## @file # (Enter your file info here) # # @copy 2007 MailerMailer LLC # $Id: CGIadapter.pm 446 2008-05-07 17:45:44Z damjan $ ## @class RWDE::Web::CGIadapter # (Enter RWDE::Web::CGIadapter info here) package RWDE::Web::CGIadapter; use strict; use warnings; use Error qw(:try); use RWDE::Exceptions; use base qw(RWDE::Logging); ## @method object get_req() # (Enter get_req info here) # @return sub get_req { my ($self, $params) = @_; return $self->{req}; } ## @method object is_https() # (Enter is_https info here) # @return sub is_https { my ($self, $params) = @_; return ($self->get_req->protocol() eq 'https'); } ## @method void check_https() # (Enter check_https info here) sub check_https { my ($self, $params) = @_; unless ($self->is_https()) { throw RWDE::DevelException({ info => 'Attempt to access secure information on a non-ssl connection.' }); } return (); } ## @method object get_uri() # (Enter get_uri info here) # @return sub get_uri { my ($self, $params) = @_; my $script_name = substr($self->get_req->script_name(), 1); #Get script returns the get part of the request if there is a // in it, we only want the script name my ($uri, $get_request) = split /\?/, $script_name; # get the uri requested return $uri; } ## @method object get_url() # (Enter get_url info here) # @return sub get_url { my ($self, $params) = @_; # get the uri requested return $self->get_req->url(); } ## @method object get_class() # (Enter get_class info here) # @return sub get_class { my ($self, $params) = @_; my $uri = $self->get_uri(); my $cpath = (split /\./, $uri)[0]; #the command path my @cparts = split /\//, $cpath; my $class = join('::', @cparts); $class = 'Command::' . $class; #replace dashes for underscores $class =~ s/-/_/g; #sanitize: remove everything that is not allowed in the package name # $class =~ /([a-zA-Z0-9_:]+)/; return ($class); } ## @method object get_formdata() # (Enter get_formdata info here) # @return sub get_formdata { my ($self, $params) = @_; my $formdata = {}; foreach my $f ($self->get_req->param()) { #each param is an array, but there most likely is just one value my @ar = $self->get_req->param($f); #if this parameter had an array of values if (scalar @ar > 1) { #pass as reference $$formdata{$f} = \@ar; } #otherwise... else { #store single value under hash key if (defined $ar[0] && $ar[0] ne '--' && $ar[0] ne '' && !($ar[0] =~ m/^\s*$/)) { $$formdata{$f} = $ar[0]; #store form data in hash } } } return $formdata; } ## @method void set_cookie($data, $insecure, $name, $uri) # (Enter set_cookie info here) # @param name (Enter explanation for param here) # @param insecure (Enter explanation for param here) # @param data (Enter explanation for param here) # @param uri (Enter explanation for param here) sub set_cookie { my ($self, $params) = @_; my $uri = $$params{uri}; my $name = $$params{name}; my $data = $$params{data}; my $cookie; if (!$$params{insecure}) { $self->check_https(); $cookie = $self->get_req->cookie( -name => $name, -value => $data, -expires => '+24h', -secure => 1 ); } else { $cookie = $self->get_req->cookie( -name => $name, -value => $data, -expires => '+24h', ); } $self->forward({ cookie => $cookie, uri => $$params{uri} }); return (); } ## @method void print_header($filename, $mimetype, $pagetype) # (Enter print_header info here) # @param filename (Enter explanation for param here) # @param pagetype (Enter explanation for param here) # @param mimetype (Enter explanation for param here) sub print_header { my ($self, $params) = @_; if ($self->{header}) { return (); } my $pagetype = $$params{pagetype}; # unless (defined $pagetype) { # throw RWDE::DevelException({ info => 'Pagetype is not defined' }); # } #if this is a standard webserver type if ($pagetype eq 'rwp') { print $self->get_req->header( -content_type => 'text/html; charset=utf-8', -pragma => 'no-cache' ); $self->{header} = 'true'; } elsif ($pagetype eq 'ttml') { print $self->get_req->header( -content_type => 'text/html; charset=utf-8', -pragma => 'no-cache' ); $self->{header} = 'true'; } elsif ($pagetype eq 'rss') { print $self->get_req->header( -content_type => 'text/xml; charset=utf-8', -pragma => 'no-cache' ); $self->{header} = 'true'; } elsif ($pagetype eq 'bin') { # Ignore header printout request for .bin's # if all required elements are not set we'll # let the command print it out later. # This avoids the problem of special casing all # standard header printouts. if (not defined $$params{filename}) { return (); } print $self->get_req->header( -type => $$params{mimetype}, -attachment => $$params{filename} ); $self->{header} = 'true'; } return (); } ## @method void forward($cookie, $uri) # (Enter forward info here) # @param cookie (Enter explanation for param here) # @param uri (Enter explanation for param here) sub forward { my ($self, $params) = @_; if ($self->{header}) { throw RWDE::DevelException({ info => 'Header was already sent to the client, redirect won\'t work' }); } my $uri = $$params{uri}; my $cookie = $$params{cookie}; print $self->get_req->redirect( -uri => $uri, -nph => 0, -cookie => $cookie, -status => '303 See Other' ); $self->{header} = 'true'; $self->{forward} = 'true'; # 301 - Moved Permanently # 302 - Found # 303 - See Other return (); } ## @method void auth_required() # (Enter auth_required info here) sub auth_required { my ($self, $params) = @_; if ($self->{header}) { throw RWDE::DevelException({ info => 'Header was already sent to the client, redirect won\'t work' }); } print $self->get_req->header( -status => '401 Authorization Required', -WWW_authenticate => 'Basic realm="DiscussThis Archives"', ); $self->{header} = 'true'; # 401 - Authorization Required return (); } ## @method object get_record() # (Enter get_record info here) # @return sub get_record { my ($self, $params) = @_; my @proof; push(@proof, "Time: " . RWDE::Time->now, "Request: " . $self->get_req->script_name(), "IP: " . $self->get_req->remote_host(), "Agent: " . ($self->get_req->user_agent() || 'N/A')); my $record .= join("\n", @proof); return $record; } ## @method object get_remote_ip() # (Enter get_remote_ip info here) # @return sub get_remote_ip { my ($self, $params) = @_; return $self->get_req->remote_host(); } ## @method object get_referer() # (Enter get_referer info here) # @return sub get_referer { my ($self, $params) = @_; return $self->get_req->referer(); } ## @method object get_contenttype() # (Enter get_contenttype info here) # @return sub get_contenttype { my ($self, $params) = @_; my $file = $self->get_req->param('upload'); my $info = $self->get_req->uploadInfo($file); return $info->{'Content-Type'}; } 1;