Annotation of loncom/cgi/loncgi.pm, revision 1.13

1.1       matthew     1: #
                      2: # LON-CAPA helpers for cgi-bin scripts
                      3: #
1.13    ! raeburn     4: # $Id: loncgi.pm,v 1.12 2011/10/21 20:00:30 raeburn Exp $
1.1       matthew     5: #
                      6: # Copyright Michigan State University Board of Trustees
                      7: #
                      8: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
                      9: #
                     10: # LON-CAPA is free software; you can redistribute it and/or modify
                     11: # it under the terms of the GNU General Public License as published by
                     12: # the Free Software Foundation; either version 2 of the License, or
                     13: # (at your option) any later version.
                     14: #
                     15: # LON-CAPA is distributed in the hope that it will be useful,
                     16: # but WITHOUT ANY WARRANTY; without even the implied warranty of
                     17: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
                     18: # GNU General Public License for more details.
                     19: #
                     20: # You should have received a copy of the GNU General Public License
                     21: # along with LON-CAPA; if not, write to the Free Software
                     22: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
                     23: #
                     24: # /home/httpd/html/adm/gpl.txt
                     25: #
                     26: # http://www.lon-capa.org/
                     27: #
                     28: #############################################
                     29: #############################################
                     30: 
                     31: =pod
                     32: 
                     33: =head1 NAME
                     34: 
                     35: loncgi
                     36: 
                     37: =head1 SYNOPSIS
                     38: 
1.9       raeburn    39: Provides subroutines for checking a LON-CAPA cookie, loading the user's
1.11      raeburn    40: environment, and retrieving arguments passed in via a CGI's Query String.
1.1       matthew    41: 
                     42: =head1 Subroutines
                     43: 
                     44: =over 4 
                     45: 
                     46: =cut
                     47: 
                     48: #############################################
                     49: #############################################
                     50: package LONCAPA::loncgi;
                     51: 
                     52: use strict;
                     53: use warnings FATAL=>'all';
                     54: no warnings 'uninitialized';
1.2       albertel   55: 
1.7       albertel   56: use lib '/home/httpd/lib/perl/';
1.12      raeburn    57: use CGI qw(:standard);
1.1       matthew    58: use CGI::Cookie();
1.12      raeburn    59: use MIME::Types();
1.1       matthew    60: use Fcntl qw(:flock);
1.7       albertel   61: use LONCAPA;
1.1       matthew    62: use LONCAPA::Configuration();
1.8       albertel   63: use GDBM_File;
1.9       raeburn    64: use Apache::lonlocal;
1.1       matthew    65: 
                     66: my $lonidsdir;
                     67: 
                     68: BEGIN {
                     69:     my $perlvar=LONCAPA::Configuration::read_conf('loncapa.conf');
                     70:     delete $perlvar->{'lonReceipt'};
                     71:     $lonidsdir = $perlvar->{'lonIDsDir'};
                     72: }
                     73: 
1.9       raeburn    74: 
1.1       matthew    75: #############################################
                     76: #############################################
                     77: 
                     78: =pod
                     79: 
1.9       raeburn    80: =item check_cookie_and_load_env()
1.1       matthew    81: 
1.10      raeburn    82: Inputs: 1 ( optional). When called from a handler in mod_perl,
                     83:         pass in the request object.
1.1       matthew    84: 
                     85: Returns: 1 if the user has a LON-CAPA cookie 0 if not.
1.3       albertel   86: Loads the users environment into the %env hash if the cookie is correct.
1.1       matthew    87: 
                     88: =cut
                     89: 
                     90: #############################################
                     91: #############################################
                     92: sub check_cookie_and_load_env {
1.10      raeburn    93:     my ($r) = @_;
                     94:     my %cookies;
                     95:     if (ref($r)) {
                     96:         %cookies = CGI::Cookie->fetch($r);    
                     97:     } else {
                     98:         %cookies = CGI::Cookie->fetch();
                     99:     }
1.1       matthew   100:     if (exists($cookies{'lonID'}) && 
                    101:         -e "$lonidsdir/".$cookies{'lonID'}->value.".id") {
                    102:         # cookie found
                    103:         &transfer_profile_to_env($cookies{'lonID'}->value);
                    104:         return 1;
                    105:     } else {
                    106:         # No cookie found
                    107:         return 0;
                    108:     }
                    109: }
                    110: 
                    111: #############################################
                    112: #############################################
                    113: 
                    114: =pod
                    115: 
