[BACK]Return to loncgi.pm CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom / cgi

Diff for /loncom/cgi/loncgi.pm between versions 1.11 and 1.16

version 1.11, 2008/12/25 01:51:03 version 1.16, 2018/07/04 16:58:26
Line 54  use warnings FATAL=>'all'; Line 54  use warnings FATAL=>'all';
 no warnings 'uninitialized';  no warnings 'uninitialized';
   
 use lib '/home/httpd/lib/perl/';  use lib '/home/httpd/lib/perl/';
 use CGI();  use CGI qw(:standard);
 use CGI::Cookie();  use CGI::Cookie();
   use MIME::Types();
 use Fcntl qw(:flock);  use Fcntl qw(:flock);
 use LONCAPA;  use LONCAPA;
 use LONCAPA::Configuration();  use LONCAPA::Configuration();
Line 81  BEGIN { Line 82  BEGIN {
 Inputs: 1 ( optional). When called from a handler in mod_perl,  Inputs: 1 ( optional). When called from a handler in mod_perl,
         pass in the request object.          pass in the request object.
   
 Returns: 1 if the user has a LON-CAPA cookie 0 if not.  Returns: 1 if the user has a LON-CAPA cookie, 0 if not.
 Loads the users environment into the %env hash if the cookie is correct.  Side effect: Loads the user's environment into the %env hash
                if the cookie is correct.
   
 =cut  =cut
   
Line 90  Loads the users environment into the %en Line 92  Loads the users environment into the %en
 #############################################  #############################################
 sub check_cookie_and_load_env {  sub check_cookie_and_load_env {
     my ($r) = @_;      my ($r) = @_;
     my %cookies;      my ($hascookie,$handle) = &check_cookie($r);
     if (ref($r)) {      if (($hascookie) && ($handle)) {
         %cookies = CGI::Cookie->fetch($r);              &transfer_profile_to_env($handle);
     } else {  
         %cookies = CGI::Cookie->fetch();  
     }  
     if (exists($cookies{'lonID'}) &&   
         -e "$lonidsdir/".$cookies{'lonID'}->value.".id") {  
         # cookie found  
         &transfer_profile_to_env($cookies{'lonID'}->value);  
         return 1;  
     } else {  
         # No cookie found  
         return 0;  
     }      }
       return $hascookie;
 }  }
   
 #############################################  #############################################
Line 116  sub check_cookie_and_load_env { Line 108  sub check_cookie_and_load_env {
   
 Inputs: none  Inputs: none
   
   Array context:
   Returns: (1,$handle) if the user has a LON-CAPA cookie;
   (0) if user does not have a LON-CAPA cookie.
   
   Scalar context:
 Returns: 1 if the user has a LON-CAPA cookie and 0 if not.  Returns: 1 if the user has a LON-CAPA cookie and 0 if not.
   
 =cut  =cut
Line 123  Returns: 1 if the user has a LON-CAPA co Line 120  Returns: 1 if the user has a LON-CAPA co
 #############################################  #############################################
 #############################################  #############################################
 sub check_cookie {  sub check_cookie {
     my %cookies=fetch CGI::Cookie;      my ($r) = @_;
     if (exists($cookies{'lonID'}) &&       my %cookies;
         -e "$lonidsdir/".$cookies{'lonID'}->value.".id") {      if (ref($r)) {
         # cookie found          %cookies = CGI::Cookie->fetch($r);
         return 1;      } else {
           %cookies = CGI::Cookie->fetch();
       }
       if (keys(%cookies)) {
           my $name = 'lonID';
           my $secure = 'lonSID';
           my $linkname = 'lonLinkID';
           my $pubname = 'lonPubID';
           my $lonid;
           if (exists($cookies{$secure})) {
               $lonid=$cookies{$secure};
           } elsif (exists($cookies{$name})) {
               $lonid=$cookies{$name};
           } elsif (exists($cookies{$linkname})) {
               $lonid=$cookies{$linkname};
           } elsif (exists($cookies{$pubname})) {
               $lonid=$cookies{$pubname};
           }
           if ($lonid) {
               my $handle=&LONCAPA::clean_handle($lonid->value);
               if ($handle) {
                   if (-l "$lonidsdir/$handle.id") {
                       my $link = readlink("$lonidsdir/$handle.id");
                       if ((-e $link) && ($link =~ m{^\Q$lonidsdir\E/(.+)\.id$})) {
                           $handle = $1;
                       }
                   }
                   if (-e "$lonidsdir/".$handle.".id") {
                       # valid cookie found
                       if (wantarray) {
                           return (1,$handle);
                       } else {
                           return 1;
                       }
                   }
               }
           }
       }
       # No valid cookie found
       if (wantarray) {
           return (0);
     } else {      } else {
         # No cookie found  
         return 0;          return 0;
     }      }
 }  }
Line 153  Returns: undef Line 189  Returns: undef
 #############################################  #############################################
 sub transfer_profile_to_env {  sub transfer_profile_to_env {
     my ($handle)=@_;      my ($handle)=@_;
    if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_READER(),      if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_READER(),
     0640)) {      0640)) {
  %Apache::lonnet::env = %disk_env;   %Apache::lonnet::env = %disk_env;
  untie(%disk_env);   untie(%disk_env);
Line 199  END Line 235  END
   
 =cgi_getitems()  =cgi_getitems()
   
 Inputs: $query (the CGI query string), and $getitems, a reference to a hash   Inputs: $query - the CGI query string (required)
           $getitems - reference to a hash (required)
           $possname - permitted names of keys (optional)
   
 Returns: nothing  Returns: nothing
   
Line 212  Side Effects: populates $getitems hash r Line 250  Side Effects: populates $getitems hash r
 #############################################  #############################################
 #############################################  #############################################
 sub cgi_getitems {  sub cgi_getitems {
     my ($query,$getitems)= @_;      my ($query,$getitems,$possnames)= @_;
     foreach (split(/&/,$query)) {      foreach (split(/&/,$query)) {
         my ($name, $value) = split(/=/,$_);          my ($name, $value) = split(/=/,$_);
         $name = &unescape($name);          $name = &unescape($name);
           if (ref($possnames) eq 'ARRAY') {
               next unless (grep(/^\Q$name\E$/,@{$possnames}));
           }
         $value =~ tr/+/ /;          $value =~ tr/+/ /;
         $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;          $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
         push(@{$$getitems{$name}},$value);          push(@{$$getitems{$name}},$value);
     }      }
     return;      return;
 }  }
   
   #############################################
   #############################################
   
   =pod
   
   =cgi_header()
   
   Inputs: $contenttype - Content Type (e.g., text/html or text/plain)
           $nocache     - Boolean 1 = nocache
   Returns: HTTP Response headers constructed using CGI.pm
   
   =cut
   
   #############################################
   #############################################
   sub cgi_header {
       my ($contenttype,$nocache) = @_;
       my $mimetypes = MIME::Types->new;
       my %headers;
       if ($contenttype ne '') {
           if ($mimetypes->type($contenttype) ne '') {
               $headers{'-type'} = $contenttype;
               if ($contenttype =~ m{^text/}) {
                   $headers{'-charset'} = 'utf-8';
               }
           }
       }
       if ($nocache) {
          $headers{'-expires'} = 'now';
       }
       if (%headers) {
           return CGI::header(%headers);
       }
       return;
   }
   
 =pod  =pod
   
Removed from v.1.11  
changed lines
  Added in v.1.16

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>