Return to loncgi.pm CVS log

Up to [LON-CAPA] / loncom / cgi

- New routine: loncgi::cgi_header() generates HTTP response headers using CGI.pm
- New arg in lonauthcgi::can_view() - $domain (optional),
  used if $page is needed for a specific domain.
- New return value: either 1, or a &-separated list of domains for which access is
  allowed.

    1: #
    2: # LON-CAPA helpers for cgi-bin scripts
    3: #
    4: # $Id: loncgi.pm,v 1.12 2011/10/21 20:00:30 raeburn Exp $
    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: 
   39: Provides subroutines for checking a LON-CAPA cookie, loading the user's
   40: environment, and retrieving arguments passed in via a CGI's Query String.
   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';
   55: 
   56: use lib '/home/httpd/lib/perl/';
   57: use CGI qw(:standard);
   58: use CGI::Cookie();
   59: use MIME::Types();
   60: use Fcntl qw(:flock);
   61: use LONCAPA;
   62: use LONCAPA::Configuration();
   63: use GDBM_File;
   64: use Apache::lonlocal;
   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: 
   74: 
   75: #############################################
   76: #############################################
   77: 
   78: =pod
   79: 
   80: =item check_cookie_and_load_env()
   81: 
   82: Inputs: 1 ( optional). When called from a handler in mod_perl,
   83:         pass in the request object.
   84: 
   85: Returns: 1 if the user has a LON-CAPA cookie 0 if not.
   86: Loads the users environment into the %env hash if the cookie is correct.
   87: 
   88: =cut
   89: 
   90: #############################################
   91: #############################################
   92: sub check_cookie_and_load_env {
   93:     my ($r) = @_;
   94:     my %cookies;
   95:     if (ref($r)) {
   96:         %cookies = CGI::Cookie->fetch($r);    
   97:     } else {
   98:         %cookies = CGI::Cookie->fetch();
   99:     }
  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: 
  116: =item check_cookie()
  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: 
  143: =item transfer_profile_to_env()
  144: 
  145: Load the users environment into the %env hash.
  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)=@_;
  157:    if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_READER(),
  158: 	    0640)) {
  159: 	%Apache::lonnet::env = %disk_env;
  160: 	untie(%disk_env);
  161:     }
  162:     $Apache::lonnet::env{'user.environment'} = "$lonidsdir/$handle.id";
  163:     return undef;
  164: }
  165: 
  166: #############################################
  167: #############################################
  168: 
  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. 
  210: 
  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: }
  226: 
  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: 
  260: =pod
  261: 
  262: =back
  263: 
  264: =cut
  265: 
  266: 1;
  267: 
  268: __END__