1.9       raeburn   116: =item check_cookie()
1.1       matthew   117: 
                    118: Inputs: none
                    119: 
                    120: Returns: 1 if the user has a LON-CAPA cookie and 0 if not.
                    121: 
                    122: =cut
                    123: 
                    124: #############################################
                    125: #############################################
                    126: sub check_cookie {
                    127:     my %cookies=fetch CGI::Cookie;
                    128:     if (exists($cookies{'lonID'}) && 
                    129:         -e "$lonidsdir/".$cookies{'lonID'}->value.".id") {
                    130:         # cookie found
                    131:         return 1;
                    132:     } else {
                    133:         # No cookie found
                    134:         return 0;
                    135:     }
                    136: }
                    137: 
                    138: #############################################
                    139: #############################################
                    140: 
                    141: =pod
                    142: 
1.9       raeburn   143: =item transfer_profile_to_env()
1.1       matthew   144: 
1.3       albertel  145: Load the users environment into the %env hash.
1.1       matthew   146: 
                    147: Inputs: $handle, the name of the users LON-CAPA cookie.
                    148: 
                    149: Returns: undef
                    150: 
                    151: =cut
                    152: 
                    153: #############################################
                    154: #############################################
                    155: sub transfer_profile_to_env {
                    156:     my ($handle)=@_;
1.13    ! raeburn   157:     if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_READER(),
1.8       albertel  158: 	    0640)) {
                    159: 	%Apache::lonnet::env = %disk_env;
                    160: 	untie(%disk_env);
1.1       matthew   161:     }
1.4       albertel  162:     $Apache::lonnet::env{'user.environment'} = "$lonidsdir/$handle.id";
1.1       matthew   163:     return undef;
                    164: }
                    165: 
                    166: #############################################
                    167: #############################################
                    168: 
1.9       raeburn   169: =pod
                    170: 
                    171: =item missing_cookie_msg()
                    172: 
                    173: Inputs: none
                    174: Returns: HTML for a page indicating cookie information absent. 
                    175: 
                    176: =cut
                    177: 
                    178: #############################################
                    179: #############################################
                    180: sub missing_cookie_msg {
                    181:     my %lt = &Apache::lonlocal::texthash (
                    182:                         cook => 'Bad Cookie',
                    183:                         your => 'Your cookie information is incorrect.',
                    184:              );
                    185:     return <<END;
                    186: <html>
                    187: <head><title>$lt{'cook'}</title></head>
                    188: <body>
                    189: $lt{'your'}
                    190: </body>
                    191: </html>
                    192: END
                    193: 
                    194: }
                    195: 
                    196: #############################################
                    197: #############################################
                    198: 
                    199: =pod
                    200: 
                    201: =cgi_getitems()
                    202: 
                    203: Inputs: $query (the CGI query string), and $getitems, a reference to a hash 
                    204: 
                    205: Returns: nothing
                    206: 
                    207: Side Effects: populates $getitems hash ref with key => value
                    208:               where each key is the name of the form item in the query string
                    209:               and value is an array of corresponding values. 
1.11      raeburn   210: 
1.9       raeburn   211: =cut
                    212: 
                    213: #############################################
                    214: #############################################
                    215: sub cgi_getitems {
                    216:     my ($query,$getitems)= @_;
                    217:     foreach (split(/&/,$query)) {
                    218:         my ($name, $value) = split(/=/,$_);
                    219:         $name = &unescape($name);
                    220:         $value =~ tr/+/ /;
                    221:         $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
                    222:         push(@{$$getitems{$name}},$value);
                    223:     }
                    224:     return;
                    225: }
1.6       albertel  226: 
1.12      raeburn   227: #############################################
                    228: #############################################
                    229: 
                    230: =pod
                    231: 
                    232: =cgi_header()
                    233: 
                    234: Inputs: $contenttype - Content Type (e.g., text/html or text/plain)
                    235:         $nocache     - Boolean 1 = nocache
                    236: Returns: HTTP Response headers constructed using CGI.pm
                    237: 
                    238: =cut
                    239: 
                    240: #############################################
                    241: #############################################
                    242: sub cgi_header {
                    243:     my ($contenttype,$nocache) = @_;
                    244:     my $mimetypes = MIME::Types->new;
                    245:     my %headers;
                    246:     if ($contenttype ne '') {
                    247:         if ($mimetypes->type($contenttype) ne '') {
                    248:             $headers{'-type'} = $contenttype;
                    249:         }
                    250:     }
                    251:     if ($nocache) {
                    252:        $headers{'-expires'} = 'now';
                    253:     }
                    254:     if (%headers) {
                    255:         return CGI::header(%headers);
                    256:     }
                    257:     return;
                    258: }
                    259: 
1.1       matthew   260: =pod
                    261: 
                    262: =back
                    263: 
                    264: =cut
                    265: 
                    266: 1;
                    267: 
                    268: __END__

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