home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / xampp / xampp-perl-addon-1.4.9-installer.exe / Request.pm < prev    next >
Encoding:
Perl POD Document  |  2003-06-30  |  9.2 KB  |  307 lines
  1.  
  2. package Apache::ASP::Request;
  3.  
  4. use Apache::ASP::Collection;
  5. use strict;
  6.  
  7. sub new {
  8.     my $asp = shift;
  9.     my $r = $asp->{r};
  10.  
  11.     my $self = bless 
  12.       { 
  13.        asp => $asp,
  14. #       content => undef,
  15. #       Cookies => undef,
  16. #       FileUpload => undef,
  17. #       Form => undef,
  18. #       QueryString => undef,
  19. #       ServerVariables => undef,
  20.        Method => $r->method || 'GET',
  21.        TotalBytes => 0,
  22.       };
  23.  
  24.     # calculate whether to read POST data here
  25.     my $request_binary_read = &config($asp, 'RequestBinaryRead', undef, 1);
  26.     $asp->{request_binary_read} = $request_binary_read;
  27.  
  28.     # set up the environment, including authentication info
  29.     my $env = { %{$r->subprocess_env}, %ENV };
  30.     if(&config($asp, 'AuthServerVariables')) {
  31.     if(defined $r->get_basic_auth_pw) {
  32.         my $c = $r->connection;
  33.         #X: this needs to be extended to support Digest authentication
  34.         $env->{AUTH_TYPE} = $c->auth_type;
  35.         $env->{AUTH_USER} = $c->user;
  36.         $env->{AUTH_NAME} = $r->auth_name;
  37.         $env->{REMOTE_USER} = $c->user;
  38.         $env->{AUTH_PASSWD} = $r->get_basic_auth_pw;
  39.     }
  40.     }
  41.     $self->{'ServerVariables'} = bless $env, 'Apache::ASP::Collection';
  42.  
  43.     # assign no matter what so Form is always defined
  44.     my $form = {};
  45.     my %upload;
  46.     my $headers_in = $self->{asp}{headers_in};
  47.     if($self->{Method} eq 'POST' and $request_binary_read) {
  48.     $self->{TotalBytes} = defined($ENV{CONTENT_LENGTH}) ? $ENV{CONTENT_LENGTH} : $headers_in->get('Content-Length');
  49.     if($headers_in->get('Content-Type') =~ m|^multipart/form-data|) {
  50.         # do the logic here so that the normal form POST processing will not
  51.         # occur either
  52.         $asp->{file_upload_process} = &config($asp, 'FileUploadProcess', undef, 1);
  53.         if($asp->{file_upload_process}) {
  54.         if($asp->{file_upload_temp} = &config($asp, 'FileUploadTemp')) {
  55.             eval "use CGI;";
  56.         } else {
  57.             # default leaves no temp files for prying eyes
  58.             eval "use CGI qw(-private_tempfiles);";        
  59.         }
  60.         if($@) { 
  61.             $self->{asp}->Error("can't use file upload without CGI.pm: $@");
  62.             goto ASP_REQUEST_POST_READ_DONE;
  63.         }
  64.  
  65.         # new behavior for file uploads when FileUploadMax is exceeded,
  66.         # before it used to error abruptly, now it will simply skip the file 
  67.         # upload data
  68.         local $CGI::DISABLE_UPLOADS = $CGI::DISABLE_UPLOADS;
  69.         if($asp->{file_upload_max} = &config($asp, 'FileUploadMax')) {
  70.             if($self->{TotalBytes} > $asp->{file_upload_max} ) {
  71.             $CGI::DISABLE_UPLOADS = 1;
  72.             }
  73.         }
  74.         
  75.         $asp->{dbg} && $asp->Debug("using CGI.pm version ".
  76.                        (eval { CGI->VERSION } || $CGI::VERSION).
  77.                        " for file upload support"
  78.                       );
  79.  
  80.         my %form;
  81.         my $q = $self->{cgi} = new CGI;
  82.         $asp->Debug($q->param);
  83.         for(my @names = $q->param) {
  84.             my @params = $q->param($_);
  85.             $form{$_} = @params > 1 ? [ @params ] : $params[0];
  86.             if(ref($form{$_}) eq 'Fh') {
  87.             my $fh = $form{$_};
  88.             binmode $fh if $asp->{win32};
  89.             $upload{$_} = $q->uploadInfo($fh);
  90.             if($asp->{file_upload_temp}) {
  91.                 $upload{$_}{TempFile} = $q->tmpFileName($fh);
  92.                 $upload{$_}{TempFile} =~ s|^/+|/|;
  93.             }
  94.             $upload{$_}{BrowserFile} = "$fh";
  95.             $upload{$_}{FileHandle} = $fh;
  96.             $upload{$_}{ContentType} = $upload{$_}{'Content-Type'};
  97.             # tie the file upload reference to a collection... %upload
  98.             # may be many file uploads note.
  99.             $upload{$_} = bless $upload{$_}, 'Apache::ASP::Collection';
  100.             $asp->{dbg} && $asp->Debug("file upload field processed for \$Request->{FileUpload}{$_}", $upload{$_});
  101.             }
  102.         }
  103.         $form = \%form;
  104.         } else {
  105.         $self->{asp}->Debug("FileUploadProcess is disabled, file upload data in \$Request->BinaryRead");
  106.         }
  107.  
  108.     } else {
  109.         # Only tie to STDIN if we have cached contents
  110.         # don't untie *STDIN until DESTROY, so filtered handlers
  111.         # have an opportunity to use any cached contents that may exist
  112.         if(my $len = $self->{TotalBytes}) {
  113.         $self->{content} = $self->BinaryRead($len) || '';
  114.         tie(*STDIN, 'Apache::ASP::Request', $self);
  115.         if($headers_in->get('Content-Type') eq 'application/x-www-form-urlencoded') {
  116.             $form = &ParseParams($self, \$self->{content});
  117.         } else {
  118.             $form = {};
  119.         }
  120.         }
  121.     }
  122.     }
  123.  
  124. ASP_REQUEST_POST_READ_DONE:
  125.  
  126.     $self->{'Form'} = bless $form, 'Apache::ASP::Collection';
  127.     $self->{'FileUpload'} = bless \%upload, 'Apache::ASP::Collection';
  128.     my $query = $r->args();
  129.     my $parsed_query = $query ? &ParseParams($self, \$query) : {};
  130.     $self->{'QueryString'} = bless $parsed_query, 'Apache::ASP::Collection';
  131.  
  132.     if(&config($asp, 'RequestParams')) {
  133.     $self->{'Params'} = bless { %$parsed_query, %$form }, 'Apache::ASP::Collection';
  134.     } 
  135.  
  136.     # do cookies now
  137.     my %cookies; 
  138.     if(my $cookie = $headers_in->get('Cookie')) {
  139.     my @parts = split(/;\s*/, ($cookie || ''));
  140.     for(@parts) {    
  141.         my($name, $value) = split(/\=/, $_, 2);
  142.         $name = &Unescape($self, $name);
  143.         
  144.         next if ($name eq $Apache::ASP::SessionCookieName);
  145.         next if $cookies{$name}; # skip dup's
  146.         
  147.         $cookies{$name} = ($value =~ /\=/) ? 
  148.           &ParseParams($self, $value) : &Unescape($self, $value);
  149.     }
  150.     }
  151.     $self->{Cookies} = bless \%cookies, 'Apache::ASP::Collection';
  152.  
  153.     $self;
  154. }
  155.  
  156. sub DESTROY {
  157.     my $self = shift;
  158.  
  159.     if($self->{cgi}) {
  160.     # make sure CGI file handles are freed
  161.     $self->{cgi}->DESTROY();
  162.     $self->{cgi} = undef;
  163.     }
  164.  
  165.     for(keys %{$self->{FileUpload}}) {
  166.     my $upload = $self->{FileUpload}{$_};
  167.     $self->{Form}{$_} = undef;
  168.     if($upload->{FileHandle}) {
  169.         close $upload->{FileHandle};
  170.         # $self->{asp}->Debug("closing fh $upload->{FileHandle}");
  171.     }
  172.     $self->{FileUpload}{$_} = undef;
  173.     }
  174.  
  175.     %$self = ();
  176. }
  177.  
  178. # just returns itself
  179. sub TIEHANDLE { $_[1] };
  180.  
  181. # just spill the cache into the scalar, so multiple reads are
  182. # fine... whoever is reading from the cached contents must
  183. # be reading the whole thing just once for this to work, 
  184. # which is fine for CGI.pm
  185. sub READ {
  186.     my $self = $_[0];
  187.     $_[1] ||= '';
  188.     $_[1] .= $self->{content};
  189.     $self->{ServerVariables}{CONTENT_LENGTH};
  190. }
  191.  
  192. sub BINMODE { };
  193.  
  194. # COLLECTIONS, normal, Cookies are special, with the dictionary lookup
  195. # directly aliased as this should be faster than autoloading
  196. sub Form { shift->{Form}->Item(@_) }
  197. sub FileUpload { shift->{FileUpload}->Item(@_) }
  198. sub QueryString { shift->{QueryString}->Item(@_) }
  199. sub ServerVariables { shift->{ServerVariables}->Item(@_) }
  200.  
  201. sub Params {
  202.     my $self = shift; 
  203.     $self->{Params}
  204.       || die("\$Request->Params object does not exist, enable with 'PerlSetVar RequestParams 1'");
  205.     $self->{Params}->Item(@_);
  206. }
  207.  
  208. sub BinaryRead {
  209.     my($self, $length) = @_;
  210.     my $data;
  211.     return undef unless $self->{TotalBytes};
  212.  
  213.     if(ref(tied(*STDIN)) && tied(*STDIN)->isa('Apache::ASP::Request')) {
  214.     if($self->{TotalBytes}) {
  215.         if(defined $length) {
  216.         return substr($self->{content}, 0, $length);
  217.         } else {
  218.         return $self->{content}
  219.         }
  220.     } else {
  221.         return undef;
  222.     }
  223.     } else {
  224.     defined($length) || ( $length = $self->{TotalBytes} );
  225.     my $asp = $self->{asp};
  226.     my $r = $asp->{r};
  227.     if(! $ENV{MOD_PERL}) {
  228.         my $rv = sysread(*STDIN, $data, $length, 0);
  229.         $asp->{dbg} && $asp->Debug("read $rv bytes from STDIN for CGI mode, tried $length bytes");
  230.     } else {
  231.         $r->read($data, $length);
  232.         $asp->{dbg} && $asp->Debug("read ".length($data)." bytes, tried $length bytes");
  233.     }
  234.     return $data;
  235.     }
  236. }
  237.  
  238. sub Cookies {
  239.     my($self, $name, $key) = @_;
  240.  
  241.     if(! $name) {
  242.     $self->{Cookies};
  243.     } elsif($key) {
  244.     $self->{Cookies}{$name}{$key};
  245.     } else {
  246.     # when we just have the name, are we expecting a dictionary or not
  247.     my $cookie = $self->{Cookies}{$name};
  248.     if(ref $cookie && wantarray) {
  249.         return %$cookie;
  250.     } else {
  251.         # CollectionItem support here one day, to not return
  252.         # an undef object, CollectionItem needs tied hash support
  253.         return $cookie;
  254.     }
  255.     }
  256. }
  257.  
  258. sub ParseParams {
  259.     my($self, $string) = @_;
  260.     ($string = $$string) if ref($string); ## faster if we pass a ref for a big string
  261.  
  262.     my %params;
  263.     defined($string) || return(\%params);
  264.     my @params = split /[\&\;]/, $string, -1;
  265.  
  266.     # we have to iterate through the params here to collect multiple values for 
  267.     # the same param, say from a multiple select statement
  268.     for my $pair (@params) {
  269.     my($key, $value) = map { 
  270.         # inline for greater efficiency
  271.         # &Unescape($self, $_) 
  272.         my $todecode = $_;
  273.         $todecode =~ tr/+/ /;       # pluses become spaces
  274.         $todecode =~ s/%([0-9a-fA-F]{2})/chr(hex($1))/ge;
  275.         $todecode;
  276.     } split (/\=/, $pair, 2);
  277.     if(defined $params{$key}) {
  278.         my $collect = $params{$key};
  279.  
  280.         if(ref $collect) {
  281.         # we have already collected more than one param for that key
  282.         push(@{$collect}, $value);
  283.         } else {
  284.         # this is the second value for a key we've seen, start array
  285.         $params{$key} = [$collect, $value];
  286.         }
  287.     } else {
  288.         # normal use, one to one key value pairs, just set
  289.         $params{$key} = $value;
  290.     }
  291.     }
  292.  
  293.     \%params;
  294. }
  295.  
  296. # unescape URL-encoded data
  297. sub Unescape {
  298.     my $todecode = $_[1];
  299.     $todecode =~ tr/+/ /;       # pluses become spaces
  300.     $todecode =~ s/%([0-9a-fA-F]{2})/chr(hex($1))/ge;
  301.     $todecode;
  302. }
  303.  
  304. *config = *Apache::ASP::config;
  305.  
  306. 1;
  307.