dae7b0629a
patch by unknown@simplemachines.org r=timeless rs=brendan git-svn-id: svn://10.0.0.236/trunk@185282 18797224-902f-48f8-a5cc-f745e15eee43
311 lines
9.7 KiB
Perl
311 lines
9.7 KiB
Perl
# -*- Mode: perl; tab-width: 4; indent-tabs-mode: nil; -*-
|
|
#
|
|
# This file is MPL/GPL dual-licensed under the following terms:
|
|
#
|
|
# The contents of this file are subject to the Mozilla Public License
|
|
# Version 1.1 (the "License"); you may not use this file except in
|
|
# compliance with the License. You may obtain a copy of the License at
|
|
# http://www.mozilla.org/MPL/
|
|
#
|
|
# Software distributed under the License is distributed on an "AS IS"
|
|
# basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
|
|
# the License for the specific language governing rights and
|
|
# limitations under the License.
|
|
#
|
|
# The Original Code is PLIF 1.0.
|
|
# The Initial Developer of the Original Code is Ian Hickson.
|
|
#
|
|
# Alternatively, the contents of this file may be used under the terms
|
|
# of the GNU General Public License Version 2 or later (the "GPL"), in
|
|
# which case the provisions of the GPL are applicable instead of those
|
|
# above. If you wish to allow use of your version of this file only
|
|
# under the terms of the GPL and not to allow others to use your
|
|
# version of this file under the MPL, indicate your decision by
|
|
# deleting the provisions above and replace them with the notice and
|
|
# other provisions required by the GPL. If you do not delete the
|
|
# provisions above, a recipient may use your version of this file
|
|
# under either the MPL or the GPL.
|
|
|
|
package PLIF::Input;
|
|
use strict;
|
|
use vars qw(@ISA);
|
|
use PLIF::Service;
|
|
@ISA = qw(PLIF::Service);
|
|
1;
|
|
|
|
sub provides {
|
|
my $class = shift;
|
|
my($service) = @_;
|
|
return (($service eq 'input' and $class->applies) or
|
|
$class->SUPER::provides($service));
|
|
}
|
|
|
|
sub applies {
|
|
my $class = shift;
|
|
$class->notImplemented(); # this must be overriden by descendants
|
|
}
|
|
|
|
__DATA__
|
|
|
|
sub defaultOutputProtocol {
|
|
my $self = shift;
|
|
$self->notImplemented(); # this must be overriden by descendants
|
|
}
|
|
|
|
sub init {
|
|
my $self = shift;
|
|
my($app) = @_;
|
|
$self->SUPER::init(@_);
|
|
$self->{app} = $app; # only safe because input services are created as service instances not pure services!!!
|
|
$self->fetchArguments();
|
|
}
|
|
|
|
sub next {
|
|
return 0;
|
|
}
|
|
|
|
sub fetchArguments {} # stub
|
|
|
|
# returns the argument, potentially after asking the user or whatever.
|
|
sub getArgument {
|
|
my $self = shift;
|
|
$self->notImplemented();
|
|
}
|
|
|
|
# returns the argument if it has been provided, otherwise an empty list.
|
|
sub peekArgument {
|
|
my $self = shift;
|
|
$self->notImplemented();
|
|
}
|
|
|
|
# returns all the arguments in a form of a hash:
|
|
# key => value
|
|
sub getArguments {
|
|
my $self = shift;
|
|
$self->notImplemented();
|
|
}
|
|
|
|
# normalise the command when it is set
|
|
sub command {
|
|
my $self = shift;
|
|
if (@_) {
|
|
my($command) = @_;
|
|
$command =~ s/[^a-zA-Z0-9]/_/gos;
|
|
$self->{'command'} = $command;
|
|
}
|
|
return $self->{'command'};
|
|
}
|
|
|
|
# escape semicolons as #s and hashes as #h, etc.
|
|
sub escapeString {
|
|
my $self = shift;
|
|
my($substring) = @_;
|
|
# this is a simple escaping mechanism which gets rid of all
|
|
# semicolons without introducing any ambiguities and without
|
|
# requiring much thought when unescaping. (If you try to escape
|
|
# the separator, say ';', by doubling it, e.g. ';;', then you lose
|
|
# the possibility of a blank value, and if you escape by using one
|
|
# escape for the separator and doubling for the escape character,
|
|
# e.g. '\;' and '\\', then you get all kinds of confusion when the
|
|
# string contains lots of '\' and ';' characters.
|
|
$substring =~ s/\#/\#h/gos;
|
|
$substring =~ s/\|/\#b/gos;
|
|
$substring =~ s/\;/\#s/gos;
|
|
$substring =~ s/\ /\#w/gos;
|
|
$substring =~ s/\n/\#n/gos;
|
|
$substring =~ s/\r/\#r/gos;
|
|
$substring =~ s/\t/\#t/gos;
|
|
return $substring;
|
|
}
|
|
|
|
# escape semicolons as #s and hashes as #h, etc.
|
|
sub unescapeString {
|
|
my $self = shift;
|
|
my($substring) = @_;
|
|
$substring =~ s/\#b/\|/gos;
|
|
$substring =~ s/\#s/\;/gos;
|
|
$substring =~ s/\#w/\ /gos;
|
|
$substring =~ s/\#n/\n/gos;
|
|
$substring =~ s/\#r/\r/gos;
|
|
$substring =~ s/\#t/\t/gos;
|
|
$substring =~ s/\#h/\#/gos;
|
|
return $substring;
|
|
}
|
|
|
|
# returns all the arguments in a form of a string
|
|
sub getArgumentsAsString {
|
|
my $self = shift;
|
|
my $hash = $self->getArguments();
|
|
my $string = '';
|
|
foreach my $key (keys(%$hash)) {
|
|
$string .= $self->escapeString($key);
|
|
$string .= ';';
|
|
if (ref($hash->{$key}) eq 'ARRAY') {
|
|
if (@{$hash->{$key}}) {
|
|
foreach my $substring (@{$hash->{$key}}) {
|
|
$string .= $self->escapeString($substring);
|
|
$string .= '|';
|
|
}
|
|
chop $string;
|
|
} # else, array is empty, so ignore it
|
|
} elsif (defined($hash->{$key})) {
|
|
$string .= $self->escapeString($hash->{$key});
|
|
}
|
|
$string .= ';';
|
|
}
|
|
chop $string;
|
|
return $string;
|
|
}
|
|
|
|
# turns a string from getArgumentsAsString() back into a hash
|
|
# you can also pass an arrayref of strings
|
|
sub getArgumentsFromString {
|
|
my $self = shift;
|
|
my($string) = @_;
|
|
if (not defined($string)) {
|
|
# no string, no arguments
|
|
return {};
|
|
}
|
|
if (ref($string) eq 'ARRAY') {
|
|
# concatenate strings (possibly containing semicolons
|
|
# themselves) together to form one long string
|
|
$string = join(';', @$string);
|
|
}
|
|
my @rawHash = split(/;/, $string);
|
|
if (not @rawHash or @rawHash % 2) {
|
|
# nope! Something in this data is screwed up, let's bail out.
|
|
return {};
|
|
} else {
|
|
my $isKey = 1;
|
|
my @hash;
|
|
foreach my $substring (@rawHash) {
|
|
if ($isKey) {
|
|
push(@hash, $self->unescapeString($substring));
|
|
} else {
|
|
my @values;
|
|
foreach my $value (split(/\|/, $substring)) {
|
|
push(@values, $self->unescapeString($value));
|
|
}
|
|
push(@hash, \@values);
|
|
}
|
|
$isKey = not $isKey;
|
|
}
|
|
return { @hash };
|
|
}
|
|
}
|
|
|
|
# returns all the arguments present that begin with a specific string
|
|
# followed by a dot (the keys in the hash returned do not start with
|
|
# the prefix)
|
|
sub getArgumentsBranch {
|
|
my $self = shift;
|
|
$self->notImplemented();
|
|
}
|
|
|
|
# if a key has multiple values, getArgumentsTree drops later values on the floor
|
|
sub getArgumentsTree {
|
|
my $self = shift;
|
|
my($root) = @_;
|
|
my $arguments = $self->getArgumentsBranch($root);
|
|
my $data = {};
|
|
foreach my $argument (keys(%$arguments)) {
|
|
my @parts = split(/\./, $argument);
|
|
my $key = pop(@parts);
|
|
my $pointer = $data;
|
|
foreach my $part (@parts) {
|
|
if (not defined($pointer->{$part})) {
|
|
$pointer->{$part} = {};
|
|
} elsif (ref($pointer->{$part}) ne 'HASH') {
|
|
$pointer->{$part} = {
|
|
'' => $pointer->{$part},
|
|
};
|
|
}
|
|
$pointer = $pointer->{$part};
|
|
}
|
|
while (exists($pointer->{$key}) and (ref($pointer->{$key}) eq 'HASH')) {
|
|
$pointer = $pointer->{$key};
|
|
$key = '';
|
|
}
|
|
$pointer->{$key} = $arguments->{$argument}->[0];
|
|
# if a key has multiple values, getArgumentsTree drops later values on the floor.
|
|
# if foo.bar and foo both have values, then the keys will be $data->{'foo'}->{'bar'}
|
|
# and $data->{'foo'}->{''}.
|
|
}
|
|
return $data;
|
|
}
|
|
|
|
# out of band data like CGI version number or IRC server name
|
|
sub getMetaData {
|
|
my $self = shift;
|
|
my($field) = @_;
|
|
return undef;
|
|
}
|
|
|
|
# out of band data like cookies or user prefs
|
|
sub getSessionData {
|
|
my $self = shift;
|
|
my($field) = @_;
|
|
return undef;
|
|
}
|
|
|
|
# return 1 if we are not allowed to have side effects
|
|
sub idempotent {
|
|
return 0;
|
|
}
|
|
|
|
sub hash {
|
|
my $self = shift;
|
|
return {
|
|
'arguments' => $self->getArguments(),
|
|
'protocol' => $self->defaultOutputProtocol(),
|
|
'ua' => $self->getMetaData('UA'),
|
|
'referrer' => $self->getMetaData('referrer'),
|
|
'host' => $self->getMetaData('host'),
|
|
'acceptType' => $self->getMetaData('acceptType'),
|
|
'acceptCharset' => $self->getMetaData('acceptCharset'),
|
|
'acceptEncoding' => $self->getMetaData('acceptEncoding'),
|
|
'acceptLanguage' => $self->getMetaData('acceptLanguage'),
|
|
};
|
|
}
|
|
|
|
# 'username' and 'password' are two out of band arguments that may be
|
|
# provided as well, they are accessed as properties of the input
|
|
# object (e.g., |if (defined($input->username)) {...}|). Input
|
|
# services that have their own username syntaxes (e.g. AIM, ICQ)
|
|
# should have a username syntax of "SERVICE: <username>" e.g., my AIM
|
|
# username would be "AIM: HixieDaPixie". Other services, which get the
|
|
# username from the user (e.g. HTTP), should pass the username
|
|
# directly. See the user service for more details.
|
|
#
|
|
# 'username' should only be provided if the user attempted to log in.
|
|
#
|
|
# 'address' is an out of band argument that should only be provided
|
|
# for input devices that know the address of the user (and can thus
|
|
# construct the username).
|
|
#
|
|
# 'idempotent' is set to 1 if the request is one that is not allowed
|
|
# to have side effects. (e.g. a GET request by HTTP.)
|
|
#
|
|
# These are separate from the metadata fields, which are available
|
|
# from getMetaData(). The following metadata fields are defined:
|
|
#
|
|
# UA
|
|
# referrer
|
|
# host
|
|
# acceptType
|
|
# acceptCharset
|
|
# acceptEncoding
|
|
# acceptLanguage
|
|
#
|
|
# There may also be session-specific data accessible through
|
|
# getSessionData. This is mainly for HTTP cookies, although other input
|
|
# systems may have ways of exposing session data. To set session data,
|
|
# for now, you have to use output-specific mechanisms. (e.g. for HTTP,
|
|
# output Set-Cookie headers.) Eventually, output systems will have
|
|
# out-of-band metadata too, such as Last-Modified dates and this
|
|
# session data.
|
|
|
|
sub username {}
|
|
sub password {}
|
|
sub address {}
|