Annotation of loncom/cgi/loncgi.pm, revision 1.15
1.1 matthew 1: #
2: # LON-CAPA helpers for cgi-bin scripts
3: #
1.15 ! raeburn 4: # $Id: loncgi.pm,v 1.14 2014/10/14 19:54:00 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:
1.15 ! raeburn 203: Inputs: $query - the CGI query string (required)
! 204: $getitems - reference to a hash (required)
! 205: $possname - permitted names of keys (optional)
1.9 raeburn 206:
207: Returns: nothing
208:
209: Side Effects: populates $getitems hash ref with key => value
210: where each key is the name of the form item in the query string
211: and value is an array of corresponding values.
1.11 raeburn 212:
1.9 raeburn 213: =cut
214:
215: #############################################
216: #############################################
217: sub cgi_getitems {
1.15 ! raeburn 218: my ($query,$getitems,$possnames)= @_;
1.9 raeburn 219: foreach (split(/&/,$query)) {
220: my ($name, $value) = split(/=/,$_);
221: $name = &unescape($name);
1.15 ! raeburn 222: if (ref($possnames) eq 'ARRAY') {
! 223: next unless (grep(/^\Q$name\E$/,@{$possnames}));
! 224: }
1.9 raeburn 225: $value =~ tr/+/ /;
226: $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
227: push(@{$$getitems{$name}},$value);
228: }
229: return;
230: }
1.6 albertel 231:
1.12 raeburn 232: #############################################
233: #############################################
234:
235: =pod
236:
237: =cgi_header()
238:
239: Inputs: $contenttype - Content Type (e.g., text/html or text/plain)
240: $nocache - Boolean 1 = nocache
241: Returns: HTTP Response headers constructed using CGI.pm
242:
243: =cut
244:
245: #############################################
246: #############################################
247: sub cgi_header {
248: my ($contenttype,$nocache) = @_;
249: my $mimetypes = MIME::Types->new;
250: my %headers;
251: if ($contenttype ne '') {
252: if ($mimetypes->type($contenttype) ne '') {
253: $headers{'-type'} = $contenttype;
1.14 raeburn 254: if ($contenttype =~ m{^text/}) {
255: $headers{'-charset'} = 'utf-8';
256: }
1.12 raeburn 257: }
258: }
259: if ($nocache) {
260: $headers{'-expires'} = 'now';
261: }
262: if (%headers) {
263: return CGI::header(%headers);
264: }
265: return;
266: }
267:
1.1 matthew 268: =pod
269:
270: =back
271:
272: =cut
273:
274: 1;
275:
276: __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