Annotation of loncom/cgi/loncgi.pm, revision 1.16
1.1 matthew 1: #
2: # LON-CAPA helpers for cgi-bin scripts
3: #
1.16 ! raeburn 4: # $Id: loncgi.pm,v 1.15 2016/08/01 15:19:05 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:
1.16 ! raeburn 85: Returns: 1 if the user has a LON-CAPA cookie, 0 if not.
! 86: Side effect: Loads the user's environment into the %env hash
! 87: if the cookie is correct.
1.1 matthew 88:
89: =cut
90:
91: #############################################
92: #############################################
93: sub check_cookie_and_load_env {
1.10 raeburn 94: my ($r) = @_;
1.16 ! raeburn 95: my ($hascookie,$handle) = &check_cookie($r);
! 96: if (($hascookie) && ($handle)) {
! 97: &transfer_profile_to_env($handle);
1.1 matthew 98: }
1.16 ! raeburn 99: return $hascookie;
1.1 matthew 100: }
101:
102: #############################################
103: #############################################
104:
105: =pod
106:
1.9 raeburn 107: =item check_cookie()
1.1 matthew 108:
109: Inputs: none
110:
1.16 ! raeburn 111: Array context:
! 112: Returns: (1,$handle) if the user has a LON-CAPA cookie;
! 113: (0) if user does not have a LON-CAPA cookie.
! 114:
! 115: Scalar context:
1.1 matthew 116: Returns: 1 if the user has a LON-CAPA cookie and 0 if not.
117:
118: =cut
119:
120: #############################################
121: #############################################
122: sub check_cookie {
1.16 ! raeburn 123: my ($r) = @_;
! 124: my %cookies;
! 125: if (ref($r)) {
! 126: %cookies = CGI::Cookie->fetch($r);
! 127: } else {
! 128: %cookies = CGI::Cookie->fetch();
! 129: }
! 130: if (keys(%cookies)) {
! 131: my $name = 'lonID';
! 132: my $secure = 'lonSID';
! 133: my $linkname = 'lonLinkID';
! 134: my $pubname = 'lonPubID';
! 135: my $lonid;
! 136: if (exists($cookies{$secure})) {
! 137: $lonid=$cookies{$secure};
! 138: } elsif (exists($cookies{$name})) {
! 139: $lonid=$cookies{$name};
! 140: } elsif (exists($cookies{$linkname})) {
! 141: $lonid=$cookies{$linkname};
! 142: } elsif (exists($cookies{$pubname})) {
! 143: $lonid=$cookies{$pubname};
! 144: }
! 145: if ($lonid) {
! 146: my $handle=&LONCAPA::clean_handle($lonid->value);
! 147: if ($handle) {
! 148: if (-l "$lonidsdir/$handle.id") {
! 149: my $link = readlink("$lonidsdir/$handle.id");
! 150: if ((-e $link) && ($link =~ m{^\Q$lonidsdir\E/(.+)\.id$})) {
! 151: $handle = $1;
! 152: }
! 153: }
! 154: if (-e "$lonidsdir/".$handle.".id") {
! 155: # valid cookie found
! 156: if (wantarray) {
! 157: return (1,$handle);
! 158: } else {
! 159: return 1;
! 160: }
! 161: }
! 162: }
! 163: }
! 164: }
! 165: # No valid cookie found
! 166: if (wantarray) {
! 167: return (0);
1.1 matthew 168: } else {
169: return 0;
170: }
171: }
172:
173: #############################################
174: #############################################
175:
176: =pod
177:
1.9 raeburn 178: =item transfer_profile_to_env()
1.1 matthew 179:
1.3 albertel 180: Load the users environment into the %env hash.
1.1 matthew 181:
182: Inputs: $handle, the name of the users LON-CAPA cookie.
183:
184: Returns: undef
185:
186: =cut
187:
188: #############################################
189: #############################################
190: sub transfer_profile_to_env {
191: my ($handle)=@_;
1.13 raeburn 192: if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_READER(),
1.8 albertel 193: 0640)) {
194: %Apache::lonnet::env = %disk_env;
195: untie(%disk_env);
1.1 matthew 196: }
1.4 albertel 197: $Apache::lonnet::env{'user.environment'} = "$lonidsdir/$handle.id";
1.1 matthew 198: return undef;
199: }
200:
201: #############################################
202: #############################################
203:
1.9 raeburn 204: =pod
205:
206: =item missing_cookie_msg()
207:
208: Inputs: none
209: Returns: HTML for a page indicating cookie information absent.
210:
211: =cut
212:
213: #############################################
214: #############################################
215: sub missing_cookie_msg {
216: my %lt = &Apache::lonlocal::texthash (
217: cook => 'Bad Cookie',
218: your => 'Your cookie information is incorrect.',
219: );
220: return <<END;
221: <html>
222: <head><title>$lt{'cook'}</title></head>
223: <body>
224: $lt{'your'}
225: </body>
226: </html>
227: END
228:
229: }
230:
231: #############################################
232: #############################################
233:
234: =pod
235:
236: =cgi_getitems()
237:
1.15 raeburn 238: Inputs: $query - the CGI query string (required)
239: $getitems - reference to a hash (required)
240: $possname - permitted names of keys (optional)
1.9 raeburn 241:
242: Returns: nothing
243:
244: Side Effects: populates $getitems hash ref with key => value
245: where each key is the name of the form item in the query string
246: and value is an array of corresponding values.
1.11 raeburn 247:
1.9 raeburn 248: =cut
249:
250: #############################################
251: #############################################
252: sub cgi_getitems {
1.15 raeburn 253: my ($query,$getitems,$possnames)= @_;
1.9 raeburn 254: foreach (split(/&/,$query)) {
255: my ($name, $value) = split(/=/,$_);
256: $name = &unescape($name);
1.15 raeburn 257: if (ref($possnames) eq 'ARRAY') {
258: next unless (grep(/^\Q$name\E$/,@{$possnames}));
259: }
1.9 raeburn 260: $value =~ tr/+/ /;
261: $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
262: push(@{$$getitems{$name}},$value);
263: }
264: return;
265: }
1.6 albertel 266:
1.12 raeburn 267: #############################################
268: #############################################
269:
270: =pod
271:
272: =cgi_header()
273:
274: Inputs: $contenttype - Content Type (e.g., text/html or text/plain)
275: $nocache - Boolean 1 = nocache
276: Returns: HTTP Response headers constructed using CGI.pm
277:
278: =cut
279:
280: #############################################
281: #############################################
282: sub cgi_header {
283: my ($contenttype,$nocache) = @_;
284: my $mimetypes = MIME::Types->new;
285: my %headers;
286: if ($contenttype ne '') {
287: if ($mimetypes->type($contenttype) ne '') {
288: $headers{'-type'} = $contenttype;
1.14 raeburn 289: if ($contenttype =~ m{^text/}) {
290: $headers{'-charset'} = 'utf-8';
291: }
1.12 raeburn 292: }
293: }
294: if ($nocache) {
295: $headers{'-expires'} = 'now';
296: }
297: if (%headers) {
298: return CGI::header(%headers);
299: }
300: return;
301: }
302:
1.1 matthew 303: =pod
304:
305: =back
306:
307: =cut
308:
309: 1;
310:
311: __END__
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to loncgi.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / cgi