Annotation of loncom/cgi/listcodes.pl, revision 1.2
1.1 raeburn 1: #!/usr/bin/perl
2: $|=1;
3: # Listing of domain's courses with unique six character codes
1.2 ! raeburn 4: # $Id: listcodes.pl,v 1.1 2014/01/01 17:41:51 raeburn Exp $
1.1 raeburn 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: listcodes.pl
36:
37: =head1 SYNOPSIS
38:
39: CGI script to display course codes and associated
40: information as plain text or XML.
41:
42: Possible formats are: plain text (CSV), XML or HTML
43: and the desired format is specified in query string.
44:
45: The query string should also contain the domain for
46: which this data is being requested.
47:
48: The current server needs to be the homeserver of the
49: special domconfig "user", which will be the primary
50: library server in the domain.
51:
52: =head1 Subroutines
53:
54: =over 4
55:
56: =cut
57:
58: #############################################
59: #############################################
60:
61: use strict;
62:
63: use lib '/home/httpd/lib/perl/';
64: use LONCAPA::loncgi;
65: use LONCAPA::lonauthcgi;
66: use Apache::lonnet();
67: use Apache::loncommon();
68: use Apache::lonlocal;
69: use LONCAPA;
70:
71: &main();
72: exit 0;
73:
74: #############################################
75: #############################################
76:
77: =pod
78:
79: =item main()
80:
81: Inputs: None
82:
83: Returns: Nothing
84:
85: Description: Main program. Determines if requesting IP is allowed
86: to view unique codes for domains for which this server
87: is the primary library server.
88:
89: =cut
90:
91: #############################################
92: #############################################
93:
94: sub main {
95: my (%gets,$reqdom,$domdesc);
96: &LONCAPA::loncgi::cgi_getitems($ENV{'QUERY_STRING'},\%gets);
97: if (ref($gets{'domain'}) eq 'ARRAY') {
98: $gets{'domain'}->[0] =~ s/^\s+|\s+$//g;
99: if ($gets{'domain'}->[0] =~ /^$LONCAPA::match_domain$/) {
100: my $domdesc = &Apache::lonnet::domain($gets{'domain'}->[0]);
101: unless ($domdesc eq '') {
102: $reqdom = $gets{'domain'}->[0];
103: }
104: }
105: }
106: if ($reqdom eq '') {
107: print &LONCAPA::loncgi::cgi_header('text/plain',1);
108: &Apache::lonlocal::get_language_handle();
109: print &mt('The query string needs to include domain=dom, where dom is a valid domain.')."\n";
110: return;
111: }
112: my @hosts = &Apache::lonnet::current_machine_ids();
113: my $confname = $reqdom.'-domainconfig';
114: my $confhome = &Apache::lonnet::homeserver($confname,$reqdom);
115: unless (grep(/^\Q$confhome\E$/,@hosts)) {
116: print &LONCAPA::loncgi::cgi_header('text/plain',1);
117: &Apache::lonlocal::get_language_handle();
118: print &mt("This server is not the home server for the domain config 'user' for the requested domain.")."\n".
119: &mt('You will need to access this information from: [_1].',$confhome);
120: return;
121: }
122: my $remote_ip = $ENV{'REMOTE_ADDR'};
123: my $allowed;
124: if (&LONCAPA::lonauthcgi::check_ipbased_access('uniquecodes',$remote_ip)) {
125: $allowed = 1;
126: } elsif (&LONCAPA::loncgi::check_cookie_and_load_env()) {
127: $allowed = &LONCAPA::lonauthcgi::can_view('uniquecodes');
128: }
129: &LONCAPA::loncgi::check_cookie_and_load_env();
130: &Apache::lonlocal::get_language_handle();
131: if ($allowed ne '') {
132: my ($format,@okdoms);
133: unless ($allowed == 1) {
134: @okdoms = split(/\&/,$allowed);
135: unless (grep(/^\Q$reqdom\E$/,@okdoms)) {
136: print &LONCAPA::loncgi::cgi_header('text/plain',1);
137: print &mt('You do not have access rights to view course codes for the requested domain.')."\n";
138: return;
139: }
140: }
141: if (ref($gets{'format'}) eq 'ARRAY') {
142: $format = $gets{'format'}->[0];
143: }
144: if ($format eq 'html') {
145: print &LONCAPA::loncgi::cgi_header('text/html',1);
146: } elsif ($format eq 'xml') {
147: print &LONCAPA::loncgi::cgi_header('text/xml',1);
148: } else {
149: $format = 'csv';
150: print &LONCAPA::loncgi::cgi_header('text/plain',1);
151: }
152: my ($count,$output) = &show_results($reqdom,$format,\%gets);
153: if ($output) {
154: if ($format eq 'html') {
155: &start_html($reqdom,&mt('LON-CAPA Courses with Unique Six Character Codes'));
156: print $output;
157: &end_html;
158: } elsif ($count) {
159: if ($format eq 'xml') {
160: &start_xml();
161: }
162: print $output;
163: }
164: }
165: } else {
166: print &LONCAPA::loncgi::cgi_header('text/plain',1);
167: &LONCAPA::lonauthcgi::unauthorized_msg('uniquecodes');
168: }
169: return;
170: }
171:
172: #############################################
173: #############################################
174:
175: =pod
176:
177: =item show_results()
178:
179: Inputs: $reqdom - domain for which unique codes and course information
180: are to be shown.
181: $format - format for output, one of: html, xml or csv. csv
182: is the default, if no format specified.
183: $getshash - references to hash of key=value pairs from the
184: query string. Keys which will be used are: code,
185: and num.
186:
187: Returns: $count - number of items detected
188: $output - output to display.
189: If there are no matches, or the input argument
190: (code or num) was invalid, no output is returned
191: unless the requested format is html.
192: Note: in the case of a query without a
193: specific code or courseID, the output
194: is printed within the &show_results()
195: routine when looping over courses retrieved
196: by a call to lonnet::courseiddump, so $output
197: is blank, in this case, unless no courses match.
198:
199: Description: Displays LON-CAPA courseID, unique codes, course owner,
200: and course title.
201:
202: Data displayed can be a single record, if the query string
203: contains code=<six character code> or
204: num=<LON CAPA course ID>.
205:
206: Data formats are: html, xml, or plain text (csv).
207:
208: =cut
209:
210: #############################################
211: #############################################
212:
213: sub show_results {
214: my ($reqdom,$format,$gethash) = @_;
215: my ($uniquecode,$cnum,$output);
216: if (ref($gethash) eq 'HASH') {
217: if (ref($gethash->{'code'}) eq 'ARRAY') {
218: $gethash->{'code'}->[0] =~ s/^\s+|\s+$//g;
219: if ($gethash->{'code'}->[0] =~ /^\w{6}$/) {
220: $uniquecode = $gethash->{'code'}->[0];
221: } else {
222: if ($format eq 'html') {
223: $output = &mt('Invalid code');
224: }
225: return (0,$output);
226: }
227: }
228: if (ref($gethash->{'num'}) eq 'ARRAY') {
229: $gethash->{'num'}->[0] =~ s/^\s+|\s+$//g;
230: if ($gethash->{'num'}->[0] =~ /^$LONCAPA::match_courseid$/) {
231: my $chome = &Apache::lonnet::homeserver($gethash->{'num'}->[0],$reqdom);
232: if ($chome ne 'no_host') {
233: $cnum = $gethash->{'num'}->[0];
234: } else {
235: if ($format eq 'html') {
236: $output = &mt('Course ID does not exist');
237: }
238: return (0,$output);
239: }
240: } else {
241: if ($format eq 'html') {
242: $output = &mt('Invalid course ID');
243: }
244: return (0,$output);
245: }
246: }
247: }
248: if ($uniquecode) {
249: my $confname = $reqdom.'-domainconfig';
250: my %codes = &Apache::lonnet::get('uniquecodes',[$uniquecode],$reqdom,$confname);
251: if ($codes{$uniquecode}) {
252: my %courseinfo = &Apache::lonnet::coursedescription($reqdom.'_'.$codes{$uniquecode},{one_time => 1});
253: if (keys(%courseinfo)) {
254: $output = &buildline($format,$codes{$uniquecode},\%courseinfo);
255: return (1,$output);
256: } else {
257: if ($format eq 'html') {
258: $output = &mt('Code matched, but course ID to which this mapped is invalid.');
259: }
260: return (0,$output);
261: }
262: } else {
263: if ($format eq 'html') {
264: $output = &mt('No match');
265: }
266: return (0,$output);
267: }
268: }
269: if ($cnum) {
270: my %courseinfo = &Apache::lonnet::coursedescription($reqdom.'_'.$cnum,{one_time => 1});
271: if (keys(%courseinfo)) {
272: $output = &buildline($format,$cnum,\%courseinfo);
273: return (1,$output);
274: } else {
275: if ($format eq 'html') {
276: $output = &mt('No match');
277: }
278: return (0,$output);
279: }
280: }
281: my %courses = &Apache::lonnet::courseiddump($reqdom,'.',1,'.','.','.',undef,undef,'.',undef,
282: undef,undef,undef,undef,undef,undef,undef,undef,
283: undef,undef,undef,1);
284: if (keys(%courses)) {
285: my (@rowstart,$rowend,$separator,%ownername);
286: if ($format eq 'html') {
287: &start_html($reqdom,&mt('LON-CAPA Courses with Unique Six Character Codes'));
288: print &html_table_start();
289: $rowstart[0] = '<tr class="LC_even_row"><td>';
290: $rowstart[1] = '<tr class="LC_odd_row"><td>';
291: $rowend = '</td></tr>'."\n";
292: $separator = '</td><td>';
293: } elsif ($format eq 'xml') {
294: &start_xml();
295: print "<courses>\n";
296: } else {
297: @rowstart = ('','');
298: $separator = ',';
299: $rowend = "\n";
300: }
301: my $num = 0;
302: foreach my $course (sort(keys(%courses))) {
303: if (ref($courses{$course}) eq 'HASH') {
304: my ($cdom,$cnum) = split(/_/,$course);
305: my $instructor;
306: if ($courses{$course}{'owner'}) {
307: unless (exists($ownername{$courses{$course}{'owner'}})) {
308: my ($uname,$udom) = split(/:/,$courses{$course}{'owner'});
309: $ownername{$courses{$course}{'owner'}} = &Apache::loncommon::plainname($uname,$udom,'lastname');
310: }
311: $instructor = $ownername{$courses{$course}{'owner'}};
312: }
313: if ($format eq 'xml') {
314: print <<"END";
1.2 ! raeburn 315: <course id="$cnum">
1.1 raeburn 316: <code>$courses{$course}{'uniquecode'}</code>
317: <title>$courses{$course}{'description'}</title>
318: <owner>$courses{$course}{'owner'}</owner>
319: <name>$instructor</name>
320: </course>
321: END
322: } else {
323: my $idx = $num%2;
324: print $rowstart[$idx].$cnum.$separator.$courses{$course}{'uniquecode'}.$separator.
325: $courses{$course}{'description'}.$separator.
326: $courses{$course}{'owner'}.$separator.$instructor.$rowend;
327: }
328: $num ++;
329: }
330: }
331: if ($format eq 'html') {
332: print '</table>';
333: &end_html();
334: } elsif ($format eq 'xml') {
335: print "</courses>\n";
336: }
337: return ($num,$output);
338: } else {
339: if ($format eq 'html') {
340: $output = &mt('No courses currently have six character identifiers.');
341: }
342: return (0,$output);
343: }
344: }
345:
346: #############################################
347: #############################################
348:
349: sub buildline {
350: my ($format,$cnum,$courseinfo) = @_;
351: return unless (ref($courseinfo) eq 'HASH');
352: my $code = $courseinfo->{'internal.uniquecode'};
353: my $title = $courseinfo->{'description'};
354: my $owner = $courseinfo->{'internal.courseowner'};
355: my $fullname;
356: if ($owner) {
357: my ($uname,$udom) = split(/:/,$owner);
358: $fullname = &Apache::loncommon::plainname($uname,$udom,'lastname');
359: }
360: if ($format eq 'html') {
361: return &html_table_start().
362: '<tr>'.
363: '<td>'.$cnum.'</td>'.
364: '<td>'.$code.'</td>'.
365: '<td>'.$title.'</td>'.
366: '<td>'.$owner.'</td>'.
367: '<td>'.$fullname.'</td></tr>'.
368: '</table>';
369: } elsif ($format eq 'xml') {
370: <<"END";
371: <courses>
1.2 ! raeburn 372: <course id="$cnum">
1.1 raeburn 373: <code>$code</code>
374: <title>$title</title>
375: <owner>$owner</owner>
376: <name>$fullname</name>
377: <course>
378: </courses>
379: END
380: } else {
381: return $cnum.','.$code.','.$title.','.$owner.','.$fullname."\n";
382: }
383: }
384:
385: sub start_html {
386: my ($dom,$title) = @_;
387: my $url;
388: if ($Apache::lonnet::env{'user.name'} && $Apache::lonnet::env{'user.domain'}) {
389: my $function = &Apache::loncommon::get_users_function();
390: my $bgcolor = &Apache::loncommon::designparm($function.'.pgbg',$dom);
391: $url = join(':',$Apache::lonnet::env{'user.name'},$Apache::lonnet::env{'user.domain'},
392: $Apache::lonnet::perlvar{'lonVersion'},
393: #time(),
394: $Apache::lonnet::env{'environment.color.timestamp'},
395: $function,$dom,$bgcolor);
396: $url = '/adm/css/'.&escape($url).'.css';
397: }
398: print '<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">'."\n".
399: '<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">'."\n\n".
400: '<head>'."\n".
401: '<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />'."\n";
402: if ($url) {
403: print '<link rel="stylesheet" type="text/css" href="'.$url.'" />'."\n";
404: }
405: print '<title>'.$title.'</title>'."\n".
406: '</head>'."\n".
407: '<body style="background-color:#ffffff">'."\n".
408: '<div>'."\n";
409: return;
410: }
411:
412: sub end_html {
413: print '</div>'."\n".
414: '</body>'."\n".
415: '</html>';
416: return;
417: }
418:
419: sub html_table_start {
420: return '<table class="LC_data_table">'.
421: '<tr class="LC_header_row">'.
422: '<th>'.&mt('Course ID').'</th>'."\n".
423: '<th>'.&mt('Code').'</th>'."\n".
424: '<th>'.&mt('Title').'</th>'."\n".
425: '<th>'.&mt('Owner').'</th>'."\n".
426: '<th>'.&mt('Instructor name').'</th>'."\n".
427: '</tr>';
428: }
429:
430: sub start_xml {
431: print '<?xml version="1.0" encoding="UTF-8"?>'."\n".'<!DOCTYPE text>'."\n";
432: return;
433: }
434:
435: =pod
436:
437: =back
438:
439: =cut
440:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to listcodes.pl CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / cgi