lib/CXGN/Apache/Request.pm

   1
   2 =head1 NAME
   3
   4 CXGN::Apache::Request
   5
   6 =head1 DESCRIPTION
   7
   8 This module is used mainly by CXGN::Apache::Error to provide detailed information about who caused a page error and how they caused it.
   9
  10 =head1 NON-OBJECT METHODS
  11
  12 =head2 as_verbose_string
  13
  14 A more detailed version of Apache::Request::as_string. It returns a big string full of information about who is requesting a page, how they are requesting it, etc.
  15
  16 =head2 client_name
  17
  18 Get the name of the client and also note if the client is from SGN by returning a second parameter.
  19
  20 =head2 page_name
  21
  22 Returns the page_name by extracting it from the current page request. Note: /tools/does_not_exist.pl needs it to be done this way, rather than asking for this information from perl environment variables, because "does_not_exist.pl" (the page the client was sent to) would be returned by the environment variables, rather than the page the client originally requested.
  23
  24 =head2 time
  25
  26 Returns a string indicating the time in Ithaca NY. Used to associate a time with an error report.
  27
  28 =head1 AUTHOR
  29
  30 john binns - John Binns <zombieite@gmail.com>
  31
  32 =cut
  33
  34 package CXGN::Apache::Request;
  35 use strict;
  36
  37 use Data::Dumper;
  38 use URI::Escape;
  39 use Socket;    #used to get hostname from IP
  40 our $CORNELL_IP_MATCH = '132.236.157.';
  41 our $OTHER_KNOWN_IPS  = {
  42     '127.0.0.1'    => 'localhost',
  43     '24.22.41.189' => 'Rob'
  44 };
  45
  46 sub as_verbose_string {
  47     my $verbose_string = '';
  48     my $time           = &time();
  49     my ( $client_name, $cornell_client_name ) = &client_name();
  50     my ( $page_name,   $parameters )          = &page_name();
  51     if ($parameters) {
  52         $parameters =~ s/&amp;/\n/g;
  53         $parameters =~ s/&/\n/g;
  54         $parameters =~ s/;/\n/g;
  55     }
  56
  57      #    my $login=CXGN::Login->new();
  58      #    my $id=$login->has_session();
  59      $verbose_string .= "\nrequest\n--------------\n";
  60      $verbose_string .=
  61        "$page_name on SGN requested by $client_name at $time\n\n";
  62      if ($parameters) { $verbose_string .= "with parameters:\n$parameters\n\n"; }
  63
  64 #     #    if($id){$verbose_string.="with login ID: $id\n\n";}
  65     $verbose_string .= "Request Environment:\n";
  66     $verbose_string .= Dumper(\%ENV);
  67     return $verbose_string;
  68 }
  69
  70 sub time {
  71     my ( $sec, $min, $hour, $day, $month, $year ) = localtime();
  72     $sec = sprintf( "%02d", $sec );
  73     $min = sprintf( "%02d", $min );
  74     $month += 1;
  75     $year = sprintf( "%02d", $year % 100 );
  76     return "$month/$day-$hour:$min:$sec";
  77 }
  78
  79 sub client_name {
  80     my $client_name = my $remote_host = CGI->new->remote_host;
  81     my $known_client_name;
  82     if ( $remote_host =~ /$CORNELL_IP_MATCH/ ) {
  83         if ( $client_name =~ /(\w+)\.sgn\.cornell\.edu/ ) {
  84             $known_client_name = $1;
  85         }
  86         else {
  87             $known_client_name = $client_name;
  88         }
  89     }
  90     else {
  91         $known_client_name = $OTHER_KNOWN_IPS->{$remote_host};
  92     }
  93     return ( $client_name, $known_client_name );
  94 }
  95
  96 sub full_page_name {
  97     my ($request_string) = @_
  98       ; #you can send in a string if you want (does_not_exist.pl does this for reasons of its own)
  99     my $parameter_string = '';
 100     $request_string ||= CGI->new->url( -query => 1 );
 101     if ( $request_string =~ / (.+) /i
 102       ) #if the request says "GET /cgi-bin/mypage.pl?arg=1 HTTP/1.1" we want the "/cgi-bin/mypage.pl?arg=1" between the space characters
 103     {
 104         $request_string = $1;
 105     }
 106     $request_string = URI::Escape::uri_unescape($request_string)
 107       ;    #usually unnecessary, but occasionally we get wacky encoded requests
 108     if ( $request_string =~
 109         /(.+)\?(.*)/ )    #if the request string has parameters, remove them
 110     {
 111         $request_string   = $1;
 112         $parameter_string = $2;
 113     }
 114     return ( $request_string, $parameter_string );
 115 }
 116
 117 sub page_name {
 118     my ($request_string) = @_
 119       ; #you can send in a string if you want (does_not_exist.pl does this for reasons of its own)
 120     my $parameter_string = '';
 121     ( $request_string, $parameter_string ) = full_page_name($request_string);
 122     unless ($parameter_string) { $parameter_string = ''; }
 123     if ( $request_string =~
 124         /\/((\w|-)+\.(pl|html|htm|js|gif|jpg|css|png|ppt|xls|pdf|cgi))/i
 125       )    #if we can recognize the script name in the request string, get it
 126     {
 127         if ( $1 ne 'index.pl'
 128           ) #index.pl is not descriptive enough, so don't use it if that's all we have
 129         {
 130             $request_string = $1;
 131         }
 132     }
 133     return ( $request_string, $parameter_string );
 134 }
 135
 136 1;