Annotation of loncom/interface/loncommon.pm, revision 1.551
1.10 albertel 1: # The LearningOnline Network with CAPA
1.1 albertel 2: # a pile of common routines
1.10 albertel 3: #
1.551 ! albertel 4: # $Id: loncommon.pm,v 1.550 2007/07/17 18:07:18 albertel Exp $
1.10 albertel 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: #
1.1 albertel 28:
29: # Makes a table out of the previous attempts
1.2 albertel 30: # Inputs result_from_symbread, user, domain, course_id
1.16 harris41 31: # Reads in non-network-related .tab files
1.1 albertel 32:
1.35 matthew 33: # POD header:
34:
1.45 matthew 35: =pod
36:
1.35 matthew 37: =head1 NAME
38:
39: Apache::loncommon - pile of common routines
40:
41: =head1 SYNOPSIS
42:
1.112 bowersj2 43: Common routines for manipulating connections, student answers,
44: domains, common Javascript fragments, etc.
1.35 matthew 45:
1.112 bowersj2 46: =head1 OVERVIEW
1.35 matthew 47:
1.112 bowersj2 48: A collection of commonly used subroutines that don't have a natural
49: home anywhere else. This collection helps remove
1.35 matthew 50: redundancy from other modules and increase efficiency of memory usage.
51:
52: =cut
53:
54: # End of POD header
1.1 albertel 55: package Apache::loncommon;
56:
57: use strict;
1.258 albertel 58: use Apache::lonnet;
1.46 matthew 59: use GDBM_File;
1.51 www 60: use POSIX qw(strftime mktime);
1.82 www 61: use Apache::lonmenu();
1.498 albertel 62: use Apache::lonenc();
1.117 www 63: use Apache::lonlocal;
1.139 matthew 64: use HTML::Entities;
1.334 albertel 65: use Apache::lonhtmlcommon();
66: use Apache::loncoursedata();
1.344 albertel 67: use Apache::lontexconvert();
1.444 albertel 68: use Apache::lonclonecourse();
1.479 albertel 69: use LONCAPA qw(:DEFAULT :match);
1.117 www 70:
1.517 raeburn 71: # ---------------------------------------------- Designs
72: use vars qw(%defaultdesign);
73:
1.22 www 74: my $readit;
75:
1.517 raeburn 76:
1.157 matthew 77: ##
78: ## Global Variables
79: ##
1.46 matthew 80:
1.20 www 81: # ----------------------------------------------- Filetypes/Languages/Copyright
1.12 harris41 82: my %language;
1.124 www 83: my %supported_language;
1.12 harris41 84: my %cprtag;
1.192 taceyjo1 85: my %scprtag;
1.351 www 86: my %fe; my %fd; my %fm;
1.41 ng 87: my %category_extensions;
1.12 harris41 88:
1.46 matthew 89: # ---------------------------------------------- Thesaurus variables
1.144 matthew 90: #
91: # %Keywords:
92: # A hash used by &keyword to determine if a word is considered a keyword.
93: # $thesaurus_db_file
94: # Scalar containing the full path to the thesaurus database.
1.46 matthew 95:
96: my %Keywords;
97: my $thesaurus_db_file;
98:
1.144 matthew 99: #
100: # Initialize values from language.tab, copyright.tab, filetypes.tab,
101: # thesaurus.tab, and filecategories.tab.
102: #
1.18 www 103: BEGIN {
1.46 matthew 104: # Variable initialization
105: $thesaurus_db_file = $Apache::lonnet::perlvar{'lonTabDir'}."/thesaurus.db";
106: #
1.22 www 107: unless ($readit) {
1.12 harris41 108: # ------------------------------------------------------------------- languages
109: {
1.158 raeburn 110: my $langtabfile = $Apache::lonnet::perlvar{'lonTabDir'}.
111: '/language.tab';
112: if ( open(my $fh,"<$langtabfile") ) {
1.356 albertel 113: while (my $line = <$fh>) {
114: next if ($line=~/^\#/);
115: chomp($line);
116: my ($key,$two,$country,$three,$enc,$val,$sup)=(split(/\t/,$line));
1.158 raeburn 117: $language{$key}=$val.' - '.$enc;
118: if ($sup) {
119: $supported_language{$key}=$sup;
120: }
121: }
122: close($fh);
123: }
1.12 harris41 124: }
125: # ------------------------------------------------------------------ copyrights
126: {
1.158 raeburn 127: my $copyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.
128: '/copyright.tab';
129: if ( open (my $fh,"<$copyrightfile") ) {
1.356 albertel 130: while (my $line = <$fh>) {
131: next if ($line=~/^\#/);
132: chomp($line);
133: my ($key,$val)=(split(/\s+/,$line,2));
1.158 raeburn 134: $cprtag{$key}=$val;
135: }
136: close($fh);
137: }
1.12 harris41 138: }
1.351 www 139: # ----------------------------------------------------------- source copyrights
1.192 taceyjo1 140: {
141: my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.
142: '/source_copyright.tab';
143: if ( open (my $fh,"<$sourcecopyrightfile") ) {
1.356 albertel 144: while (my $line = <$fh>) {
145: next if ($line =~ /^\#/);
146: chomp($line);
147: my ($key,$val)=(split(/\s+/,$line,2));
1.192 taceyjo1 148: $scprtag{$key}=$val;
149: }
150: close($fh);
151: }
152: }
1.63 www 153:
1.517 raeburn 154: # -------------------------------------------------------------- default domain designs
1.63 www 155: my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors';
1.517 raeburn 156: my $designfile = $designdir.'/default.tab';
157: if ( open (my $fh,"<$designfile") ) {
158: while (my $line = <$fh>) {
159: next if ($line =~ /^\#/);
160: chomp($line);
161: my ($key,$val)=(split(/\=/,$line));
162: if ($val) { $defaultdesign{$key}=$val; }
163: }
164: close($fh);
1.63 www 165: }
166:
1.15 harris41 167: # ------------------------------------------------------------- file categories
168: {
1.158 raeburn 169: my $categoryfile = $Apache::lonnet::perlvar{'lonTabDir'}.
170: '/filecategories.tab';
171: if ( open (my $fh,"<$categoryfile") ) {
1.356 albertel 172: while (my $line = <$fh>) {
173: next if ($line =~ /^\#/);
174: chomp($line);
175: my ($extension,$category)=(split(/\s+/,$line,2));
1.158 raeburn 176: push @{$category_extensions{lc($category)}},$extension;
177: }
178: close($fh);
179: }
180:
1.15 harris41 181: }
1.12 harris41 182: # ------------------------------------------------------------------ file types
183: {
1.158 raeburn 184: my $typesfile = $Apache::lonnet::perlvar{'lonTabDir'}.
185: '/filetypes.tab';
186: if ( open (my $fh,"<$typesfile") ) {
1.356 albertel 187: while (my $line = <$fh>) {
188: next if ($line =~ /^\#/);
189: chomp($line);
190: my ($ending,$emb,$mime,$descr)=split(/\s+/,$line,4);
1.158 raeburn 191: if ($descr ne '') {
192: $fe{$ending}=lc($emb);
193: $fd{$ending}=$descr;
1.351 www 194: if ($mime ne 'unk') { $fm{$ending}=$mime; }
1.158 raeburn 195: }
196: }
197: close($fh);
198: }
1.12 harris41 199: }
1.22 www 200: &Apache::lonnet::logthis(
1.46 matthew 201: "<font color=yellow>INFO: Read file types</font>");
1.22 www 202: $readit=1;
1.46 matthew 203: } # end of unless($readit)
1.32 matthew 204:
205: }
1.112 bowersj2 206:
1.42 matthew 207: ###############################################################
208: ## HTML and Javascript Helper Functions ##
209: ###############################################################
210:
211: =pod
212:
1.112 bowersj2 213: =head1 HTML and Javascript Functions
1.42 matthew 214:
1.112 bowersj2 215: =over 4
216:
217: =item * browser_and_searcher_javascript ()
218:
219: X<browsing, javascript>X<searching, javascript>Returns a string
220: containing javascript with two functions, C<openbrowser> and
221: C<opensearcher>. Returned string does not contain E<lt>scriptE<gt>
222: tags.
1.42 matthew 223:
1.112 bowersj2 224: =item * openbrowser(formname,elementname,only,omit) [javascript]
1.42 matthew 225:
226: inputs: formname, elementname, only, omit
227:
228: formname and elementname indicate the name of the html form and name of
229: the element that the results of the browsing selection are to be placed in.
230:
231: Specifying 'only' will restrict the browser to displaying only files
1.185 www 232: with the given extension. Can be a comma separated list.
1.42 matthew 233:
234: Specifying 'omit' will restrict the browser to NOT displaying files
1.185 www 235: with the given extension. Can be a comma separated list.
1.42 matthew 236:
1.112 bowersj2 237: =item * opensearcher(formname, elementname) [javascript]
1.42 matthew 238:
239: Inputs: formname, elementname
240:
241: formname and elementname specify the name of the html form and the name
242: of the element the selection from the search results will be placed in.
1.542 raeburn 243:
1.42 matthew 244: =cut
245:
246: sub browser_and_searcher_javascript {
1.199 albertel 247: my ($mode)=@_;
248: if (!defined($mode)) { $mode='edit'; }
1.453 albertel 249: my $resurl=&escape_single(&lastresurl());
1.42 matthew 250: return <<END;
1.219 albertel 251: // <!-- BEGIN LON-CAPA Internal
1.50 matthew 252: var editbrowser = null;
1.135 albertel 253: function openbrowser(formname,elementname,only,omit,titleelement) {
1.170 www 254: var url = '$resurl/?';
1.42 matthew 255: if (editbrowser == null) {
256: url += 'launch=1&';
257: }
258: url += 'catalogmode=interactive&';
1.199 albertel 259: url += 'mode=$mode&';
1.42 matthew 260: url += 'form=' + formname + '&';
261: if (only != null) {
262: url += 'only=' + only + '&';
1.217 albertel 263: } else {
264: url += 'only=&';
265: }
1.42 matthew 266: if (omit != null) {
267: url += 'omit=' + omit + '&';
1.217 albertel 268: } else {
269: url += 'omit=&';
270: }
1.135 albertel 271: if (titleelement != null) {
272: url += 'titleelement=' + titleelement + '&';
1.217 albertel 273: } else {
274: url += 'titleelement=&';
275: }
1.42 matthew 276: url += 'element=' + elementname + '';
277: var title = 'Browser';
1.435 albertel 278: var options = 'scrollbars=1,resizable=1,menubar=0,toolbar=1,location=1';
1.42 matthew 279: options += ',width=700,height=600';
280: editbrowser = open(url,title,options,'1');
281: editbrowser.focus();
282: }
283: var editsearcher;
1.135 albertel 284: function opensearcher(formname,elementname,titleelement) {
1.42 matthew 285: var url = '/adm/searchcat?';
286: if (editsearcher == null) {
287: url += 'launch=1&';
288: }
289: url += 'catalogmode=interactive&';
1.199 albertel 290: url += 'mode=$mode&';
1.42 matthew 291: url += 'form=' + formname + '&';
1.135 albertel 292: if (titleelement != null) {
293: url += 'titleelement=' + titleelement + '&';
1.217 albertel 294: } else {
295: url += 'titleelement=&';
296: }
1.42 matthew 297: url += 'element=' + elementname + '';
298: var title = 'Search';
1.435 albertel 299: var options = 'scrollbars=1,resizable=1,menubar=0,toolbar=1,location=1';
1.42 matthew 300: options += ',width=700,height=600';
301: editsearcher = open(url,title,options,'1');
302: editsearcher.focus();
303: }
1.219 albertel 304: // END LON-CAPA Internal -->
1.42 matthew 305: END
1.170 www 306: }
307:
308: sub lastresurl {
1.258 albertel 309: if ($env{'environment.lastresurl'}) {
310: return $env{'environment.lastresurl'}
1.170 www 311: } else {
312: return '/res';
313: }
314: }
315:
316: sub storeresurl {
317: my $resurl=&Apache::lonnet::clutter(shift);
318: unless ($resurl=~/^\/res/) { return 0; }
319: $resurl=~s/\/$//;
320: &Apache::lonnet::put('environment',{'lastresurl' => $resurl});
321: &Apache::lonnet::appenv('environment.lastresurl' => $resurl);
322: return 1;
1.42 matthew 323: }
324:
1.74 www 325: sub studentbrowser_javascript {
1.111 www 326: unless (
1.258 albertel 327: (($env{'request.course.id'}) &&
1.302 albertel 328: (&Apache::lonnet::allowed('srm',$env{'request.course.id'})
329: || &Apache::lonnet::allowed('srm',$env{'request.course.id'}.
330: '/'.$env{'request.course.sec'})
331: ))
1.258 albertel 332: || ($env{'request.role'}=~/^(au|dc|su)/)
1.111 www 333: ) { return ''; }
1.74 www 334: return (<<'ENDSTDBRW');
335: <script type="text/javascript" language="Javascript" >
336: var stdeditbrowser;
1.111 www 337: function openstdbrowser(formname,uname,udom,roleflag) {
1.74 www 338: var url = '/adm/pickstudent?';
339: var filter;
340: eval('filter=document.'+formname+'.'+uname+'.value;');
341: if (filter != null) {
342: if (filter != '') {
343: url += 'filter='+filter+'&';
344: }
345: }
346: url += 'form=' + formname + '&unameelement='+uname+
347: '&udomelement='+udom;
1.111 www 348: if (roleflag) { url+="&roles=1"; }
1.102 www 349: var title = 'Student_Browser';
1.74 www 350: var options = 'scrollbars=1,resizable=1,menubar=0';
351: options += ',width=700,height=600';
352: stdeditbrowser = open(url,title,options,'1');
353: stdeditbrowser.focus();
354: }
355: </script>
356: ENDSTDBRW
357: }
1.42 matthew 358:
1.74 www 359: sub selectstudent_link {
1.111 www 360: my ($form,$unameele,$udomele)=@_;
1.258 albertel 361: if ($env{'request.course.id'}) {
1.302 albertel 362: if (!&Apache::lonnet::allowed('srm',$env{'request.course.id'})
363: && !&Apache::lonnet::allowed('srm',$env{'request.course.id'}.
364: '/'.$env{'request.course.sec'})) {
1.111 www 365: return '';
366: }
367: return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele.
1.119 www 368: '","'.$udomele.'");'."'>".&mt('Select User')."</a>";
1.74 www 369: }
1.258 albertel 370: if ($env{'request.role'}=~/^(au|dc|su)/) {
1.111 www 371: return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele.
1.119 www 372: '","'.$udomele.'",1);'."'>".&mt('Select User')."</a>";
1.111 www 373: }
374: return '';
1.91 www 375: }
376:
377: sub coursebrowser_javascript {
1.468 raeburn 378: my ($domainfilter,$sec_element,$formname)=@_;
1.377 raeburn 379: my $crs_or_grp_alert = &mt('Please select the type of LON-CAPA entity - Course or Group - for which you wish to add/modify a user role');
1.468 raeburn 380: my $output = '
1.538 albertel 381: <script type="text/javascript">
1.468 raeburn 382: var stdeditbrowser;'."\n";
383: $output .= <<"ENDSTDBRW";
1.377 raeburn 384: function opencrsbrowser(formname,uname,udom,desc,extra_element,multflag,crstype) {
1.91 www 385: var url = '/adm/pickcourse?';
1.468 raeburn 386: var domainfilter = '';
387: var formid = getFormIdByName(formname);
388: if (formid > -1) {
389: var domid = getIndexByName(formid,udom);
390: if (domid > -1) {
391: if (document.forms[formid].elements[domid].type == 'select-one') {
392: domainfilter=document.forms[formid].elements[domid].options[document.forms[formid].elements[domid].selectedIndex].value;
393: }
394: if (document.forms[formid].elements[domid].type == 'hidden') {
395: domainfilter=document.forms[formid].elements[domid].value;
396: }
397: }
1.91 www 398: }
1.128 albertel 399: if (domainfilter != null) {
400: if (domainfilter != '') {
401: url += 'domainfilter='+domainfilter+'&';
402: }
403: }
1.91 www 404: url += 'form=' + formname + '&cnumelement='+uname+
1.187 albertel 405: '&cdomelement='+udom+
406: '&cnameelement='+desc;
1.468 raeburn 407: if (extra_element !=null && extra_element != '') {
408: if (formname == 'rolechoice') {
409: url += '&roleelement='+extra_element;
410: if (domainfilter == null || domainfilter == '') {
411: url += '&domainfilter='+extra_element;
412: }
1.234 raeburn 413: }
1.468 raeburn 414: else {
415: if (formname == 'portform') {
416: url += '&setroles='+extra_element;
417: }
418: }
1.230 raeburn 419: }
1.293 raeburn 420: if (multflag !=null && multflag != '') {
421: url += '&multiple='+multflag;
422: }
1.377 raeburn 423: if (crstype == 'Course/Group') {
424: if (formname == 'cu') {
425: crstype = document.cu.crstype.options[document.cu.crstype.selectedIndex].value;
426: if (crstype == "") {
427: alert("$crs_or_grp_alert");
428: return;
429: }
430: }
431: }
432: if (crstype !=null && crstype != '') {
433: url += '&type='+crstype;
434: }
1.102 www 435: var title = 'Course_Browser';
1.91 www 436: var options = 'scrollbars=1,resizable=1,menubar=0';
437: options += ',width=700,height=600';
438: stdeditbrowser = open(url,title,options,'1');
439: stdeditbrowser.focus();
440: }
1.468 raeburn 441:
442: function getFormIdByName(formname) {
443: for (var i=0;i<document.forms.length;i++) {
444: if (document.forms[i].name == formname) {
445: return i;
446: }
447: }
448: return -1;
449: }
450:
451: function getIndexByName(formid,item) {
452: for (var i=0;i<document.forms[formid].elements.length;i++) {
453: if (document.forms[formid].elements[i].name == item) {
454: return i;
455: }
456: }
457: return -1;
458: }
1.91 www 459: ENDSTDBRW
1.468 raeburn 460: if ($sec_element ne '') {
461: $output .= &setsec_javascript($sec_element,$formname);
462: }
463: $output .= '
464: </script>';
465: return $output;
466: }
467:
468: sub setsec_javascript {
469: my ($sec_element,$formname) = @_;
470: my $setsections = qq|
471: function setSect(sectionlist) {
472: var sectionsArray = sectionlist.split(",");
473: var numSections = sectionsArray.length;
474: document.$formname.$sec_element.length = 0;
475: if (numSections == 0) {
476: document.$formname.$sec_element.multiple=false;
477: document.$formname.$sec_element.size=1;
478: document.$formname.$sec_element.options[0] = new Option('No existing sections','',false,false)
479: } else {
480: if (numSections == 1) {
481: document.$formname.$sec_element.multiple=false;
482: document.$formname.$sec_element.size=1;
483: document.$formname.$sec_element.options[0] = new Option('Select','',true,true);
484: document.$formname.$sec_element.options[1] = new Option('No section','',false,false)
485: document.$formname.$sec_element.options[2] = new Option(sectionsArray[0],sectionsArray[0],false,false);
486: } else {
487: for (var i=0; i<numSections; i++) {
488: document.$formname.$sec_element.options[i] = new Option(sectionsArray[i],sectionsArray[i],false,false)
489: }
490: document.$formname.$sec_element.multiple=true
491: if (numSections < 3) {
492: document.$formname.$sec_element.size=numSections;
493: } else {
494: document.$formname.$sec_element.size=3;
495: }
496: document.$formname.$sec_element.options[0].selected = false
497: }
498: }
1.91 www 499: }
1.468 raeburn 500: |;
501: return $setsections;
502: }
503:
1.91 www 504:
505: sub selectcourse_link {
1.377 raeburn 506: my ($form,$unameele,$udomele,$desc,$extra_element,$multflag,$selecttype)=@_;
1.492 albertel 507: return "<a href='".'javascript:opencrsbrowser("'.$form.'","'.$unameele.
508: '","'.$udomele.'","'.$desc.'","'.$extra_element.'","'.$multflag.'","'.$selecttype.'");'."'>".&mt('Select Course')."</a>";
1.74 www 509: }
1.42 matthew 510:
1.273 raeburn 511: sub check_uncheck_jscript {
512: my $jscript = <<"ENDSCRT";
513: function checkAll(field) {
514: if (field.length > 0) {
515: for (i = 0; i < field.length; i++) {
516: field[i].checked = true ;
517: }
518: } else {
519: field.checked = true
520: }
521: }
522:
523: function uncheckAll(field) {
524: if (field.length > 0) {
525: for (i = 0; i < field.length; i++) {
526: field[i].checked = false ;
1.543 albertel 527: }
528: } else {
1.273 raeburn 529: field.checked = false ;
530: }
531: }
532: ENDSCRT
533: return $jscript;
534: }
535:
536:
1.42 matthew 537: =pod
1.36 matthew 538:
1.112 bowersj2 539: =item * linked_select_forms(...)
1.36 matthew 540:
541: linked_select_forms returns a string containing a <script></script> block
542: and html for two <select> menus. The select menus will be linked in that
543: changing the value of the first menu will result in new values being placed
544: in the second menu. The values in the select menu will appear in alphabetical
545: order.
546:
547: linked_select_forms takes the following ordered inputs:
548:
549: =over 4
550:
1.112 bowersj2 551: =item * $formname, the name of the <form> tag
1.36 matthew 552:
1.112 bowersj2 553: =item * $middletext, the text which appears between the <select> tags
1.36 matthew 554:
1.112 bowersj2 555: =item * $firstdefault, the default value for the first menu
1.36 matthew 556:
1.112 bowersj2 557: =item * $firstselectname, the name of the first <select> tag
1.36 matthew 558:
1.112 bowersj2 559: =item * $secondselectname, the name of the second <select> tag
1.36 matthew 560:
1.112 bowersj2 561: =item * $hashref, a reference to a hash containing the data for the menus.
1.36 matthew 562:
1.41 ng 563: =back
564:
1.36 matthew 565: Below is an example of such a hash. Only the 'text', 'default', and
566: 'select2' keys must appear as stated. keys(%menu) are the possible
567: values for the first select menu. The text that coincides with the
1.41 ng 568: first menu value is given in $menu{$choice1}->{'text'}. The values
1.36 matthew 569: and text for the second menu are given in the hash pointed to by
570: $menu{$choice1}->{'select2'}.
571:
1.112 bowersj2 572: my %menu = ( A1 => { text =>"Choice A1" ,
573: default => "B3",
574: select2 => {
575: B1 => "Choice B1",
576: B2 => "Choice B2",
577: B3 => "Choice B3",
578: B4 => "Choice B4"
579: }
580: },
581: A2 => { text =>"Choice A2" ,
582: default => "C2",
583: select2 => {
584: C1 => "Choice C1",
585: C2 => "Choice C2",
586: C3 => "Choice C3"
587: }
588: },
589: A3 => { text =>"Choice A3" ,
590: default => "D6",
591: select2 => {
592: D1 => "Choice D1",
593: D2 => "Choice D2",
594: D3 => "Choice D3",
595: D4 => "Choice D4",
596: D5 => "Choice D5",
597: D6 => "Choice D6",
598: D7 => "Choice D7"
599: }
600: }
601: );
1.36 matthew 602:
603: =cut
604:
605: sub linked_select_forms {
606: my ($formname,
607: $middletext,
608: $firstdefault,
609: $firstselectname,
610: $secondselectname,
611: $hashref
612: ) = @_;
613: my $second = "document.$formname.$secondselectname";
614: my $first = "document.$formname.$firstselectname";
615: # output the javascript to do the changing
616: my $result = '';
1.219 albertel 617: $result.="<script type=\"text/javascript\">\n";
1.36 matthew 618: $result.="var select2data = new Object();\n";
619: $" = '","';
620: my $debug = '';
621: foreach my $s1 (sort(keys(%$hashref))) {
622: $result.="select2data.d_$s1 = new Object();\n";
623: $result.="select2data.d_$s1.def = new String('".
624: $hashref->{$s1}->{'default'}."');\n";
625: $result.="select2data.d_$s1.values = new Array(";
626: my @s2values = sort(keys( %{ $hashref->{$s1}->{'select2'} } ));
627: $result.="\"@s2values\");\n";
628: $result.="select2data.d_$s1.texts = new Array(";
629: my @s2texts;
630: foreach my $value (@s2values) {
631: push @s2texts, $hashref->{$s1}->{'select2'}->{$value};
632: }
633: $result.="\"@s2texts\");\n";
634: }
635: $"=' ';
636: $result.= <<"END";
637:
638: function select1_changed() {
639: // Determine new choice
640: var newvalue = "d_" + $first.value;
641: // update select2
642: var values = select2data[newvalue].values;
643: var texts = select2data[newvalue].texts;
644: var select2def = select2data[newvalue].def;
645: var i;
646: // out with the old
647: for (i = 0; i < $second.options.length; i++) {
648: $second.options[i] = null;
649: }
650: // in with the nuclear
651: for (i=0;i<values.length; i++) {
652: $second.options[i] = new Option(values[i]);
1.143 matthew 653: $second.options[i].value = values[i];
1.36 matthew 654: $second.options[i].text = texts[i];
655: if (values[i] == select2def) {
656: $second.options[i].selected = true;
657: }
658: }
659: }
660: </script>
661: END
662: # output the initial values for the selection lists
663: $result .= "<select size=\"1\" name=\"$firstselectname\" onchange=\"select1_changed()\">\n";
664: foreach my $value (sort(keys(%$hashref))) {
665: $result.=" <option value=\"$value\" ";
1.253 albertel 666: $result.=" selected=\"selected\" " if ($value eq $firstdefault);
1.119 www 667: $result.=">".&mt($hashref->{$value}->{'text'})."</option>\n";
1.36 matthew 668: }
669: $result .= "</select>\n";
670: my %select2 = %{$hashref->{$firstdefault}->{'select2'}};
671: $result .= $middletext;
672: $result .= "<select size=\"1\" name=\"$secondselectname\">\n";
673: my $seconddefault = $hashref->{$firstdefault}->{'default'};
674: foreach my $value (sort(keys(%select2))) {
675: $result.=" <option value=\"$value\" ";
1.253 albertel 676: $result.=" selected=\"selected\" " if ($value eq $seconddefault);
1.119 www 677: $result.=">".&mt($select2{$value})."</option>\n";
1.36 matthew 678: }
679: $result .= "</select>\n";
680: # return $debug;
681: return $result;
682: } # end of sub linked_select_forms {
683:
1.45 matthew 684: =pod
1.44 bowersj2 685:
1.112 bowersj2 686: =item * help_open_topic($topic, $text, $stayOnPage, $width, $height)
1.44 bowersj2 687:
1.112 bowersj2 688: Returns a string corresponding to an HTML link to the given help
689: $topic, where $topic corresponds to the name of a .tex file in
690: /home/httpd/html/adm/help/tex, with underscores replaced by
691: spaces.
692:
693: $text will optionally be linked to the same topic, allowing you to
694: link text in addition to the graphic. If you do not want to link
695: text, but wish to specify one of the later parameters, pass an
696: empty string.
697:
698: $stayOnPage is a value that will be interpreted as a boolean. If true,
699: the link will not open a new window. If false, the link will open
700: a new window using Javascript. (Default is false.)
701:
702: $width and $height are optional numerical parameters that will
703: override the width and height of the popped up window, which may
704: be useful for certain help topics with big pictures included.
1.44 bowersj2 705:
706: =cut
707:
708: sub help_open_topic {
1.48 bowersj2 709: my ($topic, $text, $stayOnPage, $width, $height) = @_;
710: $text = "" if (not defined $text);
1.44 bowersj2 711: $stayOnPage = 0 if (not defined $stayOnPage);
1.258 albertel 712: if ($env{'browser.interface'} eq 'textual' ||
713: $env{'environment.remote'} eq 'off' ) {
1.79 www 714: $stayOnPage=1;
715: }
1.44 bowersj2 716: $width = 350 if (not defined $width);
717: $height = 400 if (not defined $height);
718: my $filename = $topic;
719: $filename =~ s/ /_/g;
720:
1.48 bowersj2 721: my $template = "";
722: my $link;
1.159 www 723:
724: $topic=~s/\W/\_/g;
1.44 bowersj2 725:
726: if (!$stayOnPage)
727: {
1.72 bowersj2 728: $link = "javascript:void(open('/adm/help/${filename}.hlp', 'Help_for_$topic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))";
1.44 bowersj2 729: }
730: else
731: {
1.48 bowersj2 732: $link = "/adm/help/${filename}.hlp";
733: }
734:
735: # Add the text
736: if ($text ne "")
737: {
1.77 www 738: $template .=
739: "<table bgcolor='#3333AA' cellspacing='1' cellpadding='1' border='0'><tr>".
1.436 albertel 740: "<td bgcolor='#5555FF'><a target=\"_top\" href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";
1.48 bowersj2 741: }
742:
743: # Add the graphic
1.179 matthew 744: my $title = &mt('Online Help');
1.215 albertel 745: my $helpicon=&lonhttpdurl("/adm/help/gif/smallHelp.gif");
1.48 bowersj2 746: $template .= <<"ENDTEMPLATE";
1.436 albertel 747: <a target="_top" href="$link" title="$title"><img src="$helpicon" border="0" alt="(Help: $topic)" /></a>
1.44 bowersj2 748: ENDTEMPLATE
1.78 www 749: if ($text ne '') { $template.='</td></tr></table>' };
1.44 bowersj2 750: return $template;
751:
1.106 bowersj2 752: }
753:
754: # This is a quicky function for Latex cheatsheet editing, since it
755: # appears in at least four places
756: sub helpLatexCheatsheet {
757: my $other = shift;
758: my $addOther = '';
759: if ($other) {
760: $addOther = Apache::loncommon::help_open_topic($other, shift,
761: undef, undef, 600) .
762: '</td><td>';
763: }
764: return '<table><tr><td>'.
765: $addOther .
766: &Apache::loncommon::help_open_topic("Greek_Symbols",'Greek Symbols',
767: undef,undef,600)
768: .'</td><td>'.
769: &Apache::loncommon::help_open_topic("Other_Symbols",'Other Symbols',
770: undef,undef,600)
771: .'</td></tr></table>';
1.172 www 772: }
773:
1.430 albertel 774: sub general_help {
775: my $helptopic='Student_Intro';
776: if ($env{'request.role'}=~/^(ca|au)/) {
777: $helptopic='Authoring_Intro';
778: } elsif ($env{'request.role'}=~/^cc/) {
779: $helptopic='Course_Coordination_Intro';
780: }
781: return $helptopic;
782: }
783:
784: sub update_help_link {
785: my ($topic,$component_help,$faq,$bug,$stayOnPage) = @_;
786: my $origurl = $ENV{'REQUEST_URI'};
787: $origurl=~s|^/~|/priv/|;
788: my $timestamp = time;
789: foreach my $datum (\$topic,\$component_help,\$faq,\$bug,\$origurl) {
790: $$datum = &escape($$datum);
791: }
792:
793: my $banner_link = "/adm/helpmenu?page=banner&topic=$topic&component_help=$component_help&faq=$faq&bug=$bug&origurl=$origurl&stamp=$timestamp&stayonpage=$stayOnPage";
794: my $output .= <<"ENDOUTPUT";
795: <script type="text/javascript">
796: banner_link = '$banner_link';
797: </script>
798: ENDOUTPUT
799: return $output;
800: }
801:
802: # now just updates the help link and generates a blue icon
1.193 raeburn 803: sub help_open_menu {
1.430 albertel 804: my ($topic,$component_help,$faq,$bug,$stayOnPage,$width,$height,$text)
805: = @_;
806:
807: $stayOnPage = 0 if (not defined $stayOnPage);
808: if ($env{'browser.interface'} eq 'textual' ||
809: $env{'environment.remote'} eq 'off' ) {
810: $stayOnPage=1;
811: }
812: my $output;
813: if ($component_help) {
814: if (!$text) {
815: $output=&help_open_topic($component_help,undef,$stayOnPage,
816: $width,$height);
817: } else {
818: my $help_text;
819: $help_text=&unescape($topic);
820: $output='<table><tr><td>'.
821: &help_open_topic($component_help,$help_text,$stayOnPage,
822: $width,$height).'</td></tr></table>';
823: }
824: }
825: my $banner_link = &update_help_link($topic,$component_help,$faq,$bug,$stayOnPage);
826: return $output.$banner_link;
827: }
828:
829: sub top_nav_help {
830: my ($text) = @_;
831:
1.436 albertel 832: $text = &mt($text);
833:
834: my $stayOnPage =
835: ($env{'browser.interface'} eq 'textual' ||
836: $env{'environment.remote'} eq 'off' );
837: my $link= ($stayOnPage) ? "javascript:helpMenu('display')"
838: : "javascript:helpMenu('open')";
839: my $banner_link = &update_help_link(undef,undef,undef,undef,$stayOnPage);
840:
1.201 raeburn 841: my $title = &mt('Get help');
1.436 albertel 842:
843: return <<"END";
844: $banner_link
845: <a href="$link" title="$title">$text</a>
846: END
847: }
848:
849: sub help_menu_js {
850: my ($text) = @_;
851:
852: my $stayOnPage =
853: ($env{'browser.interface'} eq 'textual' ||
854: $env{'environment.remote'} eq 'off' );
855:
856: my $width = 620;
857: my $height = 600;
1.430 albertel 858: my $helptopic=&general_help();
859: my $details_link = '/adm/help/'.$helptopic.'.hlp';
1.261 albertel 860: my $nothing=&Apache::lonhtmlcommon::javascript_nothing();
1.331 albertel 861: my $start_page =
862: &Apache::loncommon::start_page('Help Menu', undef,
863: {'frameset' => 1,
864: 'js_ready' => 1,
865: 'add_entries' => {
866: 'border' => '0',
867: 'rows' => "105,*",},});
868: my $end_page =
869: &Apache::loncommon::end_page({'frameset' => 1,
870: 'js_ready' => 1,});
871:
1.436 albertel 872: my $template .= <<"ENDTEMPLATE";
873: <script type="text/javascript">
1.253 albertel 874: // <!-- BEGIN LON-CAPA Internal
875: // <![CDATA[
1.430 albertel 876: var banner_link = '';
1.243 raeburn 877: function helpMenu(target) {
878: var caller = this;
879: if (target == 'open') {
880: var newWindow = null;
881: try {
1.262 albertel 882: newWindow = window.open($nothing,"helpmenu","HEIGHT=$height,WIDTH=$width,resizable=yes,scrollbars=yes" )
1.243 raeburn 883: }
884: catch(error) {
885: writeHelp(caller);
886: return;
887: }
888: if (newWindow) {
889: caller = newWindow;
890: }
1.193 raeburn 891: }
1.243 raeburn 892: writeHelp(caller);
893: return;
894: }
895: function writeHelp(caller) {
1.430 albertel 896: caller.document.writeln('$start_page<frame name="bannerframe" src="'+banner_link+'" /><frame name="bodyframe" src="$details_link" /> $end_page')
1.243 raeburn 897: caller.document.close()
898: caller.focus()
1.193 raeburn 899: }
1.253 albertel 900: // ]]>
1.219 albertel 901: // END LON-CAPA Internal -->
1.436 albertel 902: </script>
1.193 raeburn 903: ENDTEMPLATE
904: return $template;
905: }
906:
1.172 www 907: sub help_open_bug {
908: my ($topic, $text, $stayOnPage, $width, $height) = @_;
1.258 albertel 909: unless ($env{'user.adv'}) { return ''; }
1.172 www 910: unless ($Apache::lonnet::perlvar{'BugzillaHost'}) { return ''; }
911: $text = "" if (not defined $text);
912: $stayOnPage = 0 if (not defined $stayOnPage);
1.258 albertel 913: if ($env{'browser.interface'} eq 'textual' ||
914: $env{'environment.remote'} eq 'off' ) {
1.172 www 915: $stayOnPage=1;
916: }
1.184 albertel 917: $width = 600 if (not defined $width);
918: $height = 600 if (not defined $height);
1.172 www 919:
920: $topic=~s/\W+/\+/g;
921: my $link='';
922: my $template='';
1.379 albertel 923: my $url=$Apache::lonnet::perlvar{'BugzillaHost'}.'enter_bug.cgi?product=LON-CAPA&bug_file_loc='.
924: &escape($ENV{'REQUEST_URI'}).'&component='.$topic;
1.172 www 925: if (!$stayOnPage)
926: {
927: $link = "javascript:void(open('$url', 'Bugzilla', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))";
928: }
929: else
930: {
931: $link = $url;
932: }
933: # Add the text
934: if ($text ne "")
935: {
936: $template .=
937: "<table bgcolor='#AA3333' cellspacing='1' cellpadding='1' border='0'><tr>".
1.436 albertel 938: "<td bgcolor='#FF5555'><a target=\"_top\" href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";
1.172 www 939: }
940:
941: # Add the graphic
1.179 matthew 942: my $title = &mt('Report a Bug');
1.215 albertel 943: my $bugicon=&lonhttpdurl("/adm/lonMisc/smallBug.gif");
1.172 www 944: $template .= <<"ENDTEMPLATE";
1.436 albertel 945: <a target="_top" href="$link" title="$title"><img src="$bugicon" border="0" alt="(Bug: $topic)" /></a>
1.172 www 946: ENDTEMPLATE
947: if ($text ne '') { $template.='</td></tr></table>' };
948: return $template;
949:
950: }
951:
952: sub help_open_faq {
953: my ($topic, $text, $stayOnPage, $width, $height) = @_;
1.258 albertel 954: unless ($env{'user.adv'}) { return ''; }
1.172 www 955: unless ($Apache::lonnet::perlvar{'FAQHost'}) { return ''; }
956: $text = "" if (not defined $text);
957: $stayOnPage = 0 if (not defined $stayOnPage);
1.258 albertel 958: if ($env{'browser.interface'} eq 'textual' ||
959: $env{'environment.remote'} eq 'off' ) {
1.172 www 960: $stayOnPage=1;
961: }
962: $width = 350 if (not defined $width);
963: $height = 400 if (not defined $height);
964:
965: $topic=~s/\W+/\+/g;
966: my $link='';
967: my $template='';
968: my $url=$Apache::lonnet::perlvar{'FAQHost'}.'/fom/cache/'.$topic.'.html';
969: if (!$stayOnPage)
970: {
971: $link = "javascript:void(open('$url', 'FAQ-O-Matic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))";
972: }
973: else
974: {
975: $link = $url;
976: }
977:
978: # Add the text
979: if ($text ne "")
980: {
981: $template .=
1.173 www 982: "<table bgcolor='#337733' cellspacing='1' cellpadding='1' border='0'><tr>".
1.436 albertel 983: "<td bgcolor='#448844'><a target=\"_top\" href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";
1.172 www 984: }
985:
986: # Add the graphic
1.179 matthew 987: my $title = &mt('View the FAQ');
1.215 albertel 988: my $faqicon=&lonhttpdurl("/adm/lonMisc/smallFAQ.gif");
1.172 www 989: $template .= <<"ENDTEMPLATE";
1.436 albertel 990: <a target="_top" href="$link" title="$title"><img src="$faqicon" border="0" alt="(FAQ: $topic)" /></a>
1.172 www 991: ENDTEMPLATE
992: if ($text ne '') { $template.='</td></tr></table>' };
993: return $template;
994:
1.44 bowersj2 995: }
1.37 matthew 996:
1.180 matthew 997: ###############################################################
998: ###############################################################
999:
1.45 matthew 1000: =pod
1001:
1.256 matthew 1002: =item * change_content_javascript():
1003:
1004: This and the next function allow you to create small sections of an
1005: otherwise static HTML page that you can update on the fly with
1006: Javascript, even in Netscape 4.
1007:
1008: The Javascript fragment returned by this function (no E<lt>scriptE<gt> tag)
1009: must be written to the HTML page once. It will prove the Javascript
1010: function "change(name, content)". Calling the change function with the
1011: name of the section
1012: you want to update, matching the name passed to C<changable_area>, and
1013: the new content you want to put in there, will put the content into
1014: that area.
1015:
1016: B<Note>: Netscape 4 only reserves enough space for the changable area
1017: to contain room for the original contents. You need to "make space"
1018: for whatever changes you wish to make, and be B<sure> to check your
1019: code in Netscape 4. This feature in Netscape 4 is B<not> powerful;
1020: it's adequate for updating a one-line status display, but little more.
1021: This script will set the space to 100% width, so you only need to
1022: worry about height in Netscape 4.
1023:
1024: Modern browsers are much less limiting, and if you can commit to the
1025: user not using Netscape 4, this feature may be used freely with
1026: pretty much any HTML.
1027:
1028: =cut
1029:
1030: sub change_content_javascript {
1031: # If we're on Netscape 4, we need to use Layer-based code
1.258 albertel 1032: if ($env{'browser.type'} eq 'netscape' &&
1033: $env{'browser.version'} =~ /^4\./) {
1.256 matthew 1034: return (<<NETSCAPE4);
1035: function change(name, content) {
1036: doc = document.layers[name+"___escape"].layers[0].document;
1037: doc.open();
1038: doc.write(content);
1039: doc.close();
1040: }
1041: NETSCAPE4
1042: } else {
1043: # Otherwise, we need to use semi-standards-compliant code
1044: # (technically, "innerHTML" isn't standard but the equivalent
1045: # is really scary, and every useful browser supports it
1046: return (<<DOMBASED);
1047: function change(name, content) {
1048: element = document.getElementById(name);
1049: element.innerHTML = content;
1050: }
1051: DOMBASED
1052: }
1053: }
1054:
1055: =pod
1056:
1057: =item * changable_area($name, $origContent):
1058:
1059: This provides a "changable area" that can be modified on the fly via
1060: the Javascript code provided in C<change_content_javascript>. $name is
1061: the name you will use to reference the area later; do not repeat the
1062: same name on a given HTML page more then once. $origContent is what
1063: the area will originally contain, which can be left blank.
1064:
1065: =cut
1066:
1067: sub changable_area {
1068: my ($name, $origContent) = @_;
1069:
1.258 albertel 1070: if ($env{'browser.type'} eq 'netscape' &&
1071: $env{'browser.version'} =~ /^4\./) {
1.256 matthew 1072: # If this is netscape 4, we need to use the Layer tag
1073: return "<ilayer width='100%' id='${name}___escape' overflow='none'><layer width='100%' id='$name' overflow='none'>$origContent</layer></ilayer>";
1074: } else {
1075: return "<span id='$name'>$origContent</span>";
1076: }
1077: }
1078:
1079: =pod
1080:
1081: =back
1.542 raeburn 1082:
1.256 matthew 1083: =head1 Excel and CSV file utility routines
1084:
1085: =over 4
1086:
1087: =cut
1088:
1089: ###############################################################
1090: ###############################################################
1091:
1092: =pod
1093:
1.112 bowersj2 1094: =item * csv_translate($text)
1.37 matthew 1095:
1.185 www 1096: Translate $text to allow it to be output as a 'comma separated values'
1.37 matthew 1097: format.
1098:
1099: =cut
1100:
1.180 matthew 1101: ###############################################################
1102: ###############################################################
1.37 matthew 1103: sub csv_translate {
1104: my $text = shift;
1105: $text =~ s/\"/\"\"/g;
1.209 albertel 1106: $text =~ s/\n/ /g;
1.37 matthew 1107: return $text;
1108: }
1.180 matthew 1109:
1110: ###############################################################
1111: ###############################################################
1112:
1113: =pod
1114:
1115: =item * define_excel_formats
1116:
1117: Define some commonly used Excel cell formats.
1118:
1119: Currently supported formats:
1120:
1121: =over 4
1122:
1123: =item header
1124:
1125: =item bold
1126:
1127: =item h1
1128:
1129: =item h2
1130:
1131: =item h3
1132:
1.256 matthew 1133: =item h4
1134:
1135: =item i
1136:
1.180 matthew 1137: =item date
1138:
1139: =back
1140:
1141: Inputs: $workbook
1142:
1143: Returns: $format, a hash reference.
1144:
1145: =cut
1146:
1147: ###############################################################
1148: ###############################################################
1149: sub define_excel_formats {
1150: my ($workbook) = @_;
1151: my $format;
1152: $format->{'header'} = $workbook->add_format(bold => 1,
1153: bottom => 1,
1154: align => 'center');
1155: $format->{'bold'} = $workbook->add_format(bold=>1);
1156: $format->{'h1'} = $workbook->add_format(bold=>1, size=>18);
1157: $format->{'h2'} = $workbook->add_format(bold=>1, size=>16);
1158: $format->{'h3'} = $workbook->add_format(bold=>1, size=>14);
1.255 matthew 1159: $format->{'h4'} = $workbook->add_format(bold=>1, size=>12);
1.246 matthew 1160: $format->{'i'} = $workbook->add_format(italic=>1);
1.180 matthew 1161: $format->{'date'} = $workbook->add_format(num_format=>
1.207 matthew 1162: 'mm/dd/yyyy hh:mm:ss');
1.180 matthew 1163: return $format;
1164: }
1165:
1166: ###############################################################
1167: ###############################################################
1.113 bowersj2 1168:
1169: =pod
1170:
1.256 matthew 1171: =item * create_workbook
1.255 matthew 1172:
1173: Create an Excel worksheet. If it fails, output message on the
1174: request object and return undefs.
1175:
1176: Inputs: Apache request object
1177:
1178: Returns (undef) on failure,
1179: Excel worksheet object, scalar with filename, and formats
1180: from &Apache::loncommon::define_excel_formats on success
1181:
1182: =cut
1183:
1184: ###############################################################
1185: ###############################################################
1186: sub create_workbook {
1187: my ($r) = @_;
1188: #
1189: # Create the excel spreadsheet
1190: my $filename = '/prtspool/'.
1.258 albertel 1191: $env{'user.name'}.'_'.$env{'user.domain'}.'_'.
1.255 matthew 1192: time.'_'.rand(1000000000).'.xls';
1193: my $workbook = Spreadsheet::WriteExcel->new('/home/httpd'.$filename);
1194: if (! defined($workbook)) {
1195: $r->log_error("Error creating excel spreadsheet $filename: $!");
1196: $r->print('<p>'.&mt("Unable to create new Excel file. ".
1197: "This error has been logged. ".
1198: "Please alert your LON-CAPA administrator").
1199: '</p>');
1200: return (undef);
1201: }
1202: #
1203: $workbook->set_tempdir('/home/httpd/perl/tmp');
1204: #
1205: my $format = &Apache::loncommon::define_excel_formats($workbook);
1206: return ($workbook,$filename,$format);
1207: }
1208:
1209: ###############################################################
1210: ###############################################################
1211:
1212: =pod
1213:
1.256 matthew 1214: =item * create_text_file
1.113 bowersj2 1215:
1.542 raeburn 1216: Create a file to write to and eventually make available to the user.
1.256 matthew 1217: If file creation fails, outputs an error message on the request object and
1218: return undefs.
1.113 bowersj2 1219:
1.256 matthew 1220: Inputs: Apache request object, and file suffix
1.113 bowersj2 1221:
1.256 matthew 1222: Returns (undef) on failure,
1223: Filehandle and filename on success.
1.113 bowersj2 1224:
1225: =cut
1226:
1.256 matthew 1227: ###############################################################
1228: ###############################################################
1229: sub create_text_file {
1230: my ($r,$suffix) = @_;
1231: if (! defined($suffix)) { $suffix = 'txt'; };
1232: my $fh;
1233: my $filename = '/prtspool/'.
1.258 albertel 1234: $env{'user.name'}.'_'.$env{'user.domain'}.'_'.
1.256 matthew 1235: time.'_'.rand(1000000000).'.'.$suffix;
1236: $fh = Apache::File->new('>/home/httpd'.$filename);
1237: if (! defined($fh)) {
1238: $r->log_error("Couldn't open $filename for output $!");
1239: $r->print("Problems occured in creating the output file. ".
1240: "This error has been logged. ".
1241: "Please alert your LON-CAPA administrator.");
1.113 bowersj2 1242: }
1.256 matthew 1243: return ($fh,$filename)
1.113 bowersj2 1244: }
1245:
1246:
1.256 matthew 1247: =pod
1.113 bowersj2 1248:
1249: =back
1250:
1251: =cut
1.37 matthew 1252:
1253: ###############################################################
1.33 matthew 1254: ## Home server <option> list generating code ##
1255: ###############################################################
1.35 matthew 1256:
1.169 www 1257: # ------------------------------------------
1258:
1259: sub domain_select {
1260: my ($name,$value,$multiple)=@_;
1261: my %domains=map {
1.514 albertel 1262: $_ => $_.' '. &Apache::lonnet::domain($_,'description')
1.512 albertel 1263: } &Apache::lonnet::all_domains();
1.169 www 1264: if ($multiple) {
1265: $domains{''}=&mt('Any domain');
1.550 albertel 1266: $domains{'select_form_order'} = [sort {lc($a) cmp lc($b) } (keys(%domains))];
1.287 albertel 1267: return &multiple_select_form($name,$value,4,\%domains);
1.169 www 1268: } else {
1.550 albertel 1269: $domains{'select_form_order'} = [sort {lc($a) cmp lc($b) } (keys(%domains))];
1.169 www 1270: return &select_form($name,$value,%domains);
1271: }
1272: }
1273:
1.282 albertel 1274: #-------------------------------------------
1275:
1276: =pod
1277:
1.519 raeburn 1278: =head1 Routines for form select boxes
1279:
1280: =over 4
1281:
1282: =cut
1283:
1.287 albertel 1284: =item * multiple_select_form($name,$value,$size,$hash,$order)
1.282 albertel 1285:
1286: Returns a string containing a <select> element int multiple mode
1287:
1288:
1289: Args:
1290: $name - name of the <select> element
1.506 raeburn 1291: $value - scalar or array ref of values that should already be selected
1.282 albertel 1292: $size - number of rows long the select element is
1.283 albertel 1293: $hash - the elements should be 'option' => 'shown text'
1.282 albertel 1294: (shown text should already have been &mt())
1.506 raeburn 1295: $order - (optional) array ref of the order to show the elements in
1.283 albertel 1296:
1.282 albertel 1297: =cut
1298:
1299: #-------------------------------------------
1.169 www 1300: sub multiple_select_form {
1.284 albertel 1301: my ($name,$value,$size,$hash,$order)=@_;
1.169 www 1302: my %selected = map { $_ => 1 } ref($value)?@{$value}:($value);
1303: my $output='';
1.191 matthew 1304: if (! defined($size)) {
1305: $size = 4;
1.283 albertel 1306: if (scalar(keys(%$hash))<4) {
1307: $size = scalar(keys(%$hash));
1.191 matthew 1308: }
1309: }
1.169 www 1310: $output.="\n<select name='$name' size='$size' multiple='1'>";
1.501 banghart 1311: my @order;
1.506 raeburn 1312: if (ref($order) eq 'ARRAY') {
1313: @order = @{$order};
1314: } else {
1315: @order = sort(keys(%$hash));
1.501 banghart 1316: }
1317: if (exists($$hash{'select_form_order'})) {
1318: @order = @{$$hash{'select_form_order'}};
1319: }
1320:
1.284 albertel 1321: foreach my $key (@order) {
1.356 albertel 1322: $output.='<option value="'.&HTML::Entities::encode($key,'"<>&').'" ';
1.284 albertel 1323: $output.='selected="selected" ' if ($selected{$key});
1324: $output.='>'.$hash->{$key}."</option>\n";
1.169 www 1325: }
1326: $output.="</select>\n";
1327: return $output;
1328: }
1329:
1.88 www 1330: #-------------------------------------------
1331:
1332: =pod
1333:
1.112 bowersj2 1334: =item * select_form($defdom,$name,%hash)
1.88 www 1335:
1336: Returns a string containing a <select name='$name' size='1'> form to
1337: allow a user to select options from a hash option_name => displayed text.
1338: See lonrights.pm for an example invocation and use.
1339:
1340: =cut
1341:
1342: #-------------------------------------------
1343: sub select_form {
1344: my ($def,$name,%hash) = @_;
1345: my $selectform = "<select name=\"$name\" size=\"1\">\n";
1.128 albertel 1346: my @keys;
1347: if (exists($hash{'select_form_order'})) {
1348: @keys=@{$hash{'select_form_order'}};
1349: } else {
1350: @keys=sort(keys(%hash));
1351: }
1.356 albertel 1352: foreach my $key (@keys) {
1353: $selectform.=
1354: '<option value="'.&HTML::Entities::encode($key,'"<>&').'" '.
1355: ($key eq $def ? 'selected="selected" ' : '').
1356: ">".&mt($hash{$key})."</option>\n";
1.88 www 1357: }
1358: $selectform.="</select>";
1359: return $selectform;
1360: }
1361:
1.475 www 1362: # For display filters
1363:
1364: sub display_filter {
1365: if (!$env{'form.show'}) { $env{'form.show'}=10; }
1.477 www 1366: if (!$env{'form.displayfilter'}) { $env{'form.displayfilter'}='currentfolder'; }
1.475 www 1367: return '<nobr><label>'.&mt('Records [_1]',
1368: &Apache::lonmeta::selectbox('show',$env{'form.show'},undef,
1369: (&mt('all'),10,20,50,100,1000,10000))).
1.478 www 1370: '</label></nobr> <nobr>'.
1.475 www 1371: &mt('Filter [_1]',
1.477 www 1372: &select_form($env{'form.displayfilter'},
1373: 'displayfilter',
1374: ('currentfolder' => 'Current folder/page',
1375: 'containing' => 'Containing phrase',
1376: 'none' => 'None'))).
1.478 www 1377: '<input type="text" name="containingphrase" size="30" value="'.&HTML::Entities::encode($env{'form.containingphrase'}).'" /></nobr>';
1.475 www 1378: }
1379:
1.167 www 1380: sub gradeleveldescription {
1381: my $gradelevel=shift;
1382: my %gradelevels=(0 => 'Not specified',
1383: 1 => 'Grade 1',
1384: 2 => 'Grade 2',
1385: 3 => 'Grade 3',
1386: 4 => 'Grade 4',
1387: 5 => 'Grade 5',
1388: 6 => 'Grade 6',
1389: 7 => 'Grade 7',
1390: 8 => 'Grade 8',
1391: 9 => 'Grade 9',
1392: 10 => 'Grade 10',
1393: 11 => 'Grade 11',
1394: 12 => 'Grade 12',
1395: 13 => 'Grade 13',
1396: 14 => '100 Level',
1397: 15 => '200 Level',
1398: 16 => '300 Level',
1399: 17 => '400 Level',
1400: 18 => 'Graduate Level');
1401: return &mt($gradelevels{$gradelevel});
1402: }
1403:
1.163 www 1404: sub select_level_form {
1405: my ($deflevel,$name)=@_;
1406: unless ($deflevel) { $deflevel=0; }
1.167 www 1407: my $selectform = "<select name=\"$name\" size=\"1\">\n";
1408: for (my $i=0; $i<=18; $i++) {
1409: $selectform.="<option value=\"$i\" ".
1.253 albertel 1410: ($i==$deflevel ? 'selected="selected" ' : '').
1.167 www 1411: ">".&gradeleveldescription($i)."</option>\n";
1412: }
1413: $selectform.="</select>";
1414: return $selectform;
1.163 www 1415: }
1.167 www 1416:
1.35 matthew 1417: #-------------------------------------------
1418:
1.45 matthew 1419: =pod
1420:
1.112 bowersj2 1421: =item * select_dom_form($defdom,$name,$includeempty)
1.35 matthew 1422:
1423: Returns a string containing a <select name='$name' size='1'> form to
1424: allow a user to select the domain to preform an operation in.
1425: See loncreateuser.pm for an example invocation and use.
1426:
1.90 www 1427: If the $includeempty flag is set, it also includes an empty choice ("no domain
1428: selected");
1429:
1.35 matthew 1430: =cut
1431:
1432: #-------------------------------------------
1.34 matthew 1433: sub select_dom_form {
1.90 www 1434: my ($defdom,$name,$includeempty) = @_;
1.550 albertel 1435: my @domains = sort {lc($a) cmp lc($b)} (&Apache::lonnet::all_domains());
1.90 www 1436: if ($includeempty) { @domains=('',@domains); }
1.34 matthew 1437: my $selectdomain = "<select name=\"$name\" size=\"1\">\n";
1.356 albertel 1438: foreach my $dom (@domains) {
1439: $selectdomain.="<option value=\"$dom\" ".
1440: ($dom eq $defdom ? 'selected="selected" ' : '').
1441: ">$dom</option>\n";
1.34 matthew 1442: }
1443: $selectdomain.="</select>";
1444: return $selectdomain;
1445: }
1446:
1.35 matthew 1447: #-------------------------------------------
1448:
1.45 matthew 1449: =pod
1450:
1.112 bowersj2 1451: =item * home_server_option_list($domain)
1.35 matthew 1452:
1453: returns a string which contains an <option> list to be used in a
1454: <select> form input. See loncreateuser.pm for an example.
1455:
1456: =cut
1457:
1458: #-------------------------------------------
1.33 matthew 1459: sub home_server_option_list {
1460: my $domain = shift;
1.513 albertel 1461: my %servers = &Apache::lonnet::get_servers($domain,'library');
1.33 matthew 1462: my $result = '';
1.356 albertel 1463: foreach my $hostid (sort(keys(%servers))) {
1.33 matthew 1464: $result.=
1.356 albertel 1465: '<option value="'.$hostid.'">'.
1466: $hostid.' '.$servers{$hostid}."</option>\n";
1.33 matthew 1467: }
1468: return $result;
1469: }
1.112 bowersj2 1470:
1471: =pod
1472:
1.534 albertel 1473: =back
1474:
1.112 bowersj2 1475: =cut
1.87 matthew 1476:
1477: ###############################################################
1.112 bowersj2 1478: ## Decoding User Agent ##
1.87 matthew 1479: ###############################################################
1480:
1481: =pod
1482:
1.112 bowersj2 1483: =head1 Decoding the User Agent
1484:
1485: =over 4
1486:
1487: =item * &decode_user_agent()
1.87 matthew 1488:
1489: Inputs: $r
1490:
1491: Outputs:
1492:
1493: =over 4
1494:
1.112 bowersj2 1495: =item * $httpbrowser
1.87 matthew 1496:
1.112 bowersj2 1497: =item * $clientbrowser
1.87 matthew 1498:
1.112 bowersj2 1499: =item * $clientversion
1.87 matthew 1500:
1.112 bowersj2 1501: =item * $clientmathml
1.87 matthew 1502:
1.112 bowersj2 1503: =item * $clientunicode
1.87 matthew 1504:
1.112 bowersj2 1505: =item * $clientos
1.87 matthew 1506:
1507: =back
1508:
1.157 matthew 1509: =back
1510:
1.87 matthew 1511: =cut
1512:
1513: ###############################################################
1514: ###############################################################
1515: sub decode_user_agent {
1.247 albertel 1516: my ($r)=@_;
1.87 matthew 1517: my @browsertype=split(/\&/,$Apache::lonnet::perlvar{"lonBrowsDet"});
1518: my %mathcap=split(/\&/,$$Apache::lonnet::perlvar{"lonMathML"});
1519: my $httpbrowser=$ENV{"HTTP_USER_AGENT"};
1.247 albertel 1520: if (!$httpbrowser && $r) { $httpbrowser=$r->header_in('User-Agent'); }
1.87 matthew 1521: my $clientbrowser='unknown';
1522: my $clientversion='0';
1523: my $clientmathml='';
1524: my $clientunicode='0';
1525: for (my $i=0;$i<=$#browsertype;$i++) {
1526: my ($bname,$match,$notmatch,$vreg,$minv,$univ)=split(/\:/,$browsertype[$i]);
1527: if (($httpbrowser=~/$match/i) && ($httpbrowser!~/$notmatch/i)) {
1528: $clientbrowser=$bname;
1529: $httpbrowser=~/$vreg/i;
1530: $clientversion=$1;
1531: $clientmathml=($clientversion>=$minv);
1532: $clientunicode=($clientversion>=$univ);
1533: }
1534: }
1535: my $clientos='unknown';
1536: if (($httpbrowser=~/linux/i) ||
1537: ($httpbrowser=~/unix/i) ||
1538: ($httpbrowser=~/ux/i) ||
1539: ($httpbrowser=~/solaris/i)) { $clientos='unix'; }
1540: if (($httpbrowser=~/vax/i) ||
1541: ($httpbrowser=~/vms/i)) { $clientos='vms'; }
1542: if ($httpbrowser=~/next/i) { $clientos='next'; }
1543: if (($httpbrowser=~/mac/i) ||
1544: ($httpbrowser=~/powerpc/i)) { $clientos='mac'; }
1545: if ($httpbrowser=~/win/i) { $clientos='win'; }
1546: if ($httpbrowser=~/embed/i) { $clientos='pda'; }
1547: return ($httpbrowser,$clientbrowser,$clientversion,$clientmathml,
1548: $clientunicode,$clientos,);
1549: }
1550:
1.32 matthew 1551: ###############################################################
1552: ## Authentication changing form generation subroutines ##
1553: ###############################################################
1554: ##
1555: ## All of the authform_xxxxxxx subroutines take their inputs in a
1556: ## hash, and have reasonable default values.
1557: ##
1558: ## formname = the name given in the <form> tag.
1.35 matthew 1559: #-------------------------------------------
1560:
1.45 matthew 1561: =pod
1562:
1.112 bowersj2 1563: =head1 Authentication Routines
1564:
1565: =over 4
1566:
1567: =item * authform_xxxxxx
1.35 matthew 1568:
1569: The authform_xxxxxx subroutines provide javascript and html forms which
1570: handle some of the conveniences required for authentication forms.
1571: This is not an optimal method, but it works.
1572:
1573: See loncreateuser.pm for invocation and use examples.
1574:
1575: =over 4
1576:
1.112 bowersj2 1577: =item * authform_header
1.35 matthew 1578:
1.112 bowersj2 1579: =item * authform_authorwarning
1.35 matthew 1580:
1.112 bowersj2 1581: =item * authform_nochange
1.35 matthew 1582:
1.112 bowersj2 1583: =item * authform_kerberos
1.35 matthew 1584:
1.112 bowersj2 1585: =item * authform_internal
1.35 matthew 1586:
1.112 bowersj2 1587: =item * authform_filesystem
1.35 matthew 1588:
1589: =back
1590:
1.157 matthew 1591: =back
1592:
1.35 matthew 1593: =cut
1594:
1595: #-------------------------------------------
1.32 matthew 1596: sub authform_header{
1597: my %in = (
1598: formname => 'cu',
1.80 albertel 1599: kerb_def_dom => '',
1.32 matthew 1600: @_,
1601: );
1602: $in{'formname'} = 'document.' . $in{'formname'};
1603: my $result='';
1.80 albertel 1604:
1605: #---------------------------------------------- Code for upper case translation
1606: my $Javascript_toUpperCase;
1607: unless ($in{kerb_def_dom}) {
1608: $Javascript_toUpperCase =<<"END";
1609: switch (choice) {
1610: case 'krb': currentform.elements[choicearg].value =
1611: currentform.elements[choicearg].value.toUpperCase();
1612: break;
1613: default:
1614: }
1615: END
1616: } else {
1617: $Javascript_toUpperCase = "";
1618: }
1619:
1.165 raeburn 1620: my $radioval = "'nochange'";
1.174 matthew 1621: if (exists($in{'curr_authtype'}) &&
1622: defined($in{'curr_authtype'}) &&
1623: $in{'curr_authtype'} ne '') {
1624: $radioval = "'$in{'curr_authtype'}arg'";
1625: }
1.165 raeburn 1626: my $argfield = 'null';
1627: if ( grep/^mode$/,(keys %in) ) {
1628: if ($in{'mode'} eq 'modifycourse') {
1629: if ( grep/^curr_authtype$/,(keys %in) ) {
1630: $radioval = "'$in{'curr_authtype'}'";
1631: }
1632: if ( grep/^curr_autharg$/,(keys %in) ) {
1633: unless ($in{'curr_autharg'} eq '') {
1634: $argfield = "'$in{'curr_autharg'}'";
1635: }
1636: }
1637: }
1638: }
1639:
1.32 matthew 1640: $result.=<<"END";
1641: var current = new Object();
1.165 raeburn 1642: current.radiovalue = $radioval;
1643: current.argfield = $argfield;
1.32 matthew 1644:
1645: function changed_radio(choice,currentform) {
1646: var choicearg = choice + 'arg';
1647: // If a radio button in changed, we need to change the argfield
1648: if (current.radiovalue != choice) {
1649: current.radiovalue = choice;
1650: if (current.argfield != null) {
1651: currentform.elements[current.argfield].value = '';
1652: }
1653: if (choice == 'nochange') {
1654: current.argfield = null;
1655: } else {
1656: current.argfield = choicearg;
1657: switch(choice) {
1658: case 'krb':
1659: currentform.elements[current.argfield].value =
1660: "$in{'kerb_def_dom'}";
1661: break;
1662: default:
1663: break;
1664: }
1665: }
1666: }
1667: return;
1668: }
1.22 www 1669:
1.32 matthew 1670: function changed_text(choice,currentform) {
1671: var choicearg = choice + 'arg';
1672: if (currentform.elements[choicearg].value !='') {
1.80 albertel 1673: $Javascript_toUpperCase
1.32 matthew 1674: // clear old field
1675: if ((current.argfield != choicearg) && (current.argfield != null)) {
1676: currentform.elements[current.argfield].value = '';
1677: }
1678: current.argfield = choicearg;
1679: }
1680: set_auth_radio_buttons(choice,currentform);
1681: return;
1.20 www 1682: }
1.32 matthew 1683:
1684: function set_auth_radio_buttons(newvalue,currentform) {
1685: var i=0;
1686: while (i < currentform.login.length) {
1687: if (currentform.login[i].value == newvalue) { break; }
1688: i++;
1689: }
1690: if (i == currentform.login.length) {
1691: return;
1692: }
1693: current.radiovalue = newvalue;
1694: currentform.login[i].checked = true;
1695: return;
1696: }
1697: END
1698: return $result;
1699: }
1700:
1701: sub authform_authorwarning{
1702: my $result='';
1.144 matthew 1703: $result='<i>'.
1704: &mt('As a general rule, only authors or co-authors should be '.
1705: 'filesystem authenticated '.
1706: '(which allows access to the server filesystem).')."</i>\n";
1.32 matthew 1707: return $result;
1708: }
1709:
1710: sub authform_nochange{
1711: my %in = (
1712: formname => 'document.cu',
1713: kerb_def_dom => 'MSU.EDU',
1714: @_,
1715: );
1.281 albertel 1716: my $result = '<label>'.&mt('[_1] Do not change login data',
1.144 matthew 1717: '<input type="radio" name="login" value="nochange" '.
1718: 'checked="checked" onclick="'.
1.281 albertel 1719: "javascript:changed_radio('nochange',$in{'formname'});".'" />').
1720: '</label>';
1.32 matthew 1721: return $result;
1722: }
1723:
1724: sub authform_kerberos{
1725: my %in = (
1726: formname => 'document.cu',
1727: kerb_def_dom => 'MSU.EDU',
1.80 albertel 1728: kerb_def_auth => 'krb4',
1.32 matthew 1729: @_,
1730: );
1.165 raeburn 1731: my ($check4,$check5,$krbarg);
1.80 albertel 1732: if ($in{'kerb_def_auth'} eq 'krb5') {
1733: $check5 = " checked=\"on\"";
1734: } else {
1735: $check4 = " checked=\"on\"";
1736: }
1.165 raeburn 1737: $krbarg = $in{'kerb_def_dom'};
1738:
1739: my $krbcheck = "";
1740: if ( grep/^curr_authtype$/,(keys %in) ) {
1741: if ($in{'curr_authtype'} =~ m/^krb/) {
1742: $krbcheck = " checked=\"on\"";
1743: if ( grep/^curr_autharg$/,(keys %in) ) {
1744: $krbarg = $in{'curr_autharg'};
1745: }
1746: }
1747: }
1748:
1.144 matthew 1749: my $jscall = "javascript:changed_radio('krb',$in{'formname'});";
1750: my $result .= &mt
1751: ('[_1] Kerberos authenticated with domain [_2] '.
1.281 albertel 1752: '[_3] Version 4 [_4] Version 5 [_5]',
1753: '<label><input type="radio" name="login" value="krb" '.
1.165 raeburn 1754: 'onclick="'.$jscall.'" onchange="'.$jscall.'"'.$krbcheck.' />',
1.281 albertel 1755: '</label><input type="text" size="10" name="krbarg" '.
1.165 raeburn 1756: 'value="'.$krbarg.'" '.
1.144 matthew 1757: 'onchange="'.$jscall.'" />',
1.281 albertel 1758: '<label><input type="radio" name="krbver" value="4" '.$check4.' />',
1759: '</label><label><input type="radio" name="krbver" value="5" '.$check5.' />',
1760: '</label>');
1.32 matthew 1761: return $result;
1762: }
1763:
1764: sub authform_internal{
1765: my %args = (
1766: formname => 'document.cu',
1767: kerb_def_dom => 'MSU.EDU',
1768: @_,
1769: );
1.165 raeburn 1770:
1771: my $intcheck = "";
1772: my $intarg = 'value=""';
1773: if ( grep/^curr_authtype$/,(keys %args) ) {
1774: if ($args{'curr_authtype'} eq 'int') {
1775: $intcheck = " checked=\"on\"";
1776: if ( grep/^curr_autharg$/,(keys %args) ) {
1777: $intarg = "value=\"$args{'curr_autharg'}\"";
1778: }
1779: }
1780: }
1781:
1.144 matthew 1782: my $jscall = "javascript:changed_radio('int',$args{'formname'});";
1783: my $result.=&mt
1784: ('[_1] Internally authenticated (with initial password [_2])',
1.281 albertel 1785: '<label><input type="radio" name="login" value="int" '.$intcheck.
1.165 raeburn 1786: ' onchange="'.$jscall.'" onclick="'.$jscall.'" />',
1.281 albertel 1787: '</label><input type="text" size="10" name="intarg" '.$intarg.
1.165 raeburn 1788: ' onchange="'.$jscall.'" />');
1.32 matthew 1789: return $result;
1790: }
1791:
1792: sub authform_local{
1793: my %in = (
1794: formname => 'document.cu',
1795: kerb_def_dom => 'MSU.EDU',
1796: @_,
1797: );
1.165 raeburn 1798:
1799: my $loccheck = "";
1800: my $locarg = 'value=""';
1801: if ( grep/^curr_authtype$/,(keys %in) ) {
1802: if ($in{'curr_authtype'} eq 'loc') {
1803: $loccheck = " checked=\"on\"";
1804: if ( grep/^curr_autharg$/,(keys %in) ) {
1805: $locarg = "value=\"$in{'curr_autharg'}\"";
1806: }
1807: }
1808: }
1809:
1.144 matthew 1810: my $jscall = "javascript:changed_radio('loc',$in{'formname'});";
1.160 matthew 1811: my $result.=&mt('[_1] Local Authentication with argument [_2]',
1.281 albertel 1812: '<label><input type="radio" name="login" value="loc" '.$loccheck.
1.165 raeburn 1813: ' onchange="'.$jscall.'" onclick="'.$jscall.'" />',
1.281 albertel 1814: '</label><input type="text" size="10" name="locarg" '.$locarg.
1.165 raeburn 1815: ' onchange="'.$jscall.'" />');
1.32 matthew 1816: return $result;
1817: }
1818:
1819: sub authform_filesystem{
1820: my %in = (
1821: formname => 'document.cu',
1822: kerb_def_dom => 'MSU.EDU',
1823: @_,
1824: );
1.144 matthew 1825: my $jscall = "javascript:changed_radio('fsys',$in{'formname'});";
1826: my $result.= &mt
1827: ('[_1] Filesystem Authenticated (with initial password [_2])',
1.281 albertel 1828: '<label><input type="radio" name="login" value="fsys" '.
1.144 matthew 1829: 'onchange="'.$jscall.'" onclick="'.$jscall.'" />',
1.281 albertel 1830: '</label><input type="text" size="10" name="fsysarg" value="" '.
1.144 matthew 1831: 'onchange="'.$jscall.'" />');
1.32 matthew 1832: return $result;
1833: }
1834:
1.80 albertel 1835: ###############################################################
1836: ## Get Authentication Defaults for Domain ##
1837: ###############################################################
1838:
1839: =pod
1840:
1.112 bowersj2 1841: =head1 Domains and Authentication
1842:
1843: Returns default authentication type and an associated argument as
1844: listed in file 'domain.tab'.
1845:
1846: =over 4
1847:
1848: =item * get_auth_defaults
1.80 albertel 1849:
1850: get_auth_defaults($target_domain) returns the default authentication
1851: type and an associated argument (initial password or a kerberos domain).
1852: These values are stored in lonTabs/domain.tab
1853:
1854: ($def_auth, $def_arg) = &get_auth_defaults($target_domain);
1855:
1856: If target_domain is not found in domain.tab, returns nothing ('').
1857:
1858: =cut
1859:
1860: #-------------------------------------------
1861: sub get_auth_defaults {
1862: my $domain=shift;
1.514 albertel 1863: return (&Apache::lonnet::domain($domain,'auth_def'),
1864: &Apache::lonnet::domain($domain,'auth_arg_def'));
1865:
1.80 albertel 1866: }
1867: ###############################################################
1868: ## End Get Authentication Defaults for Domain ##
1869: ###############################################################
1870:
1871: ###############################################################
1872: ## Get Kerberos Defaults for Domain ##
1873: ###############################################################
1874: ##
1875: ## Returns default kerberos version and an associated argument
1876: ## as listed in file domain.tab. If not listed, provides
1877: ## appropriate default domain and kerberos version.
1878: ##
1879: #-------------------------------------------
1880:
1881: =pod
1882:
1.112 bowersj2 1883: =item * get_kerberos_defaults
1.80 albertel 1884:
1885: get_kerberos_defaults($target_domain) returns the default kerberos
1886: version and domain. If not found in domain.tabs, it defaults to
1887: version 4 and the domain of the server.
1888:
1889: ($def_version, $def_krb_domain) = &get_kerberos_defaults($target_domain);
1890:
1891: =cut
1892:
1893: #-------------------------------------------
1894: sub get_kerberos_defaults {
1895: my $domain=shift;
1896: my ($krbdef,$krbdefdom) =
1897: &Apache::loncommon::get_auth_defaults($domain);
1898: unless ($krbdef =~/^krb/ && $krbdefdom) {
1899: $ENV{'SERVER_NAME'}=~/(\w+\.\w+)$/;
1900: my $krbdefdom=$1;
1901: $krbdefdom=~tr/a-z/A-Z/;
1902: $krbdef = "krb4";
1903: }
1904: return ($krbdef,$krbdefdom);
1905: }
1.112 bowersj2 1906:
1907: =pod
1908:
1909: =back
1910:
1911: =cut
1.32 matthew 1912:
1.46 matthew 1913: ###############################################################
1914: ## Thesaurus Functions ##
1915: ###############################################################
1.20 www 1916:
1.46 matthew 1917: =pod
1.20 www 1918:
1.112 bowersj2 1919: =head1 Thesaurus Functions
1920:
1921: =over 4
1922:
1923: =item * initialize_keywords
1.46 matthew 1924:
1925: Initializes the package variable %Keywords if it is empty. Uses the
1926: package variable $thesaurus_db_file.
1927:
1928: =cut
1929:
1930: ###################################################
1931:
1932: sub initialize_keywords {
1933: return 1 if (scalar keys(%Keywords));
1934: # If we are here, %Keywords is empty, so fill it up
1935: # Make sure the file we need exists...
1936: if (! -e $thesaurus_db_file) {
1937: &Apache::lonnet::logthis("Attempt to access $thesaurus_db_file".
1938: " failed because it does not exist");
1939: return 0;
1940: }
1941: # Set up the hash as a database
1942: my %thesaurus_db;
1943: if (! tie(%thesaurus_db,'GDBM_File',
1.53 albertel 1944: $thesaurus_db_file,&GDBM_READER(),0640)){
1.46 matthew 1945: &Apache::lonnet::logthis("Could not tie \%thesaurus_db to ".
1946: $thesaurus_db_file);
1947: return 0;
1948: }
1949: # Get the average number of appearances of a word.
1950: my $avecount = $thesaurus_db{'average.count'};
1951: # Put keywords (those that appear > average) into %Keywords
1952: while (my ($word,$data)=each (%thesaurus_db)) {
1953: my ($count,undef) = split /:/,$data;
1954: $Keywords{$word}++ if ($count > $avecount);
1955: }
1956: untie %thesaurus_db;
1957: # Remove special values from %Keywords.
1.356 albertel 1958: foreach my $value ('total.count','average.count') {
1959: delete($Keywords{$value}) if (exists($Keywords{$value}));
1.46 matthew 1960: }
1961: return 1;
1962: }
1963:
1964: ###################################################
1965:
1966: =pod
1967:
1.112 bowersj2 1968: =item * keyword($word)
1.46 matthew 1969:
1970: Returns true if $word is a keyword. A keyword is a word that appears more
1971: than the average number of times in the thesaurus database. Calls
1972: &initialize_keywords
1973:
1974: =cut
1975:
1976: ###################################################
1.20 www 1977:
1978: sub keyword {
1.46 matthew 1979: return if (!&initialize_keywords());
1980: my $word=lc(shift());
1981: $word=~s/\W//g;
1982: return exists($Keywords{$word});
1.20 www 1983: }
1.46 matthew 1984:
1985: ###############################################################
1986:
1987: =pod
1.20 www 1988:
1.112 bowersj2 1989: =item * get_related_words
1.46 matthew 1990:
1.160 matthew 1991: Look up a word in the thesaurus. Takes a scalar argument and returns
1.46 matthew 1992: an array of words. If the keyword is not in the thesaurus, an empty array
1993: will be returned. The order of the words returned is determined by the
1994: database which holds them.
1995:
1996: Uses global $thesaurus_db_file.
1997:
1998: =cut
1999:
2000: ###############################################################
2001: sub get_related_words {
2002: my $keyword = shift;
2003: my %thesaurus_db;
2004: if (! -e $thesaurus_db_file) {
2005: &Apache::lonnet::logthis("Attempt to access $thesaurus_db_file ".
2006: "failed because the file does not exist");
2007: return ();
2008: }
2009: if (! tie(%thesaurus_db,'GDBM_File',
1.53 albertel 2010: $thesaurus_db_file,&GDBM_READER(),0640)){
1.46 matthew 2011: return ();
2012: }
2013: my @Words=();
1.429 www 2014: my $count=0;
1.46 matthew 2015: if (exists($thesaurus_db{$keyword})) {
1.356 albertel 2016: # The first element is the number of times
2017: # the word appears. We do not need it now.
1.429 www 2018: my (undef,@RelatedWords) = (split(/:/,$thesaurus_db{$keyword}));
2019: my (undef,$mostfrequentcount)=split(/\,/,$RelatedWords[0]);
2020: my $threshold=$mostfrequentcount/10;
2021: foreach my $possibleword (@RelatedWords) {
2022: my ($word,$wordcount)=split(/\,/,$possibleword);
2023: if ($wordcount>$threshold) {
2024: push(@Words,$word);
2025: $count++;
2026: if ($count>10) { last; }
2027: }
1.20 www 2028: }
2029: }
1.46 matthew 2030: untie %thesaurus_db;
2031: return @Words;
1.14 harris41 2032: }
1.46 matthew 2033:
1.112 bowersj2 2034: =pod
2035:
2036: =back
2037:
2038: =cut
1.61 www 2039:
2040: # -------------------------------------------------------------- Plaintext name
1.81 albertel 2041: =pod
2042:
1.112 bowersj2 2043: =head1 User Name Functions
2044:
2045: =over 4
2046:
1.226 albertel 2047: =item * plainname($uname,$udom,$first)
1.81 albertel 2048:
1.112 bowersj2 2049: Takes a users logon name and returns it as a string in
1.226 albertel 2050: "first middle last generation" form
2051: if $first is set to 'lastname' then it returns it as
2052: 'lastname generation, firstname middlename' if their is a lastname
1.81 albertel 2053:
2054: =cut
1.61 www 2055:
1.295 www 2056:
1.81 albertel 2057: ###############################################################
1.61 www 2058: sub plainname {
1.226 albertel 2059: my ($uname,$udom,$first)=@_;
1.537 albertel 2060: return if (!defined($uname) || !defined($udom));
1.295 www 2061: my %names=&getnames($uname,$udom);
1.226 albertel 2062: my $name=&Apache::lonnet::format_name($names{'firstname'},
2063: $names{'middlename'},
2064: $names{'lastname'},
2065: $names{'generation'},$first);
2066: $name=~s/^\s+//;
1.62 www 2067: $name=~s/\s+$//;
2068: $name=~s/\s+/ /g;
1.353 albertel 2069: if ($name !~ /\S/) { $name=$uname.':'.$udom; }
1.62 www 2070: return $name;
1.61 www 2071: }
1.66 www 2072:
2073: # -------------------------------------------------------------------- Nickname
1.81 albertel 2074: =pod
2075:
1.112 bowersj2 2076: =item * nickname($uname,$udom)
1.81 albertel 2077:
2078: Gets a users name and returns it as a string as
2079:
2080: ""nickname""
1.66 www 2081:
1.81 albertel 2082: if the user has a nickname or
2083:
2084: "first middle last generation"
2085:
2086: if the user does not
2087:
2088: =cut
1.66 www 2089:
2090: sub nickname {
2091: my ($uname,$udom)=@_;
1.537 albertel 2092: return if (!defined($uname) || !defined($udom));
1.295 www 2093: my %names=&getnames($uname,$udom);
1.68 albertel 2094: my $name=$names{'nickname'};
1.66 www 2095: if ($name) {
2096: $name='"'.$name.'"';
2097: } else {
2098: $name=$names{'firstname'}.' '.$names{'middlename'}.' '.
2099: $names{'lastname'}.' '.$names{'generation'};
2100: $name=~s/\s+$//;
2101: $name=~s/\s+/ /g;
2102: }
2103: return $name;
2104: }
2105:
1.295 www 2106: sub getnames {
2107: my ($uname,$udom)=@_;
1.537 albertel 2108: return if (!defined($uname) || !defined($udom));
1.433 albertel 2109: if ($udom eq 'public' && $uname eq 'public') {
2110: return ('lastname' => &mt('Public'));
2111: }
1.295 www 2112: my $id=$uname.':'.$udom;
2113: my ($names,$cached)=&Apache::lonnet::is_cached_new('namescache',$id);
2114: if ($cached) {
2115: return %{$names};
2116: } else {
2117: my %loadnames=&Apache::lonnet::get('environment',
2118: ['firstname','middlename','lastname','generation','nickname'],
2119: $udom,$uname);
2120: &Apache::lonnet::do_cache_new('namescache',$id,\%loadnames);
2121: return %loadnames;
2122: }
2123: }
1.61 www 2124:
1.542 raeburn 2125: # -------------------------------------------------------------------- getemails
2126: =pod
2127:
2128: =item * getemails($uname,$udom)
2129:
2130: Gets a user's email information and returns it as a hash with keys:
2131: notification, critnotification, permanentemail
2132:
2133: For notification and critnotification, values are comma-separated lists
2134: of e-mail address(es); for permanentemail, value is a single e-mail address.
2135:
2136: =cut
2137:
1.466 albertel 2138: sub getemails {
2139: my ($uname,$udom)=@_;
2140: if ($udom eq 'public' && $uname eq 'public') {
2141: return;
2142: }
1.467 www 2143: if (!$udom) { $udom=$env{'user.domain'}; }
2144: if (!$uname) { $uname=$env{'user.name'}; }
1.466 albertel 2145: my $id=$uname.':'.$udom;
2146: my ($names,$cached)=&Apache::lonnet::is_cached_new('emailscache',$id);
2147: if ($cached) {
2148: return %{$names};
2149: } else {
2150: my %loadnames=&Apache::lonnet::get('environment',
2151: ['notification','critnotification',
2152: 'permanentemail'],
2153: $udom,$uname);
2154: &Apache::lonnet::do_cache_new('emailscache',$id,\%loadnames);
2155: return %loadnames;
2156: }
2157: }
2158:
1.551 ! albertel 2159: sub flush_email_cache {
! 2160: my ($uname,$udom)=@_;
! 2161: if (!$udom) { $udom =$env{'user.domain'}; }
! 2162: if (!$uname) { $uname=$env{'user.name'}; }
! 2163: return if ($udom eq 'public' && $uname eq 'public');
! 2164: my $id=$uname.':'.$udom;
! 2165: &Apache::lonnet::devalidate_cache_new('emailscache',$id);
! 2166: }
! 2167:
1.61 www 2168: # ------------------------------------------------------------------ Screenname
1.81 albertel 2169:
2170: =pod
2171:
1.112 bowersj2 2172: =item * screenname($uname,$udom)
1.81 albertel 2173:
2174: Gets a users screenname and returns it as a string
2175:
2176: =cut
1.61 www 2177:
2178: sub screenname {
2179: my ($uname,$udom)=@_;
1.258 albertel 2180: if ($uname eq $env{'user.name'} &&
2181: $udom eq $env{'user.domain'}) {return $env{'environment.screenname'};}
1.212 albertel 2182: my %names=&Apache::lonnet::get('environment',['screenname'],$udom,$uname);
1.68 albertel 2183: return $names{'screenname'};
1.62 www 2184: }
2185:
1.212 albertel 2186:
1.62 www 2187: # ------------------------------------------------------------- Message Wrapper
2188:
2189: sub messagewrapper {
1.369 www 2190: my ($link,$username,$domain,$subject,$text)=@_;
1.62 www 2191: return
1.441 albertel 2192: '<a href="/adm/email?compose=individual&'.
2193: 'recname='.$username.'&recdom='.$domain.
2194: '&subject='.&escape($subject).'&text='.&escape($text).'" '.
1.200 matthew 2195: 'title="'.&mt('Send message').'">'.$link.'</a>';
1.74 www 2196: }
2197: # --------------------------------------------------------------- Notes Wrapper
2198:
2199: sub noteswrapper {
2200: my ($link,$un,$do)=@_;
2201: return
2202: "<a href='/adm/email?recordftf=retrieve&recname=$un&recdom=$do'>$link</a>";
1.62 www 2203: }
2204: # ------------------------------------------------------------- Aboutme Wrapper
2205:
2206: sub aboutmewrapper {
1.166 www 2207: my ($link,$username,$domain,$target)=@_;
1.447 raeburn 2208: if (!defined($username) && !defined($domain)) {
2209: return;
2210: }
1.205 www 2211: return '<a href="/adm/'.$domain.'/'.$username.'/aboutme"'.
1.454 banghart 2212: ($target?' target="$target"':'').' title="'.&mt("View this user's personal page").'">'.$link.'</a>';
1.62 www 2213: }
2214:
2215: # ------------------------------------------------------------ Syllabus Wrapper
2216:
2217:
2218: sub syllabuswrapper {
1.109 matthew 2219: my ($linktext,$coursedir,$domain,$fontcolor)=@_;
2220: if ($fontcolor) {
2221: $linktext='<font color="'.$fontcolor.'">'.$linktext.'</font>';
2222: }
1.208 matthew 2223: return qq{<a href="/public/$domain/$coursedir/syllabus">$linktext</a>};
1.61 www 2224: }
1.14 harris41 2225:
1.208 matthew 2226: sub track_student_link {
1.268 albertel 2227: my ($linktext,$sname,$sdom,$target,$start) = @_;
2228: my $link ="/adm/trackstudent?";
1.208 matthew 2229: my $title = 'View recent activity';
2230: if (defined($sname) && $sname !~ /^\s*$/ &&
2231: defined($sdom) && $sdom !~ /^\s*$/) {
1.268 albertel 2232: $link .= "selected_student=$sname:$sdom";
1.208 matthew 2233: $title .= ' of this student';
1.268 albertel 2234: }
1.208 matthew 2235: if (defined($target) && $target !~ /^\s*$/) {
2236: $target = qq{target="$target"};
2237: } else {
2238: $target = '';
2239: }
1.268 albertel 2240: if ($start) { $link.='&start='.$start; }
1.448 albertel 2241:
2242: return qq{<a href="$link" title="$title" $target>$linktext</a>}.
2243: &help_open_topic('View_recent_activity');
1.208 matthew 2244: }
2245:
1.508 www 2246: # ===================================================== Display a student photo
2247:
2248:
1.509 albertel 2249: sub student_image_tag {
1.508 www 2250: my ($domain,$user)=@_;
2251: my $imgsrc=&Apache::lonnet::studentphoto($domain,$user,'jpg');
2252: if (($imgsrc) && ($imgsrc ne '/adm/lonKaputt/lonlogo_broken.gif')) {
2253: return '<img src="'.$imgsrc.'" align="right" />';
2254: } else {
2255: return '';
2256: }
2257: }
2258:
1.112 bowersj2 2259: =pod
2260:
2261: =back
2262:
2263: =head1 Access .tab File Data
2264:
2265: =over 4
2266:
2267: =item * languageids()
2268:
2269: returns list of all language ids
2270:
2271: =cut
2272:
1.14 harris41 2273: sub languageids {
1.16 harris41 2274: return sort(keys(%language));
1.14 harris41 2275: }
2276:
1.112 bowersj2 2277: =pod
2278:
2279: =item * languagedescription()
2280:
2281: returns description of a specified language id
2282:
2283: =cut
2284:
1.14 harris41 2285: sub languagedescription {
1.125 www 2286: my $code=shift;
2287: return ($supported_language{$code}?'* ':'').
2288: $language{$code}.
1.126 www 2289: ($supported_language{$code}?' ('.&mt('interface available').')':'');
1.145 www 2290: }
2291:
2292: sub plainlanguagedescription {
2293: my $code=shift;
2294: return $language{$code};
2295: }
2296:
2297: sub supportedlanguagecode {
2298: my $code=shift;
2299: return $supported_language{$code};
1.97 www 2300: }
2301:
1.112 bowersj2 2302: =pod
2303:
2304: =item * copyrightids()
2305:
2306: returns list of all copyrights
2307:
2308: =cut
2309:
2310: sub copyrightids {
2311: return sort(keys(%cprtag));
2312: }
2313:
2314: =pod
2315:
2316: =item * copyrightdescription()
2317:
2318: returns description of a specified copyright id
2319:
2320: =cut
2321:
2322: sub copyrightdescription {
1.166 www 2323: return &mt($cprtag{shift(@_)});
1.112 bowersj2 2324: }
1.197 matthew 2325:
2326: =pod
2327:
1.192 taceyjo1 2328: =item * source_copyrightids()
2329:
2330: returns list of all source copyrights
2331:
2332: =cut
2333:
2334: sub source_copyrightids {
2335: return sort(keys(%scprtag));
2336: }
2337:
2338: =pod
2339:
2340: =item * source_copyrightdescription()
2341:
2342: returns description of a specified source copyright id
2343:
2344: =cut
2345:
2346: sub source_copyrightdescription {
2347: return &mt($scprtag{shift(@_)});
2348: }
1.112 bowersj2 2349:
2350: =pod
2351:
2352: =item * filecategories()
2353:
2354: returns list of all file categories
2355:
2356: =cut
2357:
2358: sub filecategories {
2359: return sort(keys(%category_extensions));
2360: }
2361:
2362: =pod
2363:
2364: =item * filecategorytypes()
2365:
2366: returns list of file types belonging to a given file
2367: category
2368:
2369: =cut
2370:
2371: sub filecategorytypes {
1.356 albertel 2372: my ($cat) = @_;
2373: return @{$category_extensions{lc($cat)}};
1.112 bowersj2 2374: }
2375:
2376: =pod
2377:
2378: =item * fileembstyle()
2379:
2380: returns embedding style for a specified file type
2381:
2382: =cut
2383:
2384: sub fileembstyle {
2385: return $fe{lc(shift(@_))};
1.169 www 2386: }
2387:
1.351 www 2388: sub filemimetype {
2389: return $fm{lc(shift(@_))};
2390: }
2391:
1.169 www 2392:
2393: sub filecategoryselect {
2394: my ($name,$value)=@_;
1.189 matthew 2395: return &select_form($value,$name,
1.169 www 2396: '' => &mt('Any category'),
2397: map { $_,$_ } sort(keys(%category_extensions)));
1.112 bowersj2 2398: }
2399:
2400: =pod
2401:
2402: =item * filedescription()
2403:
2404: returns description for a specified file type
2405:
2406: =cut
2407:
2408: sub filedescription {
1.188 matthew 2409: my $file_description = $fd{lc(shift())};
2410: $file_description =~ s:([\[\]]):~$1:g;
2411: return &mt($file_description);
1.112 bowersj2 2412: }
2413:
2414: =pod
2415:
2416: =item * filedescriptionex()
2417:
2418: returns description for a specified file type with
2419: extra formatting
2420:
2421: =cut
2422:
2423: sub filedescriptionex {
2424: my $ex=shift;
1.188 matthew 2425: my $file_description = $fd{lc($ex)};
2426: $file_description =~ s:([\[\]]):~$1:g;
2427: return '.'.$ex.' '.&mt($file_description);
1.112 bowersj2 2428: }
2429:
2430: # End of .tab access
2431: =pod
2432:
2433: =back
2434:
2435: =cut
2436:
2437: # ------------------------------------------------------------------ File Types
2438: sub fileextensions {
2439: return sort(keys(%fe));
2440: }
2441:
1.97 www 2442: # ----------------------------------------------------------- Display Languages
2443: # returns a hash with all desired display languages
2444: #
2445:
2446: sub display_languages {
2447: my %languages=();
1.356 albertel 2448: foreach my $lang (&preferred_languages()) {
2449: $languages{$lang}=1;
1.97 www 2450: }
2451: &get_unprocessed_cgi($ENV{'QUERY_STRING'},['displaylanguage']);
1.258 albertel 2452: if ($env{'form.displaylanguage'}) {
1.356 albertel 2453: foreach my $lang (split(/\s*(\,|\;|\:)\s*/,$env{'form.displaylanguage'})) {
2454: $languages{$lang}=1;
1.97 www 2455: }
2456: }
2457: return %languages;
1.14 harris41 2458: }
2459:
1.117 www 2460: sub preferred_languages {
2461: my @languages=();
1.258 albertel 2462: if ($env{'course.'.$env{'request.course.id'}.'.languages'}) {
1.117 www 2463: @languages=(@languages,split(/\s*(\,|\;|\:)\s*/,
1.258 albertel 2464: $env{'course.'.$env{'request.course.id'}.'.languages'}));
1.177 www 2465: }
1.258 albertel 2466: if ($env{'environment.languages'}) {
1.459 albertel 2467: @languages=(@languages,
2468: split(/\s*(\,|\;|\:)\s*/,$env{'environment.languages'}));
1.118 www 2469: }
1.162 www 2470: my $browser=(split(/\;/,$ENV{'HTTP_ACCEPT_LANGUAGE'}))[0];
2471: if ($browser) {
2472: @languages=(@languages,split(/\s*(\,|\;|\:)\s*/,$browser));
2473: }
1.514 albertel 2474: if (&Apache::lonnet::domain($env{'user.domain'},'lang_def')) {
1.118 www 2475: @languages=(@languages,
1.514 albertel 2476: &Apache::lonnet::domain($env{'user.domain'},
2477: 'lang_def'));
1.118 www 2478: }
1.514 albertel 2479: if (&Apache::lonnet::domain($env{'request.role.domain'},'lang_def')) {
1.118 www 2480: @languages=(@languages,
1.514 albertel 2481: &Apache::lonnet::domain($env{'request.role.domain'},
2482: 'lang_def'));
1.118 www 2483: }
1.514 albertel 2484: if (&Apache::lonnet::domain($Apache::lonnet::perlvar{'lonDefDomain'},
2485: 'lang_def')) {
1.118 www 2486: @languages=(@languages,
1.514 albertel 2487: &Apache::lonnet::domain($Apache::lonnet::perlvar{'lonDefDomain'},
2488: 'lang_def'));
1.118 www 2489: }
2490: # turn "en-ca" into "en-ca,en"
2491: my @genlanguages;
1.356 albertel 2492: foreach my $lang (@languages) {
2493: unless ($lang=~/\w/) { next; }
2494: push (@genlanguages,$lang);
2495: if ($lang=~/(\-|\_)/) {
2496: push(@genlanguages,(split(/(\-|\_)/,$lang))[0]);
1.118 www 2497: }
2498: }
2499: return @genlanguages;
1.117 www 2500: }
2501:
1.112 bowersj2 2502: ###############################################################
2503: ## Student Answer Attempts ##
2504: ###############################################################
2505:
2506: =pod
2507:
2508: =head1 Alternate Problem Views
2509:
2510: =over 4
2511:
2512: =item * get_previous_attempt($symb, $username, $domain, $course,
2513: $getattempt, $regexp, $gradesub)
2514:
2515: Return string with previous attempt on problem. Arguments:
2516:
2517: =over 4
2518:
2519: =item * $symb: Problem, including path
2520:
2521: =item * $username: username of the desired student
2522:
2523: =item * $domain: domain of the desired student
1.14 harris41 2524:
1.112 bowersj2 2525: =item * $course: Course ID
1.14 harris41 2526:
1.112 bowersj2 2527: =item * $getattempt: Leave blank for all attempts, otherwise put
2528: something
1.14 harris41 2529:
1.112 bowersj2 2530: =item * $regexp: if string matches this regexp, the string will be
2531: sent to $gradesub
1.14 harris41 2532:
1.112 bowersj2 2533: =item * $gradesub: routine that processes the string if it matches $regexp
1.14 harris41 2534:
1.112 bowersj2 2535: =back
1.14 harris41 2536:
1.112 bowersj2 2537: The output string is a table containing all desired attempts, if any.
1.16 harris41 2538:
1.112 bowersj2 2539: =cut
1.1 albertel 2540:
2541: sub get_previous_attempt {
1.43 ng 2542: my ($symb,$username,$domain,$course,$getattempt,$regexp,$gradesub)=@_;
1.1 albertel 2543: my $prevattempts='';
1.43 ng 2544: no strict 'refs';
1.1 albertel 2545: if ($symb) {
1.3 albertel 2546: my (%returnhash)=
2547: &Apache::lonnet::restore($symb,$course,$domain,$username);
1.1 albertel 2548: if ($returnhash{'version'}) {
2549: my %lasthash=();
2550: my $version;
2551: for ($version=1;$version<=$returnhash{'version'};$version++) {
1.356 albertel 2552: foreach my $key (sort(split(/\:/,$returnhash{$version.':keys'}))) {
2553: $lasthash{$key}=$returnhash{$version.':'.$key};
1.19 harris41 2554: }
1.1 albertel 2555: }
1.43 ng 2556: $prevattempts='<table border="0" width="100%"><tr><td bgcolor="#777777">';
1.40 ng 2557: $prevattempts.='<table border="0" width="100%"><tr bgcolor="#e6ffff"><td>History</td>';
1.356 albertel 2558: foreach my $key (sort(keys(%lasthash))) {
2559: my ($ign,@parts) = split(/\./,$key);
1.41 ng 2560: if ($#parts > 0) {
1.31 albertel 2561: my $data=$parts[-1];
2562: pop(@parts);
1.40 ng 2563: $prevattempts.='<td>Part '.join('.',@parts).'<br />'.$data.' </td>';
1.31 albertel 2564: } else {
1.41 ng 2565: if ($#parts == 0) {
2566: $prevattempts.='<th>'.$parts[0].'</th>';
2567: } else {
2568: $prevattempts.='<th>'.$ign.'</th>';
2569: }
1.31 albertel 2570: }
1.16 harris41 2571: }
1.40 ng 2572: if ($getattempt eq '') {
2573: for ($version=1;$version<=$returnhash{'version'};$version++) {
2574: $prevattempts.='</tr><tr bgcolor="#ffffe6"><td>Transaction '.$version.'</td>';
1.356 albertel 2575: foreach my $key (sort(keys(%lasthash))) {
1.40 ng 2576: my $value;
1.356 albertel 2577: if ($key =~ /timestamp/) {
2578: $value=scalar(localtime($returnhash{$version.':'.$key}));
1.40 ng 2579: } else {
1.356 albertel 2580: $value=$returnhash{$version.':'.$key};
1.40 ng 2581: }
1.369 www 2582: $prevattempts.='<td>'.&unescape($value).' </td>';
1.40 ng 2583: }
2584: }
1.1 albertel 2585: }
1.40 ng 2586: $prevattempts.='</tr><tr bgcolor="#ffffe6"><td>Current</td>';
1.356 albertel 2587: foreach my $key (sort(keys(%lasthash))) {
1.5 albertel 2588: my $value;
1.356 albertel 2589: if ($key =~ /timestamp/) {
2590: $value=scalar(localtime($lasthash{$key}));
1.5 albertel 2591: } else {
1.356 albertel 2592: $value=$lasthash{$key};
1.5 albertel 2593: }
1.369 www 2594: $value=&unescape($value);
1.356 albertel 2595: if ($key =~/$regexp$/ && (defined &$gradesub)) {$value = &$gradesub($value)}
1.40 ng 2596: $prevattempts.='<td>'.$value.' </td>';
1.16 harris41 2597: }
1.40 ng 2598: $prevattempts.='</tr></table></td></tr></table>';
1.1 albertel 2599: } else {
2600: $prevattempts='Nothing submitted - no attempts.';
2601: }
2602: } else {
2603: $prevattempts='No data.';
2604: }
1.10 albertel 2605: }
2606:
1.107 albertel 2607: sub relative_to_absolute {
2608: my ($url,$output)=@_;
2609: my $parser=HTML::TokeParser->new(\$output);
2610: my $token;
2611: my $thisdir=$url;
2612: my @rlinks=();
2613: while ($token=$parser->get_token) {
2614: if ($token->[0] eq 'S') {
2615: if ($token->[1] eq 'a') {
2616: if ($token->[2]->{'href'}) {
2617: $rlinks[$#rlinks+1]=$token->[2]->{'href'};
2618: }
2619: } elsif ($token->[1] eq 'img' || $token->[1] eq 'embed' ) {
2620: $rlinks[$#rlinks+1]=$token->[2]->{'src'};
2621: } elsif ($token->[1] eq 'base') {
2622: $thisdir=$token->[2]->{'href'};
2623: }
2624: }
2625: }
2626: $thisdir=~s-/[^/]*$--;
1.356 albertel 2627: foreach my $link (@rlinks) {
2628: unless (($link=~/^http:\/\//i) ||
2629: ($link=~/^\//) ||
2630: ($link=~/^javascript:/i) ||
2631: ($link=~/^mailto:/i) ||
2632: ($link=~/^\#/)) {
2633: my $newlocation=&Apache::lonnet::hreflocation($thisdir,$link);
2634: $output=~s/(\"|\'|\=\s*)\Q$link\E(\"|\'|\s|\>)/$1$newlocation$2/;
1.107 albertel 2635: }
2636: }
2637: # -------------------------------------------------- Deal with Applet codebases
2638: $output=~s/(\<applet[^\>]+)(codebase\=[^\S\>]+)*([^\>]*)\>/$1.($2?$2:' codebase="'.$thisdir.'"').$3.'>'/gei;
2639: return $output;
2640: }
2641:
1.112 bowersj2 2642: =pod
2643:
2644: =item * get_student_view
2645:
2646: show a snapshot of what student was looking at
2647:
2648: =cut
2649:
1.10 albertel 2650: sub get_student_view {
1.186 albertel 2651: my ($symb,$username,$domain,$courseid,$target,$moreenv) = @_;
1.114 www 2652: my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb);
1.186 albertel 2653: my (%form);
1.10 albertel 2654: my @elements=('symb','courseid','domain','username');
2655: foreach my $element (@elements) {
1.186 albertel 2656: $form{'grade_'.$element}=eval '$'.$element #'
1.10 albertel 2657: }
1.186 albertel 2658: if (defined($moreenv)) {
2659: %form=(%form,%{$moreenv});
2660: }
1.236 albertel 2661: if (defined($target)) { $form{'grade_target'} = $target; }
1.107 albertel 2662: $feedurl=&Apache::lonnet::clutter($feedurl);
1.186 albertel 2663: my $userview=&Apache::lonnet::ssi_body($feedurl,%form);
1.11 albertel 2664: $userview=~s/\<body[^\>]*\>//gi;
2665: $userview=~s/\<\/body\>//gi;
2666: $userview=~s/\<html\>//gi;
2667: $userview=~s/\<\/html\>//gi;
2668: $userview=~s/\<head\>//gi;
2669: $userview=~s/\<\/head\>//gi;
2670: $userview=~s/action\s*\=/would_be_action\=/gi;
1.107 albertel 2671: $userview=&relative_to_absolute($feedurl,$userview);
1.11 albertel 2672: return $userview;
2673: }
2674:
1.112 bowersj2 2675: =pod
2676:
2677: =item * get_student_answers()
2678:
2679: show a snapshot of how student was answering problem
2680:
2681: =cut
2682:
1.11 albertel 2683: sub get_student_answers {
1.100 sakharuk 2684: my ($symb,$username,$domain,$courseid,%form) = @_;
1.114 www 2685: my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb);
1.186 albertel 2686: my (%moreenv);
1.11 albertel 2687: my @elements=('symb','courseid','domain','username');
2688: foreach my $element (@elements) {
1.186 albertel 2689: $moreenv{'grade_'.$element}=eval '$'.$element #'
1.10 albertel 2690: }
1.186 albertel 2691: $moreenv{'grade_target'}='answer';
2692: %moreenv=(%form,%moreenv);
1.497 raeburn 2693: $feedurl = &Apache::lonnet::clutter($feedurl);
2694: my $userview=&Apache::lonnet::ssi($feedurl,%moreenv);
1.10 albertel 2695: return $userview;
1.1 albertel 2696: }
1.116 albertel 2697:
2698: =pod
2699:
2700: =item * &submlink()
2701:
1.242 albertel 2702: Inputs: $text $uname $udom $symb $target
1.116 albertel 2703:
2704: Returns: A link to grades.pm such as to see the SUBM view of a student
2705:
2706: =cut
2707:
2708: ###############################################
2709: sub submlink {
1.242 albertel 2710: my ($text,$uname,$udom,$symb,$target)=@_;
1.116 albertel 2711: if (!($uname && $udom)) {
2712: (my $cursymb, my $courseid,$udom,$uname)=
1.463 albertel 2713: &Apache::lonnet::whichuser($symb);
1.116 albertel 2714: if (!$symb) { $symb=$cursymb; }
2715: }
1.254 matthew 2716: if (!$symb) { $symb=&Apache::lonnet::symbread(); }
1.369 www 2717: $symb=&escape($symb);
1.242 albertel 2718: if ($target) { $target="target=\"$target\""; }
2719: return '<a href="/adm/grades?&command=submission&'.
2720: 'symb='.$symb.'&student='.$uname.
2721: '&userdom='.$udom.'" '.$target.'>'.$text.'</a>';
2722: }
2723: ##############################################
2724:
2725: =pod
2726:
2727: =item * &pgrdlink()
2728:
2729: Inputs: $text $uname $udom $symb $target
2730:
2731: Returns: A link to grades.pm such as to see the PGRD view of a student
2732:
2733: =cut
2734:
2735: ###############################################
2736: sub pgrdlink {
2737: my $link=&submlink(@_);
2738: $link=~s/(&command=submission)/$1&showgrading=yes/;
2739: return $link;
2740: }
2741: ##############################################
2742:
2743: =pod
2744:
2745: =item * &pprmlink()
2746:
2747: Inputs: $text $uname $udom $symb $target
2748:
2749: Returns: A link to parmset.pm such as to see the PPRM view of a
1.283 albertel 2750: student and a specific resource
1.242 albertel 2751:
2752: =cut
2753:
2754: ###############################################
2755: sub pprmlink {
2756: my ($text,$uname,$udom,$symb,$target)=@_;
2757: if (!($uname && $udom)) {
2758: (my $cursymb, my $courseid,$udom,$uname)=
1.463 albertel 2759: &Apache::lonnet::whichuser($symb);
1.242 albertel 2760: if (!$symb) { $symb=$cursymb; }
2761: }
1.254 matthew 2762: if (!$symb) { $symb=&Apache::lonnet::symbread(); }
1.369 www 2763: $symb=&escape($symb);
1.242 albertel 2764: if ($target) { $target="target=\"$target\""; }
2765: return '<a href="/adm/parmset?&command=set&'.
2766: 'symb='.$symb.'&uname='.$uname.
2767: '&udom='.$udom.'" '.$target.'>'.$text.'</a>';
1.116 albertel 2768: }
2769: ##############################################
1.37 matthew 2770:
1.112 bowersj2 2771: =pod
2772:
2773: =back
2774:
2775: =cut
2776:
1.37 matthew 2777: ###############################################
1.51 www 2778:
2779:
2780: sub timehash {
2781: my @ltime=localtime(shift);
2782: return ( 'seconds' => $ltime[0],
2783: 'minutes' => $ltime[1],
2784: 'hours' => $ltime[2],
2785: 'day' => $ltime[3],
2786: 'month' => $ltime[4]+1,
2787: 'year' => $ltime[5]+1900,
2788: 'weekday' => $ltime[6],
2789: 'dayyear' => $ltime[7]+1,
2790: 'dlsav' => $ltime[8] );
2791: }
2792:
1.370 www 2793: sub utc_string {
2794: my ($date)=@_;
1.371 www 2795: return strftime("%Y%m%dT%H%M%SZ",gmtime($date));
1.370 www 2796: }
2797:
1.51 www 2798: sub maketime {
2799: my %th=@_;
2800: return POSIX::mktime(
2801: ($th{'seconds'},$th{'minutes'},$th{'hours'},
1.210 www 2802: $th{'day'},$th{'month'}-1,$th{'year'}-1900,0,0,-1));
1.70 www 2803: }
2804:
2805: #########################################
1.51 www 2806:
2807: sub findallcourses {
1.482 raeburn 2808: my ($roles,$uname,$udom) = @_;
1.355 albertel 2809: my %roles;
2810: if (ref($roles)) { %roles = map { $_ => 1 } @{$roles}; }
1.348 albertel 2811: my %courses;
1.51 www 2812: my $now=time;
1.482 raeburn 2813: if (!defined($uname)) {
2814: $uname = $env{'user.name'};
2815: }
2816: if (!defined($udom)) {
2817: $udom = $env{'user.domain'};
2818: }
2819: if (($uname ne $env{'user.name'}) || ($udom ne $env{'user.domain'})) {
2820: my %roleshash = &Apache::lonnet::dump('roles',$udom,$uname);
2821: if (!%roles) {
2822: %roles = (
2823: cc => 1,
2824: in => 1,
2825: ep => 1,
2826: ta => 1,
2827: cr => 1,
2828: st => 1,
2829: );
2830: }
2831: foreach my $entry (keys(%roleshash)) {
2832: my ($trole,$tend,$tstart) = split(/_/,$roleshash{$entry});
2833: if ($trole =~ /^cr/) {
2834: next if (!exists($roles{$trole}) && !exists($roles{'cr'}));
2835: } else {
2836: next if (!exists($roles{$trole}));
2837: }
2838: if ($tend) {
2839: next if ($tend < $now);
2840: }
2841: if ($tstart) {
2842: next if ($tstart > $now);
2843: }
2844: my ($cdom,$cnum,$sec,$cnumpart,$secpart,$role,$realsec);
2845: (undef,$cdom,$cnumpart,$secpart) = split(/\//,$entry);
2846: if ($secpart eq '') {
2847: ($cnum,$role) = split(/_/,$cnumpart);
2848: $sec = 'none';
2849: $realsec = '';
2850: } else {
2851: $cnum = $cnumpart;
2852: ($sec,$role) = split(/_/,$secpart);
2853: $realsec = $sec;
1.490 raeburn 2854: }
1.482 raeburn 2855: $courses{$cdom.'_'.$cnum}{$sec} = $trole.'/'.$cdom.'/'.$cnum.'/'.$realsec;
2856: }
2857: } else {
2858: foreach my $key (keys(%env)) {
1.483 albertel 2859: if ( $key=~m{^user\.role\.(\w+)\./($match_domain)/($match_courseid)/?(\w*)$} ||
2860: $key=~m{^user\.role\.(cr/$match_domain/$match_username/\w+)\./($match_domain)/($match_courseid)/?(\w*)$}) {
1.482 raeburn 2861: my ($role,$cdom,$cnum,$sec) = ($1,$2,$3,$4);
2862: next if ($role eq 'ca' || $role eq 'aa');
2863: next if (%roles && !exists($roles{$role}));
2864: my ($starttime,$endtime)=split(/\./,$env{$key});
2865: my $active=1;
2866: if ($starttime) {
2867: if ($now<$starttime) { $active=0; }
2868: }
2869: if ($endtime) {
2870: if ($now>$endtime) { $active=0; }
2871: }
2872: if ($active) {
2873: if ($sec eq '') {
2874: $sec = 'none';
2875: }
2876: $courses{$cdom.'_'.$cnum}{$sec} =
2877: $role.'/'.$cdom.'/'.$cnum.'/'.$sec;
1.474 raeburn 2878: }
2879: }
1.51 www 2880: }
2881: }
1.474 raeburn 2882: return %courses;
1.51 www 2883: }
1.37 matthew 2884:
1.54 www 2885: ###############################################
1.474 raeburn 2886:
2887: sub blockcheck {
1.482 raeburn 2888: my ($setters,$activity,$uname,$udom) = @_;
1.490 raeburn 2889:
2890: if (!defined($udom)) {
2891: $udom = $env{'user.domain'};
2892: }
2893: if (!defined($uname)) {
2894: $uname = $env{'user.name'};
2895: }
2896:
2897: # If uname and udom are for a course, check for blocks in the course.
2898:
2899: if (&Apache::lonnet::is_course($udom,$uname)) {
2900: my %records = &Apache::lonnet::dump('comm_block',$udom,$uname);
1.502 raeburn 2901: my ($startblock,$endblock)=&get_blocks($setters,$activity,$udom,$uname);
1.490 raeburn 2902: return ($startblock,$endblock);
2903: }
1.474 raeburn 2904:
1.502 raeburn 2905: my $startblock = 0;
2906: my $endblock = 0;
1.482 raeburn 2907: my %live_courses = &findallcourses(undef,$uname,$udom);
1.474 raeburn 2908:
1.490 raeburn 2909: # If uname is for a user, and activity is course-specific, i.e.,
2910: # boards, chat or groups, check for blocking in current course only.
1.474 raeburn 2911:
1.490 raeburn 2912: if (($activity eq 'boards' || $activity eq 'chat' ||
2913: $activity eq 'groups') && ($env{'request.course.id'})) {
2914: foreach my $key (keys(%live_courses)) {
2915: if ($key ne $env{'request.course.id'}) {
2916: delete($live_courses{$key});
2917: }
2918: }
2919: }
2920:
2921: my $otheruser = 0;
2922: my %own_courses;
2923: if ((($uname ne $env{'user.name'})) || ($udom ne $env{'user.domain'})) {
2924: # Resource belongs to user other than current user.
2925: $otheruser = 1;
2926: # Gather courses for current user
2927: %own_courses =
2928: &findallcourses(undef,$env{'user.name'},$env{'user.domain'});
2929: }
2930:
2931: # Gather active course roles - course coordinator, instructor,
2932: # exam proctor, ta, student, or custom role.
1.474 raeburn 2933:
2934: foreach my $course (keys(%live_courses)) {
1.482 raeburn 2935: my ($cdom,$cnum);
2936: if ((defined($env{'course.'.$course.'.domain'})) && (defined($env{'course.'.$course.'.num'}))) {
2937: $cdom = $env{'course.'.$course.'.domain'};
2938: $cnum = $env{'course.'.$course.'.num'};
2939: } else {
1.490 raeburn 2940: ($cdom,$cnum) = split(/_/,$course);
1.482 raeburn 2941: }
2942: my $no_ownblock = 0;
2943: my $no_userblock = 0;
1.533 raeburn 2944: if ($otheruser && $activity ne 'com') {
1.490 raeburn 2945: # Check if current user has 'evb' priv for this
2946: if (defined($own_courses{$course})) {
2947: foreach my $sec (keys(%{$own_courses{$course}})) {
2948: my $checkrole = 'cm./'.$cdom.'/'.$cnum;
2949: if ($sec ne 'none') {
2950: $checkrole .= '/'.$sec;
2951: }
2952: if (&Apache::lonnet::allowed('evb',undef,undef,$checkrole)) {
2953: $no_ownblock = 1;
2954: last;
2955: }
2956: }
2957: }
2958: # if they have 'evb' priv and are currently not playing student
2959: next if (($no_ownblock) &&
2960: ($env{'request.role'} !~ m{^st\./$cdom/$cnum}));
2961: }
1.474 raeburn 2962: foreach my $sec (keys(%{$live_courses{$course}})) {
1.482 raeburn 2963: my $checkrole = 'cm./'.$cdom.'/'.$cnum;
1.474 raeburn 2964: if ($sec ne 'none') {
1.482 raeburn 2965: $checkrole .= '/'.$sec;
1.474 raeburn 2966: }
1.490 raeburn 2967: if ($otheruser) {
2968: # Resource belongs to user other than current user.
2969: # Assemble privs for that user, and check for 'evb' priv.
1.482 raeburn 2970: my ($trole,$tdom,$tnum,$tsec);
2971: my $entry = $live_courses{$course}{$sec};
2972: if ($entry =~ /^cr/) {
2973: ($trole,$tdom,$tnum,$tsec) =
2974: ($entry =~ m|^(cr/$match_domain/$match_username/\w+)\./($match_domain)/($match_username)/?(\w*)$|);
2975: } else {
2976: ($trole,$tdom,$tnum,$tsec) = split(/\//,$entry);
2977: }
2978: my ($spec,$area,$trest,%allroles,%userroles);
2979: $area = '/'.$tdom.'/'.$tnum;
2980: $trest = $tnum;
2981: if ($tsec ne '') {
2982: $area .= '/'.$tsec;
2983: $trest .= '/'.$tsec;
2984: }
2985: $spec = $trole.'.'.$area;
2986: if ($trole =~ /^cr/) {
2987: &Apache::lonnet::custom_roleprivs(\%allroles,$trole,
2988: $tdom,$spec,$trest,$area);
2989: } else {
2990: &Apache::lonnet::standard_roleprivs(\%allroles,$trole,
2991: $tdom,$spec,$trest,$area);
2992: }
2993: my ($author,$adv) = &Apache::lonnet::set_userprivs(\%userroles,\%allroles);
1.486 raeburn 2994: if ($userroles{'user.priv.'.$checkrole} =~ /evb\&([^\:]*)/) {
2995: if ($1) {
2996: $no_userblock = 1;
2997: last;
2998: }
2999: }
1.490 raeburn 3000: } else {
3001: # Resource belongs to current user
3002: # Check for 'evb' priv via lonnet::allowed().
1.482 raeburn 3003: if (&Apache::lonnet::allowed('evb',undef,undef,$checkrole)) {
3004: $no_ownblock = 1;
3005: last;
3006: }
1.474 raeburn 3007: }
3008: }
3009: # if they have the evb priv and are currently not playing student
1.482 raeburn 3010: next if (($no_ownblock) &&
1.491 albertel 3011: ($env{'request.role'} !~ m{^st\./\Q$cdom\E/\Q$cnum\E}));
1.482 raeburn 3012: next if ($no_userblock);
1.474 raeburn 3013:
1.490 raeburn 3014: # Retrieve blocking times and identity of blocker for course
3015: # of specified user, unless user has 'evb' privilege.
1.502 raeburn 3016:
3017: my ($start,$end)=&get_blocks($setters,$activity,$cdom,$cnum);
3018: if (($start != 0) &&
3019: (($startblock == 0) || ($startblock > $start))) {
3020: $startblock = $start;
3021: }
3022: if (($end != 0) &&
3023: (($endblock == 0) || ($endblock < $end))) {
3024: $endblock = $end;
3025: }
1.490 raeburn 3026: }
3027: return ($startblock,$endblock);
3028: }
3029:
3030: sub get_blocks {
3031: my ($setters,$activity,$cdom,$cnum) = @_;
3032: my $startblock = 0;
3033: my $endblock = 0;
3034: my $course = $cdom.'_'.$cnum;
3035: $setters->{$course} = {};
3036: $setters->{$course}{'staff'} = [];
3037: $setters->{$course}{'times'} = [];
3038: my %records = &Apache::lonnet::dump('comm_block',$cdom,$cnum);
3039: foreach my $record (keys(%records)) {
3040: my ($start,$end) = ($record =~ m/^(\d+)____(\d+)$/);
3041: if ($start <= time && $end >= time) {
3042: my ($staff_name,$staff_dom,$title,$blocks) =
3043: &parse_block_record($records{$record});
3044: if ($blocks->{$activity} eq 'on') {
3045: push(@{$$setters{$course}{'staff'}},[$staff_name,$staff_dom]);
3046: push(@{$$setters{$course}{'times'}}, [$start,$end]);
1.491 albertel 3047: if ( ($startblock == 0) || ($startblock > $start) ) {
3048: $startblock = $start;
1.490 raeburn 3049: }
1.491 albertel 3050: if ( ($endblock == 0) || ($endblock < $end) ) {
3051: $endblock = $end;
1.474 raeburn 3052: }
3053: }
3054: }
3055: }
3056: return ($startblock,$endblock);
3057: }
3058:
3059: sub parse_block_record {
3060: my ($record) = @_;
3061: my ($setuname,$setudom,$title,$blocks);
3062: if (ref($record) eq 'HASH') {
3063: ($setuname,$setudom) = split(/:/,$record->{'setter'});
3064: $title = &unescape($record->{'event'});
3065: $blocks = $record->{'blocks'};
3066: } else {
3067: my @data = split(/:/,$record,3);
3068: if (scalar(@data) eq 2) {
3069: $title = $data[1];
3070: ($setuname,$setudom) = split(/@/,$data[0]);
3071: } else {
3072: ($setuname,$setudom,$title) = @data;
3073: }
3074: $blocks = { 'com' => 'on' };
3075: }
3076: return ($setuname,$setudom,$title,$blocks);
3077: }
3078:
3079: sub build_block_table {
3080: my ($startblock,$endblock,$setters) = @_;
3081: my %lt = &Apache::lonlocal::texthash(
3082: 'cacb' => 'Currently active communication blocks',
3083: 'cour' => 'Course',
3084: 'dura' => 'Duration',
3085: 'blse' => 'Block set by'
3086: );
3087: my $output;
1.476 raeburn 3088: $output = '<br />'.$lt{'cacb'}.':<br />';
1.474 raeburn 3089: $output .= &start_data_table();
3090: $output .= '
3091: <tr>
3092: <th>'.$lt{'cour'}.'</th>
3093: <th>'.$lt{'dura'}.'</th>
3094: <th>'.$lt{'blse'}.'</th>
3095: </tr>
3096: ';
3097: foreach my $course (keys(%{$setters})) {
3098: my %courseinfo=&Apache::lonnet::coursedescription($course);
3099: for (my $i=0; $i<@{$$setters{$course}{staff}}; $i++) {
3100: my ($uname,$udom) = @{$$setters{$course}{staff}[$i]};
1.490 raeburn 3101: my $fullname = &plainname($uname,$udom);
3102: if (defined($env{'user.name'}) && defined($env{'user.domain'})
3103: && $env{'user.name'} ne 'public'
3104: && $env{'user.domain'} ne 'public') {
3105: $fullname = &aboutmewrapper($fullname,$uname,$udom);
3106: }
1.474 raeburn 3107: my ($openblock,$closeblock) = @{$$setters{$course}{times}[$i]};
3108: $openblock = &Apache::lonlocal::locallocaltime($openblock);
3109: $closeblock= &Apache::lonlocal::locallocaltime($closeblock);
3110: $output .= &Apache::loncommon::start_data_table_row().
3111: '<td>'.$courseinfo{'description'}.'</td>'.
3112: '<td>'.$openblock.' to '.$closeblock.'</td>'.
1.490 raeburn 3113: '<td>'.$fullname.'</td>'.
1.474 raeburn 3114: &Apache::loncommon::end_data_table_row();
3115: }
3116: }
3117: $output .= &end_data_table();
3118: }
3119:
1.490 raeburn 3120: sub blocking_status {
3121: my ($activity,$uname,$udom) = @_;
3122: my %setters;
3123: my ($blocked,$output,$ownitem,$is_course);
3124: my ($startblock,$endblock)=&blockcheck(\%setters,$activity,$uname,$udom);
3125: if ($startblock && $endblock) {
3126: $blocked = 1;
3127: if (wantarray) {
3128: my $category;
3129: if ($activity eq 'boards') {
3130: $category = 'Discussion posts in this course';
3131: } elsif ($activity eq 'blogs') {
3132: $category = 'Blogs';
3133: } elsif ($activity eq 'port') {
3134: if (defined($uname) && defined($udom)) {
3135: if ($uname eq $env{'user.name'} &&
3136: $udom eq $env{'user.domain'}) {
3137: $ownitem = 1;
3138: }
3139: }
3140: $is_course = &Apache::lonnet::is_course($udom,$uname);
3141: if ($ownitem) {
3142: $category = 'Your portfolio files';
3143: } elsif ($is_course) {
3144: my $coursedesc;
3145: foreach my $course (keys(%setters)) {
3146: my %courseinfo =
3147: &Apache::lonnet::coursedescription($course);
3148: $coursedesc = $courseinfo{'description'};
3149: }
3150: $category = "Group files in the course '$coursedesc'";
3151: } else {
3152: $category = 'Portfolio files belonging to ';
3153: if ($env{'user.name'} eq 'public' &&
3154: $env{'user.domain'} eq 'public') {
3155: $category .= &plainname($uname,$udom);
3156: } else {
3157: $category .= &aboutmewrapper(&plainname($uname,$udom),$uname,$udom);
3158: }
3159: }
3160: } elsif ($activity eq 'groups') {
3161: $category = 'Groups in this course';
3162: }
3163: my $showstart = &Apache::lonlocal::locallocaltime($startblock);
3164: my $showend = &Apache::lonlocal::locallocaltime($endblock);
3165: $output = '<br />'.&mt('[_1] will be inaccessible between [_2] and [_3] because communication is being blocked.',$category,$showstart,$showend).'<br />';
3166: if (!($activity eq 'port' && !($ownitem) && !($is_course))) {
3167: $output .= &build_block_table($startblock,$endblock,\%setters);
3168: }
3169: }
3170: }
3171: if (wantarray) {
3172: return ($blocked,$output);
3173: } else {
3174: return $blocked;
3175: }
3176: }
3177:
1.60 matthew 3178: ###############################################
3179:
3180: =pod
3181:
1.112 bowersj2 3182: =head1 Domain Template Functions
3183:
3184: =over 4
3185:
3186: =item * &determinedomain()
1.60 matthew 3187:
3188: Inputs: $domain (usually will be undef)
3189:
1.63 www 3190: Returns: Determines which domain should be used for designs
1.60 matthew 3191:
3192: =cut
1.54 www 3193:
1.60 matthew 3194: ###############################################
1.63 www 3195: sub determinedomain {
3196: my $domain=shift;
1.531 albertel 3197: if (! $domain) {
1.60 matthew 3198: # Determine domain if we have not been given one
3199: $domain = $Apache::lonnet::perlvar{'lonDefDomain'};
1.258 albertel 3200: if ($env{'user.domain'}) { $domain=$env{'user.domain'}; }
3201: if ($env{'request.role.domain'}) {
3202: $domain=$env{'request.role.domain'};
1.60 matthew 3203: }
3204: }
1.63 www 3205: return $domain;
3206: }
3207: ###############################################
1.517 raeburn 3208:
1.518 albertel 3209: sub devalidate_domconfig_cache {
3210: my ($udom)=@_;
3211: &Apache::lonnet::devalidate_cache_new('domainconfig',$udom);
3212: }
3213:
3214: # ---------------------- Get domain configuration for a domain
3215: sub get_domainconf {
3216: my ($udom) = @_;
3217: my $cachetime=1800;
3218: my ($result,$cached)=&Apache::lonnet::is_cached_new('domainconfig',$udom);
3219: if (defined($cached)) { return %{$result}; }
3220:
3221: my %domconfig = &Apache::lonnet::get_dom('configuration',
3222: ['login','rolecolors'],$udom);
3223: my %designhash;
3224: if (keys(%domconfig) > 0) {
3225: if (ref($domconfig{'login'}) eq 'HASH') {
3226: foreach my $key (keys(%{$domconfig{'login'}})) {
3227: $designhash{$udom.'.login.'.$key}=$domconfig{'login'}{$key};
3228: }
3229: }
3230: if (ref($domconfig{'rolecolors'}) eq 'HASH') {
3231: foreach my $role (keys(%{$domconfig{'rolecolors'}})) {
3232: if (ref($domconfig{'rolecolors'}{$role}) eq 'HASH') {
3233: foreach my $item (keys(%{$domconfig{'rolecolors'}{$role}})) {
3234: $designhash{$udom.'.'.$role.'.'.$item}=$domconfig{'rolecolors'}{$role}{$item};
3235: }
3236: }
3237: }
3238: }
3239: } else {
3240: my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors';
3241: my $designfile = $designdir.'/'.$udom.'.tab';
3242: if (-e $designfile) {
3243: if ( open (my $fh,"<$designfile") ) {
3244: while (my $line = <$fh>) {
3245: next if ($line =~ /^\#/);
3246: chomp($line);
3247: my ($key,$val)=(split(/\=/,$line));
3248: if ($val) { $designhash{$udom.'.'.$key}=$val; }
3249: }
3250: close($fh);
3251: }
3252: }
3253: if (-e '/home/httpd/html/adm/lonDomLogos/'.$udom.'.gif') {
1.519 raeburn 3254: $designhash{$udom.'.login.domlogo'} = "/adm/lonDomLogos/$udom.gif";
1.518 albertel 3255: }
3256: }
3257: &Apache::lonnet::do_cache_new('domainconfig',$udom,\%designhash,
3258: $cachetime);
3259: return %designhash;
3260: }
3261:
1.63 www 3262: =pod
3263:
1.112 bowersj2 3264: =item * &domainlogo()
1.63 www 3265:
3266: Inputs: $domain (usually will be undef)
3267:
3268: Returns: A link to a domain logo, if the domain logo exists.
3269: If the domain logo does not exist, a description of the domain.
3270:
3271: =cut
1.112 bowersj2 3272:
1.63 www 3273: ###############################################
3274: sub domainlogo {
1.517 raeburn 3275: my $domain = &determinedomain(shift);
1.518 albertel 3276: my %designhash = &get_domainconf($domain);
1.517 raeburn 3277: # See if there is a logo
3278: if ($designhash{$domain.'.login.domlogo'} ne '') {
1.519 raeburn 3279: my $imgsrc = $designhash{$domain.'.login.domlogo'};
1.538 albertel 3280: if ($imgsrc =~ m{^/(adm|res)/}) {
3281: if ($imgsrc =~ m{^/res/}) {
3282: my $local_name = &Apache::lonnet::filelocation('',$imgsrc);
3283: &Apache::lonnet::repcopy($local_name);
3284: }
3285: $imgsrc = &lonhttpdurl($imgsrc);
1.519 raeburn 3286: }
3287: return '<img src="'.$imgsrc.'" alt="'.$domain.'" />';
1.514 albertel 3288: } elsif (defined(&Apache::lonnet::domain($domain,'description'))) {
3289: return &Apache::lonnet::domain($domain,'description');
1.59 www 3290: } else {
1.60 matthew 3291: return '';
1.59 www 3292: }
3293: }
1.63 www 3294: ##############################################
3295:
3296: =pod
3297:
1.112 bowersj2 3298: =item * &designparm()
1.63 www 3299:
3300: Inputs: $which parameter; $domain (usually will be undef)
3301:
3302: Returns: value of designparamter $which
3303:
3304: =cut
1.112 bowersj2 3305:
1.397 albertel 3306:
1.400 albertel 3307: ##############################################
1.397 albertel 3308: sub designparm {
3309: my ($which,$domain)=@_;
1.258 albertel 3310: if ($env{'browser.blackwhite'} eq 'on') {
1.110 www 3311: if ($which=~/\.(font|alink|vlink|link)$/) {
3312: return '#000000';
3313: }
3314: if ($which=~/\.(pgbg|sidebg)$/) {
3315: return '#FFFFFF';
3316: }
3317: if ($which=~/\.tabbg$/) {
3318: return '#CCCCCC';
3319: }
3320: }
1.397 albertel 3321: if (exists($env{'environment.color.'.$which})) {
1.258 albertel 3322: return $env{'environment.color.'.$which};
1.96 www 3323: }
1.63 www 3324: $domain=&determinedomain($domain);
1.518 albertel 3325: my %domdesign = &get_domainconf($domain);
1.520 raeburn 3326: my $output;
1.517 raeburn 3327: if ($domdesign{$domain.'.'.$which} ne '') {
1.520 raeburn 3328: $output = $domdesign{$domain.'.'.$which};
1.63 www 3329: } else {
1.520 raeburn 3330: $output = $defaultdesign{$which};
3331: }
3332: if (($which =~ /^(student|coordinator|author|admin)\.img$/) ||
3333: ($which =~ /login\.(img|logo|domlogo)/)) {
1.538 albertel 3334: if ($output =~ m{^/(adm|res)/}) {
3335: if ($output =~ m{^/res/}) {
3336: my $local_name = &Apache::lonnet::filelocation('',$output);
3337: &Apache::lonnet::repcopy($local_name);
3338: }
1.520 raeburn 3339: $output = &lonhttpdurl($output);
3340: }
1.63 www 3341: }
1.520 raeburn 3342: return $output;
1.63 www 3343: }
1.59 www 3344:
1.60 matthew 3345: ###############################################
3346: ###############################################
3347:
3348: =pod
3349:
1.112 bowersj2 3350: =back
3351:
1.549 albertel 3352: =head1 HTML Helpers
1.112 bowersj2 3353:
3354: =over 4
3355:
3356: =item * &bodytag()
1.60 matthew 3357:
3358: Returns a uniform header for LON-CAPA web pages.
3359:
3360: Inputs:
3361:
1.112 bowersj2 3362: =over 4
3363:
3364: =item * $title, A title to be displayed on the page.
3365:
3366: =item * $function, the current role (can be undef).
3367:
3368: =item * $addentries, extra parameters for the <body> tag.
3369:
3370: =item * $bodyonly, if defined, only return the <body> tag.
3371:
3372: =item * $domain, if defined, force a given domain.
3373:
3374: =item * $forcereg, if page should register as content page (relevant for
1.86 www 3375: text interface only)
1.60 matthew 3376:
1.326 albertel 3377: =item * $customtitle, alternate text to use instead of $title
3378: in the title box that appears, this text
3379: is not auto translated like the $title is
1.309 albertel 3380:
3381: =item * $notopbar, if true, keep the 'what is this' info but remove the
3382: navigational links
1.317 albertel 3383:
1.338 albertel 3384: =item * $bgcolor, used to override the bgcolor on a webpage to a specific value
3385:
3386: =item * $notitle, if true keep the nav controls, but remove the title bar
3387:
1.361 albertel 3388: =item * $no_inline_link, if true and in remote mode, don't show the
3389: 'Switch To Inline Menu' link
3390:
1.460 albertel 3391: =item * $args, optional argument valid values are
3392: no_auto_mt_title -> prevents &mt()ing the title arg
3393:
1.112 bowersj2 3394: =back
3395:
1.60 matthew 3396: Returns: A uniform header for LON-CAPA web pages.
3397: If $bodyonly is nonzero, a string containing a <body> tag will be returned.
3398: If $bodyonly is undef or zero, an html string containing a <body> tag and
3399: other decorations will be returned.
3400:
3401: =cut
3402:
1.54 www 3403: sub bodytag {
1.309 albertel 3404: my ($title,$function,$addentries,$bodyonly,$domain,$forcereg,$customtitle,
1.460 albertel 3405: $notopbar,$bgcolor,$notitle,$no_inline_link,$args)=@_;
1.339 albertel 3406:
1.460 albertel 3407: if (!$args->{'no_auto_mt_title'}) { $title = &mt($title); }
1.339 albertel 3408:
1.183 matthew 3409: $function = &get_users_function() if (!$function);
1.339 albertel 3410: my $img = &designparm($function.'.img',$domain);
3411: my $font = &designparm($function.'.font',$domain);
3412: my $pgbg = $bgcolor || &designparm($function.'.pgbg',$domain);
3413:
3414: my %design = ( 'style' => 'margin-top: 0px',
1.535 albertel 3415: 'bgcolor' => $pgbg,
1.339 albertel 3416: 'text' => $font,
3417: 'alink' => &designparm($function.'.alink',$domain),
3418: 'vlink' => &designparm($function.'.vlink',$domain),
3419: 'link' => &designparm($function.'.link',$domain),);
1.438 albertel 3420: @design{keys(%$addentries)} = @$addentries{keys(%$addentries)};
1.339 albertel 3421:
1.63 www 3422: # role and realm
1.378 raeburn 3423: my ($role,$realm) = split(/\./,$env{'request.role'},2);
3424: if ($role eq 'ca') {
1.479 albertel 3425: my ($rdom,$rname) = ($realm =~ m{^/($match_domain)/($match_username)$});
1.500 albertel 3426: $realm = &plainname($rname,$rdom);
1.378 raeburn 3427: }
1.55 www 3428: # realm
1.258 albertel 3429: if ($env{'request.course.id'}) {
1.378 raeburn 3430: if ($env{'request.role'} !~ /^cr/) {
3431: $role = &Apache::lonnet::plaintext($role,&course_type());
3432: }
1.359 albertel 3433: $realm = $env{'course.'.$env{'request.course.id'}.'.description'};
1.378 raeburn 3434: } else {
3435: $role = &Apache::lonnet::plaintext($role);
1.54 www 3436: }
1.433 albertel 3437:
1.359 albertel 3438: if (!$realm) { $realm=' '; }
1.55 www 3439: # Set messages
1.60 matthew 3440: my $messages=&domainlogo($domain);
1.101 www 3441: # Port for miniserver
1.83 albertel 3442: my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'};
3443: if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; }
1.330 albertel 3444:
1.438 albertel 3445: my $extra_body_attr = &make_attr_string($forcereg,\%design);
1.329 albertel 3446:
1.101 www 3447: # construct main body tag
1.359 albertel 3448: my $bodytag = "<body $extra_body_attr>".
3449: &Apache::lontexconvert::init_math_support();
1.252 albertel 3450:
1.530 albertel 3451: if ($bodyonly) {
1.60 matthew 3452: return $bodytag;
1.258 albertel 3453: } elsif ($env{'browser.interface'} eq 'textual') {
1.95 www 3454: # Accessibility
1.224 raeburn 3455:
1.337 albertel 3456: $bodytag.=&Apache::lonmenu::menubuttons($forcereg,$forcereg);
1.338 albertel 3457: if (!$notitle) {
1.337 albertel 3458: $bodytag.='<h1>LON-CAPA: '.$title.'</h1>';
3459: }
3460: return $bodytag;
1.359 albertel 3461: }
3462:
1.410 albertel 3463: my $name = &plainname($env{'user.name'},$env{'user.domain'});
1.433 albertel 3464: if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
3465: undef($role);
1.434 albertel 3466: } else {
3467: $name = &aboutmewrapper($name,$env{'user.name'},$env{'user.domain'});
1.433 albertel 3468: }
1.359 albertel 3469:
3470: my $roleinfo=(<<ENDROLE);
3471: <td class="LC_title_bar_who">
3472: <div class="LC_title_bar_name">
1.410 albertel 3473: $name
1.361 albertel 3474:
1.359 albertel 3475: </div>
3476: <div class="LC_title_bar_role">
1.361 albertel 3477: $role
1.359 albertel 3478: </div>
3479: <div class="LC_title_bar_realm">
1.361 albertel 3480: $realm
1.359 albertel 3481: </div>
1.206 albertel 3482: </td>
3483: ENDROLE
1.235 raeburn 3484:
1.359 albertel 3485: my $titleinfo = '<span class="LC_title_bar_title">'.$title.'</span>';
3486: if ($customtitle) {
3487: $titleinfo = $customtitle;
3488: }
3489: #
3490: # Extra info if you are the DC
3491: my $dc_info = '';
3492: if ($env{'user.adv'} && exists($env{'user.role.dc./'.
3493: $env{'course.'.$env{'request.course.id'}.
3494: '.domain'}.'/'})) {
3495: my $cid = $env{'request.course.id'};
3496: $dc_info.= $cid.' '.$env{'course.'.$cid.'.internal.coursecode'};
1.380 www 3497: $dc_info =~ s/\s+$//;
1.359 albertel 3498: $dc_info = '('.$dc_info.')';
3499: }
3500:
3501: if ($env{'environment.remote'} eq 'off') {
3502: # No Remote
1.258 albertel 3503: if ($env{'request.state'} eq 'construct') {
1.359 albertel 3504: $forcereg=1;
3505: }
3506:
3507: if (!$customtitle && $env{'request.state'} eq 'construct') {
3508: # this is for resources; directories have customtitle, and crumbs
3509: # and select recent are created in lonpubdir.pm
1.229 albertel 3510: my ($uname,$thisdisfn)=
1.258 albertel 3511: ($env{'request.filename'} =~ m|^/home/([^/]+)/public_html/(.*)|);
1.229 albertel 3512: my $formaction='/priv/'.$uname.'/'.$thisdisfn;
3513: $formaction=~s/\/+/\//g;
3514:
1.359 albertel 3515: my $parentpath = '';
3516: my $lastitem = '';
3517: if ($thisdisfn =~ m-(.+/)([^/]*)$-) {
3518: $parentpath = $1;
3519: $lastitem = $2;
3520: } else {
3521: $lastitem = $thisdisfn;
3522: }
3523: $titleinfo =
1.401 albertel 3524: &Apache::loncommon::help_open_menu('','',3,'Authoring').
1.359 albertel 3525: '<b>Construction Space</b>: '.
3526: '<form name="dirs" method="post" action="'.$formaction
3527: .'" target="_top"><tt><b>'
3528: .&Apache::lonhtmlcommon::crumbs($uname.'/'.$parentpath,'_top','/priv','','+1',1)."<font size=\"+1\">$lastitem</font></b></tt><br />"
3529: .&Apache::lonhtmlcommon::select_recent('construct','recent','this.form.action=this.form.recent.value;this.form.submit()')
3530: .'</form>'
3531: .&Apache::lonmenu::constspaceform();
1.235 raeburn 3532: }
1.359 albertel 3533:
1.337 albertel 3534: my $titletable;
1.338 albertel 3535: if (!$notitle) {
1.337 albertel 3536: $titletable =
1.359 albertel 3537: '<table id="LC_title_bar">'.
3538: "<tr><td> $titleinfo $dc_info</td>".$roleinfo.
3539: '</tr></table>';
1.337 albertel 3540: }
1.359 albertel 3541: if ($notopbar) {
3542: $bodytag .= $titletable;
3543: } else {
3544: if ($env{'request.state'} eq 'construct') {
1.337 albertel 3545: $bodytag .= &Apache::lonmenu::menubuttons($forcereg,$forcereg,
3546: $titletable);
1.272 raeburn 3547: } else {
1.336 albertel 3548: $bodytag .= &Apache::lonmenu::menubuttons($forcereg,$forcereg).
1.359 albertel 3549: $titletable;
1.272 raeburn 3550: }
1.235 raeburn 3551: }
3552: return $bodytag;
1.94 www 3553: }
1.95 www 3554:
1.93 www 3555: #
1.95 www 3556: # Top frame rendering, Remote is up
1.93 www 3557: #
1.359 albertel 3558:
1.517 raeburn 3559: my $imgsrc = $img;
3560: if ($img =~ /^\/adm/) {
3561: $imgsrc = 'http://'.$ENV{'HTTP_HOST'}.':'.$lonhttpdPort.$img;
3562: }
3563: my $upperleft='<img src="'.$imgsrc.'" alt="'.$function.'" />';
1.359 albertel 3564:
1.305 www 3565: # Explicit link to get inline menu
1.361 albertel 3566: my $menu= ($no_inline_link?''
3567: :'<br /><a href="/adm/remote?action=collapse">'.&mt('Switch to Inline Menu Mode').'</a>');
1.245 matthew 3568: #
1.338 albertel 3569: if ($notitle) {
1.337 albertel 3570: return $bodytag;
3571: }
1.94 www 3572: return(<<ENDBODY);
1.60 matthew 3573: $bodytag
1.359 albertel 3574: <table id="LC_title_bar" class="LC_with_remote">
1.368 albertel 3575: <tr><td class="LC_title_bar_role_logo">$upperleft</td>
1.359 albertel 3576: <td class="LC_title_bar_domain_logo">$messages </td>
1.54 www 3577: </tr>
1.359 albertel 3578: <tr><td>$titleinfo $dc_info $menu</td>
3579: $roleinfo
1.368 albertel 3580: </tr>
1.356 albertel 3581: </table>
1.54 www 3582: ENDBODY
1.182 matthew 3583: }
3584:
1.330 albertel 3585: sub make_attr_string {
3586: my ($register,$attr_ref) = @_;
3587:
3588: if ($attr_ref && !ref($attr_ref)) {
3589: die("addentries Must be a hash ref ".
3590: join(':',caller(1))." ".
3591: join(':',caller(0))." ");
3592: }
3593:
3594: if ($register) {
1.339 albertel 3595: my ($on_load,$on_unload);
3596: foreach my $key (keys(%{$attr_ref})) {
3597: if (lc($key) eq 'onload') {
3598: $on_load.=$attr_ref->{$key}.';';
3599: delete($attr_ref->{$key});
3600:
3601: } elsif (lc($key) eq 'onunload') {
3602: $on_unload.=$attr_ref->{$key}.';';
3603: delete($attr_ref->{$key});
3604: }
3605: }
3606: $attr_ref->{'onload'} =
3607: &Apache::lonmenu::loadevents(). $on_load;
3608: $attr_ref->{'onunload'}=
3609: &Apache::lonmenu::unloadevents().$on_unload;
3610: }
3611:
3612: # Accessibility font enhance
3613: if ($env{'browser.fontenhance'} eq 'on') {
3614: my $style;
3615: foreach my $key (keys(%{$attr_ref})) {
3616: if (lc($key) eq 'style') {
3617: $style.=$attr_ref->{$key}.';';
3618: delete($attr_ref->{$key});
3619: }
3620: }
3621: $attr_ref->{'style'}=$style.'; font-size: x-large;';
1.330 albertel 3622: }
1.339 albertel 3623:
3624: if ($env{'browser.blackwhite'} eq 'on') {
3625: delete($attr_ref->{'font'});
3626: delete($attr_ref->{'link'});
3627: delete($attr_ref->{'alink'});
3628: delete($attr_ref->{'vlink'});
3629: delete($attr_ref->{'bgcolor'});
3630: delete($attr_ref->{'background'});
3631: }
3632:
1.330 albertel 3633: my $attr_string;
3634: foreach my $attr (keys(%$attr_ref)) {
3635: $attr_string .= " $attr=\"".$attr_ref->{$attr}.'" ';
3636: }
3637: return $attr_string;
3638: }
3639:
3640:
1.182 matthew 3641: ###############################################
1.251 albertel 3642: ###############################################
3643:
3644: =pod
3645:
3646: =item * &endbodytag()
3647:
3648: Returns a uniform footer for LON-CAPA web pages.
3649:
1.306 albertel 3650: Inputs: none
1.251 albertel 3651:
3652: =cut
3653:
3654: sub endbodytag {
3655: my $endbodytag='</body>';
1.269 albertel 3656: $endbodytag=&Apache::lontexconvert::jsMath_process()."\n".$endbodytag;
1.315 albertel 3657: if ( exists( $env{'internal.head.redirect'} ) ) {
3658: $endbodytag=
3659: "<br /><a href=\"$env{'internal.head.redirect'}\">".
3660: &mt('Continue').'</a>'.
3661: $endbodytag;
3662: }
1.251 albertel 3663: return $endbodytag;
3664: }
3665:
1.352 albertel 3666: =pod
3667:
3668: =item * &standard_css()
3669:
3670: Returns a style sheet
3671:
3672: Inputs: (all optional)
3673: domain -> force to color decorate a page for a specific
3674: domain
3675: function -> force usage of a specific rolish color scheme
3676: bgcolor -> override the default page bgcolor
3677:
3678: =cut
3679:
1.343 albertel 3680: sub standard_css {
1.345 albertel 3681: my ($function,$domain,$bgcolor) = @_;
1.352 albertel 3682: $function = &get_users_function() if (!$function);
3683: my $img = &designparm($function.'.img', $domain);
3684: my $tabbg = &designparm($function.'.tabbg', $domain);
3685: my $font = &designparm($function.'.font', $domain);
1.345 albertel 3686: my $sidebg = &designparm($function.'.sidebg',$domain);
1.382 albertel 3687: my $pgbg_or_bgcolor =
3688: $bgcolor ||
1.352 albertel 3689: &designparm($function.'.pgbg', $domain);
1.382 albertel 3690: my $pgbg = &designparm($function.'.pgbg', $domain);
1.352 albertel 3691: my $alink = &designparm($function.'.alink', $domain);
3692: my $vlink = &designparm($function.'.vlink', $domain);
3693: my $link = &designparm($function.'.link', $domain);
3694:
3695: my $sans = 'Arial,Helvetica,sans-serif';
1.395 albertel 3696: my $mono = 'monospace';
1.352 albertel 3697: my $data_table_head = $tabbg;
3698: my $data_table_light = '#EEEEEE';
1.470 banghart 3699: my $data_table_dark = '#DDDDDD';
3700: my $data_table_darker = '#CCCCCC';
1.349 albertel 3701: my $data_table_highlight = '#FFFF00';
1.352 albertel 3702: my $mail_new = '#FFBB77';
3703: my $mail_new_hover = '#DD9955';
3704: my $mail_read = '#BBBB77';
3705: my $mail_read_hover = '#999944';
3706: my $mail_replied = '#AAAA88';
3707: my $mail_replied_hover = '#888855';
3708: my $mail_other = '#99BBBB';
3709: my $mail_other_hover = '#669999';
1.391 albertel 3710: my $table_header = '#DDDDDD';
1.489 raeburn 3711: my $feedback_link_bg = '#BBBBBB';
1.392 albertel 3712:
3713: my $border = ($env{'browser.type'} eq 'explorer') ? '0px 2px 0px 2px'
3714: : '0px 3px 0px 4px';
1.448 albertel 3715:
1.523 albertel 3716:
1.343 albertel 3717: return <<END;
1.345 albertel 3718: h1, h2, h3, th { font-family: $sans }
1.343 albertel 3719: a:focus { color: red; background: yellow }
1.510 albertel 3720: table.thinborder,
1.523 albertel 3721:
1.510 albertel 3722: table.thinborder tr th {
3723: border-style: solid;
3724: border-width: 1px;
3725: background: $tabbg;
3726: }
1.523 albertel 3727: table.thinborder tr td {
1.510 albertel 3728: border-style: solid;
3729: border-width: 1px
3730: }
1.426 albertel 3731:
1.343 albertel 3732: form, .inline { display: inline; }
3733: .center { text-align: center; }
1.395 albertel 3734: .LC_filename {font-family: $mono;}
1.350 albertel 3735: .LC_error {
3736: color: red;
3737: font-size: larger;
3738: }
1.457 albertel 3739: .LC_warning,
3740: .LC_diff_removed {
1.394 albertel 3741: color: red;
3742: }
1.532 albertel 3743:
3744: .LC_info,
1.457 albertel 3745: .LC_success,
3746: .LC_diff_added {
1.350 albertel 3747: color: green;
3748: }
1.543 albertel 3749: .LC_unknown {
3750: color: yellow;
3751: }
3752:
1.440 albertel 3753: .LC_icon {
3754: border: 0px;
3755: }
1.539 albertel 3756: .LC_indexer_icon {
3757: border: 0px;
3758: height: 22px;
3759: }
1.543 albertel 3760: .LC_docs_spacer {
3761: width: 25px;
3762: height: 1px;
3763: border: 0px;
3764: }
1.346 albertel 3765:
1.532 albertel 3766: .LC_internal_info {
3767: color: #999;
3768: }
3769:
1.458 albertel 3770: table.LC_pastsubmission {
3771: border: 1px solid black;
3772: margin: 2px;
3773: }
3774:
1.392 albertel 3775: table#LC_top_nav, table#LC_menubuttons {
1.345 albertel 3776: width: 100%;
3777: background: $pgbg;
1.392 albertel 3778: border: 2px;
1.402 albertel 3779: border-collapse: separate;
1.403 albertel 3780: padding: 0px;
1.345 albertel 3781: }
1.392 albertel 3782:
1.409 albertel 3783: table#LC_title_bar, table.LC_breadcrumbs, table#LC_nav_location,
1.393 albertel 3784: table#LC_title_bar.LC_with_remote {
1.359 albertel 3785: width: 100%;
1.392 albertel 3786: border-color: $pgbg;
3787: border-style: solid;
3788: border-width: $border;
3789:
1.379 albertel 3790: background: $pgbg;
3791: font-family: $sans;
1.392 albertel 3792: border-collapse: collapse;
1.403 albertel 3793: padding: 0px;
1.359 albertel 3794: }
1.392 albertel 3795:
1.409 albertel 3796: table.LC_docs_path {
3797: width: 100%;
3798: border: 0;
3799: background: $pgbg;
3800: font-family: $sans;
3801: border-collapse: collapse;
3802: padding: 0px;
3803: }
3804:
1.359 albertel 3805: table#LC_title_bar td {
3806: background: $tabbg;
3807: }
3808: table#LC_title_bar td.LC_title_bar_who {
3809: background: $tabbg;
3810: color: $font;
1.427 albertel 3811: font: small $sans;
1.359 albertel 3812: text-align: right;
3813: }
1.469 banghart 3814: span.LC_metadata {
3815: font-family: $sans;
3816: }
1.359 albertel 3817: span.LC_title_bar_title {
1.416 albertel 3818: font: bold x-large $sans;
1.359 albertel 3819: }
3820: table#LC_title_bar td.LC_title_bar_domain_logo {
3821: background: $sidebg;
3822: text-align: right;
1.368 albertel 3823: padding: 0px;
3824: }
3825: table#LC_title_bar td.LC_title_bar_role_logo {
3826: background: $sidebg;
3827: padding: 0px;
1.359 albertel 3828: }
3829:
1.346 albertel 3830: table#LC_menubuttons_mainmenu {
1.526 www 3831: width: 100%;
1.346 albertel 3832: border: 0px;
3833: border-spacing: 1px;
1.372 albertel 3834: padding: 0px 1px;
1.346 albertel 3835: margin: 0px;
3836: border-collapse: separate;
3837: }
3838: table#LC_menubuttons img, table#LC_menubuttons_mainmenu img {
3839: border: 0px;
3840: }
1.345 albertel 3841: table#LC_top_nav td {
3842: background: $tabbg;
1.392 albertel 3843: border: 0px;
1.407 albertel 3844: font-size: small;
1.345 albertel 3845: }
3846: table#LC_top_nav td a, div#LC_top_nav a {
3847: color: $font;
3848: font-family: $sans;
3849: }
1.364 albertel 3850: table#LC_top_nav td.LC_top_nav_logo {
3851: background: $tabbg;
1.432 albertel 3852: text-align: left;
1.408 albertel 3853: white-space: nowrap;
1.432 albertel 3854: width: 31px;
1.408 albertel 3855: }
3856: table#LC_top_nav td.LC_top_nav_logo img {
1.432 albertel 3857: border: 0px;
1.408 albertel 3858: vertical-align: bottom;
1.364 albertel 3859: }
1.432 albertel 3860: table#LC_top_nav td.LC_top_nav_exit,
3861: table#LC_top_nav td.LC_top_nav_help {
3862: width: 2.0em;
3863: }
1.442 albertel 3864: table#LC_top_nav td.LC_top_nav_login {
3865: width: 4.0em;
3866: text-align: center;
3867: }
1.409 albertel 3868: table.LC_breadcrumbs td, table.LC_docs_path td {
1.357 albertel 3869: background: $tabbg;
3870: color: $font;
3871: font-family: $sans;
1.358 albertel 3872: font-size: smaller;
1.357 albertel 3873: }
1.411 albertel 3874: table.LC_breadcrumbs td.LC_breadcrumbs_component,
1.409 albertel 3875: table.LC_docs_path td.LC_docs_path_component {
1.357 albertel 3876: background: $tabbg;
3877: color: $font;
3878: font-family: $sans;
3879: font-size: larger;
3880: text-align: right;
3881: }
1.383 albertel 3882: td.LC_table_cell_checkbox {
3883: text-align: center;
3884: }
3885:
1.522 albertel 3886: table#LC_mainmenu td.LC_mainmenu_column {
3887: vertical-align: top;
3888: }
3889:
1.346 albertel 3890: .LC_menubuttons_inline_text {
3891: color: $font;
3892: font-family: $sans;
3893: font-size: smaller;
3894: }
3895:
1.526 www 3896: .LC_menubuttons_link {
3897: text-decoration: none;
3898: }
3899:
1.522 albertel 3900: .LC_menubuttons_category {
1.521 www 3901: color: $font;
1.526 www 3902: background: $pgbg;
1.521 www 3903: font-family: $sans;
3904: font-size: larger;
3905: font-weight: bold;
3906: }
3907:
1.346 albertel 3908: td.LC_menubuttons_text {
1.526 www 3909: width: 90%;
1.346 albertel 3910: color: $font;
3911: font-family: $sans;
3912: }
1.526 www 3913:
1.346 albertel 3914: td.LC_menubuttons_img {
3915: }
1.526 www 3916:
1.346 albertel 3917: .LC_current_location {
3918: font-family: $sans;
3919: background: $tabbg;
3920: }
3921: .LC_new_mail {
3922: font-family: $sans;
3923: font-weight: bold;
3924: }
1.347 albertel 3925:
1.526 www 3926: .LC_rolesmenu_is {
3927: font-family: $sans;
3928: }
3929:
3930: .LC_rolesmenu_selected {
3931: font-family: $sans;
3932: }
3933:
3934: .LC_rolesmenu_future {
3935: font-family: $sans;
3936: }
3937:
3938:
3939: .LC_rolesmenu_will {
3940: font-family: $sans;
3941: }
3942:
3943: .LC_rolesmenu_will_not {
3944: font-family: $sans;
3945: }
3946:
3947: .LC_rolesmenu_expired {
3948: font-family: $sans;
3949: }
3950:
3951: .LC_rolesinfo {
3952: font-family: $sans;
3953: }
3954:
1.527 www 3955: .LC_dropadd_labeltext {
3956: font-family: $sans;
3957: text-align: right;
3958: }
3959:
3960: .LC_preferences_labeltext {
3961: font-family: $sans;
3962: text-align: right;
3963: }
3964:
1.440 albertel 3965: table.LC_aboutme_port {
3966: border: 0px;
3967: border-collapse: collapse;
3968: border-spacing: 0px;
3969: }
1.349 albertel 3970: table.LC_data_table, table.LC_mail_list {
1.347 albertel 3971: border: 1px solid #000000;
1.402 albertel 3972: border-collapse: separate;
1.426 albertel 3973: border-spacing: 1px;
1.347 albertel 3974: }
1.422 albertel 3975: .LC_data_table_dense {
3976: font-size: small;
3977: }
1.507 raeburn 3978: table.LC_nested_outer {
3979: border: 1px solid #000000;
3980: border-collapse: separate;
3981: border-spacing: 0px;
3982: width: 100%;
3983: }
3984: table.LC_nested {
3985: border: 0px;
3986: border-collapse: separate;
3987: border-spacing: 0px;
3988: width: 100%;
3989: }
1.523 albertel 3990: table.LC_data_table tr th, table.LC_calendar tr th, table.LC_mail_list tr th,
3991: table.LC_prior_tries tr th {
1.349 albertel 3992: font-weight: bold;
3993: background-color: $data_table_head;
1.421 albertel 3994: font-size: smaller;
1.347 albertel 3995: }
1.440 albertel 3996: table.LC_data_table tr td,
3997: table.LC_aboutme_port tr td {
1.349 albertel 3998: background-color: $data_table_light;
1.425 albertel 3999: padding: 2px;
1.347 albertel 4000: }
1.440 albertel 4001: table.LC_data_table tr.LC_even_row td,
4002: table.LC_aboutme_port tr.LC_even_row td {
1.349 albertel 4003: background-color: $data_table_dark;
1.347 albertel 4004: }
1.425 albertel 4005: table.LC_data_table tr.LC_data_table_highlight td {
4006: background-color: $data_table_darker;
4007: }
1.451 albertel 4008: table.LC_data_table tr.LC_empty_row td,
1.507 raeburn 4009: table.LC_nested tr.LC_empty_row td {
1.347 albertel 4010: background-color: #FFFFFF;
1.421 albertel 4011: font-weight: bold;
4012: font-style: italic;
4013: text-align: center;
4014: padding: 8px;
1.347 albertel 4015: }
1.507 raeburn 4016: table.LC_nested tr.LC_empty_row td {
1.465 albertel 4017: padding: 4ex
4018: }
1.507 raeburn 4019: table.LC_nested_outer tr th {
4020: font-weight: bold;
4021: background-color: $data_table_head;
4022: font-size: smaller;
4023: border-bottom: 1px solid #000000;
4024: }
4025: table.LC_nested_outer tr td.LC_subheader {
4026: background-color: $data_table_head;
4027: font-weight: bold;
4028: font-size: small;
4029: border-bottom: 1px solid #000000;
4030: text-align: right;
1.451 albertel 4031: }
1.507 raeburn 4032: table.LC_nested tr.LC_info_row td {
1.451 albertel 4033: background-color: #CCC;
4034: font-weight: bold;
4035: font-size: small;
1.507 raeburn 4036: text-align: center;
4037: }
4038: table.LC_nested tr.LC_info_row td.LC_left_item {
4039: text-align: left;
1.451 albertel 4040: }
1.507 raeburn 4041: table.LC_nested td {
1.451 albertel 4042: background-color: #FFF;
4043: font-size: small;
1.507 raeburn 4044: }
4045: table.LC_nested_outer tr th.LC_right_item,
4046: table.LC_nested tr.LC_info_row td.LC_right_item,
4047: table.LC_nested tr.LC_odd_row td.LC_right_item,
4048: table.LC_nested tr td.LC_right_item {
1.451 albertel 4049: text-align: right;
4050: }
4051:
1.507 raeburn 4052: table.LC_nested tr.LC_odd_row td {
1.451 albertel 4053: background-color: #EEE;
4054: }
4055:
1.473 raeburn 4056: table.LC_createuser {
4057: }
4058:
4059: table.LC_createuser tr.LC_section_row td {
4060: font-size: smaller;
4061: }
4062:
4063: table.LC_createuser tr.LC_info_row td {
4064: background-color: #CCC;
4065: font-weight: bold;
4066: text-align: center;
4067: }
4068:
1.349 albertel 4069: table.LC_calendar {
4070: border: 1px solid #000000;
4071: border-collapse: collapse;
4072: }
4073: table.LC_calendar_pickdate {
4074: font-size: xx-small;
4075: }
4076: table.LC_calendar tr td {
4077: border: 1px solid #000000;
4078: vertical-align: top;
4079: }
4080: table.LC_calendar tr td.LC_calendar_day_empty {
4081: background-color: $data_table_dark;
4082: }
4083: table.LC_calendar tr td.LC_calendar_day_current {
4084: background-color: $data_table_highlight;
4085: }
4086:
4087: table.LC_mail_list tr.LC_mail_new {
4088: background-color: $mail_new;
4089: }
4090: table.LC_mail_list tr.LC_mail_new:hover {
4091: background-color: $mail_new_hover;
4092: }
4093: table.LC_mail_list tr.LC_mail_read {
4094: background-color: $mail_read;
4095: }
4096: table.LC_mail_list tr.LC_mail_read:hover {
4097: background-color: $mail_read_hover;
4098: }
4099: table.LC_mail_list tr.LC_mail_replied {
4100: background-color: $mail_replied;
4101: }
4102: table.LC_mail_list tr.LC_mail_replied:hover {
4103: background-color: $mail_replied_hover;
4104: }
4105: table.LC_mail_list tr.LC_mail_other {
4106: background-color: $mail_other;
4107: }
4108: table.LC_mail_list tr.LC_mail_other:hover {
4109: background-color: $mail_other_hover;
4110: }
1.494 raeburn 4111: table.LC_mail_list tr.LC_mail_even {
4112: }
4113: table.LC_mail_list tr.LC_mail_odd {
4114: }
4115:
1.385 albertel 4116:
1.386 albertel 4117: table#LC_portfolio_actions {
4118: width: auto;
4119: background: $pgbg;
4120: border: 0px;
4121: border-spacing: 2px 2px;
4122: padding: 0px;
4123: margin: 0px;
4124: border-collapse: separate;
4125: }
4126: table#LC_portfolio_actions td.LC_label {
4127: background: $tabbg;
4128: text-align: right;
4129: }
4130: table#LC_portfolio_actions td.LC_value {
4131: background: $tabbg;
4132: }
1.385 albertel 4133:
1.391 albertel 4134: table#LC_cstr_controls {
4135: width: 100%;
4136: border-collapse: collapse;
4137: }
4138: table#LC_cstr_controls tr td {
4139: border: 4px solid $pgbg;
4140: padding: 4px;
4141: text-align: center;
4142: background: $tabbg;
4143: }
4144: table#LC_cstr_controls tr th {
4145: border: 4px solid $pgbg;
4146: background: $table_header;
4147: text-align: center;
4148: font-family: $sans;
4149: font-size: smaller;
4150: }
4151:
1.389 albertel 4152: table#LC_browser {
4153:
4154: }
4155: table#LC_browser tr th {
1.391 albertel 4156: background: $table_header;
1.389 albertel 4157: }
1.390 albertel 4158: table#LC_browser tr td {
4159: padding: 2px;
4160: }
1.389 albertel 4161: table#LC_browser tr.LC_browser_file,
4162: table#LC_browser tr.LC_browser_file_published {
4163: background: #CCFF88;
4164: }
4165: table#LC_browser tr.LC_browser_file_locked,
4166: table#LC_browser tr.LC_browser_file_unpublished {
4167: background: #FFAA99;
1.387 albertel 4168: }
1.389 albertel 4169: table#LC_browser tr.LC_browser_file_obsolete {
4170: background: #AAAAAA;
1.387 albertel 4171: }
1.455 albertel 4172: table#LC_browser tr.LC_browser_file_modified,
4173: table#LC_browser tr.LC_browser_file_metamodified {
1.389 albertel 4174: background: #FFFF77;
1.387 albertel 4175: }
1.389 albertel 4176: table#LC_browser tr.LC_browser_folder {
4177: background: #CCCCFF;
1.387 albertel 4178: }
1.388 albertel 4179: span.LC_current_location {
4180: font-size: x-large;
4181: background: $pgbg;
4182: }
1.387 albertel 4183:
1.395 albertel 4184: span.LC_parm_menu_item {
4185: font-size: larger;
4186: font-family: $sans;
4187: }
4188: span.LC_parm_scope_all {
4189: color: red;
4190: }
4191: span.LC_parm_scope_folder {
4192: color: green;
4193: }
4194: span.LC_parm_scope_resource {
4195: color: orange;
4196: }
4197: span.LC_parm_part {
4198: color: blue;
4199: }
4200: span.LC_parm_folder, span.LC_parm_symb {
4201: font-size: x-small;
4202: font-family: $mono;
4203: color: #AAAAAA;
4204: }
4205:
1.396 albertel 4206: td.LC_parm_overview_level_menu, td.LC_parm_overview_map_menu,
4207: td.LC_parm_overview_parm_selectors, td.LC_parm_overview_parm_restrictions {
4208: border: 1px solid black;
4209: border-collapse: collapse;
4210: }
4211: table.LC_parm_overview_restrictions td {
4212: border-width: 1px 4px 1px 4px;
4213: border-style: solid;
4214: border-color: $pgbg;
4215: text-align: center;
4216: }
4217: table.LC_parm_overview_restrictions th {
4218: background: $tabbg;
4219: border-width: 1px 4px 1px 4px;
4220: border-style: solid;
4221: border-color: $pgbg;
4222: }
1.398 albertel 4223: table#LC_helpmenu {
4224: border: 0px;
4225: height: 55px;
4226: border-spacing: 0px;
4227: }
4228:
4229: table#LC_helpmenu fieldset legend {
4230: font-size: larger;
4231: font-weight: bold;
4232: }
1.397 albertel 4233: table#LC_helpmenu_links {
4234: width: 100%;
4235: border: 1px solid black;
4236: background: $pgbg;
4237: padding: 0px;
4238: border-spacing: 1px;
4239: }
4240: table#LC_helpmenu_links tr td {
4241: padding: 1px;
4242: background: $tabbg;
1.399 albertel 4243: text-align: center;
4244: font-weight: bold;
1.397 albertel 4245: }
1.396 albertel 4246:
1.397 albertel 4247: table#LC_helpmenu_links a:link, table#LC_helpmenu_links a:visited,
4248: table#LC_helpmenu_links a:active {
4249: text-decoration: none;
4250: color: $font;
4251: }
4252: table#LC_helpmenu_links a:hover {
4253: text-decoration: underline;
4254: color: $vlink;
4255: }
1.396 albertel 4256:
1.417 albertel 4257: .LC_chrt_popup_exists {
4258: border: 1px solid #339933;
4259: margin: -1px;
4260: }
4261: .LC_chrt_popup_up {
4262: border: 1px solid yellow;
4263: margin: -1px;
4264: }
4265: .LC_chrt_popup {
4266: border: 1px solid #8888FF;
4267: background: #CCCCFF;
4268: }
4269:
1.421 albertel 4270: table.LC_pick_box {
4271: width: 100%;
4272: border-collapse: separate;
4273: background: white;
4274: border: 1px solid black;
4275: border-spacing: 1px;
4276: }
4277: table.LC_pick_box td.LC_pick_box_title {
4278: background: $tabbg;
4279: font-weight: bold;
4280: text-align: right;
4281: width: 184px;
4282: padding: 8px;
4283: }
1.424 albertel 4284: table.LC_pick_box td.LC_pick_box_separator {
1.421 albertel 4285: padding: 0px;
4286: height: 1px;
4287: background: black;
4288: }
4289: table.LC_pick_box td.LC_pick_box_submit {
4290: text-align: right;
4291: }
4292:
1.424 albertel 4293: table.LC_group_priv_box {
4294: background: white;
4295: border: 1px solid black;
4296: border-spacing: 1px;
4297: }
4298: table.LC_group_priv_box td.LC_pick_box_title {
4299: background: $tabbg;
4300: font-weight: bold;
4301: text-align: right;
4302: width: 184px;
4303: }
4304: table.LC_group_priv_box td.LC_groups_fixed {
4305: background: $data_table_light;
4306: text-align: center;
4307: }
4308: table.LC_group_priv_box td.LC_groups_optional {
4309: background: $data_table_dark;
4310: text-align: center;
4311: }
4312: table.LC_group_priv_box td.LC_groups_functionality {
4313: background: $data_table_darker;
4314: text-align: center;
4315: font-weight: bold;
4316: }
4317: table.LC_group_priv td {
4318: text-align: left;
4319: padding: 0px;
4320: }
4321:
1.421 albertel 4322: table.LC_notify_front_page {
4323: background: white;
4324: border: 1px solid black;
4325: padding: 8px;
4326: }
4327: table.LC_notify_front_page td {
4328: padding: 8px;
4329: }
1.424 albertel 4330: .LC_navbuttons {
4331: margin: 2ex 0ex 2ex 0ex;
4332: }
1.423 albertel 4333: .LC_topic_bar {
4334: font-family: $sans;
4335: font-weight: bold;
4336: width: 100%;
4337: background: $tabbg;
4338: vertical-align: middle;
4339: margin: 2ex 0ex 2ex 0ex;
4340: }
4341: .LC_topic_bar span {
4342: vertical-align: middle;
4343: }
4344: .LC_topic_bar img {
4345: vertical-align: bottom;
4346: }
4347: table.LC_course_group_status {
4348: margin: 20px;
4349: }
4350: table.LC_status_selector td {
4351: vertical-align: top;
4352: text-align: center;
1.424 albertel 4353: padding: 4px;
4354: }
4355: table.LC_descriptive_input td.LC_description {
4356: vertical-align: top;
4357: text-align: right;
4358: font-weight: bold;
1.423 albertel 4359: }
1.489 raeburn 4360: table.LC_feedback_link {
4361: background: $feedback_link_bg;
4362: }
4363: span.LC_feedback_link {
4364: background: $feedback_link_bg;
4365: font-size: larger;
4366: }
1.421 albertel 4367:
1.515 albertel 4368: table.LC_prior_tries {
1.524 albertel 4369: border: 1px solid #000000;
4370: border-collapse: separate;
4371: border-spacing: 1px;
1.515 albertel 4372: }
1.523 albertel 4373:
1.515 albertel 4374: table.LC_prior_tries td {
1.524 albertel 4375: padding: 2px;
1.515 albertel 4376: }
1.523 albertel 4377:
4378: .LC_answer_correct {
4379: background: #AAFFAA;
4380: color: black;
4381: }
4382: .LC_answer_charged_try {
4383: background: #FFAAAA ! important;
4384: color: black;
4385: }
4386: .LC_answer_not_charged_try,
4387: .LC_answer_no_grade,
4388: .LC_answer_late {
4389: background: #FFFFAA;
4390: color: black;
4391: }
4392: .LC_answer_previous {
4393: background: #AAAAFF;
4394: color: black;
4395: }
4396: .LC_answer_no_message {
4397: background: #FFFFFF;
4398: color: black;
4399: }
4400: .LC_answer_unknown {
4401: background: orange;
4402: color: black;
4403: }
4404:
4405:
1.529 albertel 4406: span.LC_prior_numerical,
4407: span.LC_prior_string,
4408: span.LC_prior_custom,
4409: span.LC_prior_reaction,
4410: span.LC_prior_math {
1.523 albertel 4411: font-family: monospace;
4412: white-space: pre;
4413: }
4414:
1.525 albertel 4415: span.LC_prior_string {
4416: font-family: monospace;
4417: white-space: pre;
4418: }
4419:
1.523 albertel 4420: table.LC_prior_option {
4421: width: 100%;
4422: border-collapse: collapse;
4423: }
1.528 albertel 4424: table.LC_prior_rank, table.LC_prior_match {
4425: border-collapse: collapse;
4426: }
4427: table.LC_prior_option tr td,
4428: table.LC_prior_rank tr td,
4429: table.LC_prior_match tr td {
1.524 albertel 4430: border: 1px solid #000000;
1.515 albertel 4431: }
4432:
1.519 raeburn 4433: span.LC_nobreak {
1.544 albertel 4434: white-space: nowrap;
1.519 raeburn 4435: }
4436:
1.545 albertel 4437: table.LC_docs_documents {
4438: background: #BBBBBB;
1.547 albertel 4439: border-width: 0px;
1.545 albertel 4440: border-collapse: collapse;
4441: }
4442:
4443: table.LC_docs_documents td.LC_docs_document {
4444: border: 2px solid black;
4445: padding: 4px;
4446: }
4447:
4448: .LC_docs_course_commands div {
4449: float: left;
4450: border: 4px solid #AAAAAA;
4451: padding: 4px;
4452: background: #DDDDCC;
4453: }
4454:
4455: .LC_docs_entry_move {
4456: border: 0px;
4457: border-collapse: collapse;
1.544 albertel 4458: }
4459:
1.545 albertel 4460: .LC_docs_entry_move td {
4461: border: 2px solid #BBBBBB;
4462: background: #DDDDDD;
4463: }
4464:
4465: .LC_docs_editor td.LC_docs_entry_commands {
4466: background: #DDDDDD;
4467: font-size: x-small;
4468: }
1.544 albertel 4469: .LC_docs_copy {
1.545 albertel 4470: color: #000099;
1.544 albertel 4471: }
4472: .LC_docs_cut {
1.545 albertel 4473: color: #550044;
1.544 albertel 4474: }
4475: .LC_docs_rename {
1.545 albertel 4476: color: #009900;
1.544 albertel 4477: }
4478: .LC_docs_remove {
1.545 albertel 4479: color: #990000;
4480: }
4481:
1.547 albertel 4482: .LC_docs_reinit_warn,
4483: .LC_docs_ext_edit {
4484: font-size: x-small;
4485: }
4486:
1.545 albertel 4487: .LC_docs_editor td.LC_docs_entry_title,
4488: .LC_docs_editor td.LC_docs_entry_icon {
4489: background: #FFFFBB;
4490: }
4491: .LC_docs_editor td.LC_docs_entry_parameter {
4492: background: #BBBBFF;
4493: font-size: x-small;
4494: white-space: nowrap;
4495: }
4496:
4497: table.LC_docs_adddocs td,
4498: table.LC_docs_adddocs th {
4499: border: 1px solid #BBBBBB;
4500: padding: 4px;
4501: background: #DDDDDD;
1.543 albertel 4502: }
4503:
1.343 albertel 4504: END
4505: }
4506:
1.306 albertel 4507: =pod
4508:
4509: =item * &headtag()
4510:
4511: Returns a uniform footer for LON-CAPA web pages.
4512:
1.307 albertel 4513: Inputs: $title - optional title for the head
4514: $head_extra - optional extra HTML to put inside the <head>
1.315 albertel 4515: $args - optional arguments
1.319 albertel 4516: force_register - if is true call registerurl so the remote is
4517: informed
1.415 albertel 4518: redirect -> array ref of
4519: 1- seconds before redirect occurs
4520: 2- url to redirect to
4521: 3- whether the side effect should occur
1.315 albertel 4522: (side effect of setting
4523: $env{'internal.head.redirect'} to the url
4524: redirected too)
1.352 albertel 4525: domain -> force to color decorate a page for a specific
4526: domain
4527: function -> force usage of a specific rolish color scheme
4528: bgcolor -> override the default page bgcolor
1.460 albertel 4529: no_auto_mt_title
4530: -> prevent &mt()ing the title arg
1.464 albertel 4531:
1.306 albertel 4532: =cut
4533:
4534: sub headtag {
1.313 albertel 4535: my ($title,$head_extra,$args) = @_;
1.306 albertel 4536:
1.363 albertel 4537: my $function = $args->{'function'} || &get_users_function();
4538: my $domain = $args->{'domain'} || &determinedomain();
4539: my $bgcolor = $args->{'bgcolor'} || &designparm($function.'.pgbg',$domain);
1.418 albertel 4540: my $url = join(':',$env{'user.name'},$env{'user.domain'},
1.458 albertel 4541: $Apache::lonnet::perlvar{'lonVersion'},
1.531 albertel 4542: #time(),
1.418 albertel 4543: $env{'environment.color.timestamp'},
1.363 albertel 4544: $function,$domain,$bgcolor);
4545:
1.369 www 4546: $url = '/adm/css/'.&escape($url).'.css';
1.363 albertel 4547:
1.308 albertel 4548: my $result =
4549: '<head>'.
1.461 albertel 4550: &font_settings();
1.319 albertel 4551:
1.461 albertel 4552: if (!$args->{'frameset'}) {
4553: $result .= &Apache::lonhtmlcommon::htmlareaheaders();
4554: }
1.319 albertel 4555: if ($args->{'force_register'}) {
4556: $result .= &Apache::lonmenu::registerurl(1);
4557: }
1.436 albertel 4558: if (!$args->{'no_nav_bar'}
4559: && !$args->{'only_body'}
4560: && !$args->{'frameset'}) {
4561: $result .= &help_menu_js();
4562: }
1.319 albertel 4563:
1.314 albertel 4564: if (ref($args->{'redirect'})) {
1.414 albertel 4565: my ($time,$url,$inhibit_continue) = @{$args->{'redirect'}};
1.315 albertel 4566: $url = &Apache::lonenc::check_encrypt($url);
1.414 albertel 4567: if (!$inhibit_continue) {
4568: $env{'internal.head.redirect'} = $url;
4569: }
1.313 albertel 4570: $result.=<<ADDMETA
4571: <meta http-equiv="pragma" content="no-cache" />
1.344 albertel 4572: <meta http-equiv="Refresh" content="$time; url=$url" />
1.313 albertel 4573: ADDMETA
4574: }
1.306 albertel 4575: if (!defined($title)) {
4576: $title = 'The LearningOnline Network with CAPA';
4577: }
1.460 albertel 4578: if (!$args->{'no_auto_mt_title'}) { $title = &mt($title); }
4579: $result .= '<title> LON-CAPA '.$title.'</title>'
1.414 albertel 4580: .'<link rel="stylesheet" type="text/css" href="'.$url.'" />'
4581: .$head_extra;
1.306 albertel 4582: return $result;
4583: }
4584:
4585: =pod
4586:
1.340 albertel 4587: =item * &font_settings()
4588:
4589: Returns neccessary <meta> to set the proper encoding
4590:
4591: Inputs: none
4592:
4593: =cut
4594:
4595: sub font_settings {
4596: my $headerstring='';
4597: if (($env{'browser.os'} eq 'mac') && (!$env{'browser.mathml'})) {
4598: $headerstring.=
4599: '<meta Content-Type="text/html; charset=x-mac-roman" />';
4600: } elsif (!$env{'browser.mathml'} && $env{'browser.unicode'}) {
4601: $headerstring.=
4602: '<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />';
4603: }
4604: return $headerstring;
4605: }
4606:
1.341 albertel 4607: =pod
4608:
4609: =item * &xml_begin()
4610:
4611: Returns the needed doctype and <html>
4612:
4613: Inputs: none
4614:
4615: =cut
4616:
4617: sub xml_begin {
4618: my $output='';
4619:
1.342 albertel 4620: &Apache::lonhtmlcommon::init_htmlareafields();
4621:
1.341 albertel 4622: if ($env{'browser.mathml'}) {
4623: $output='<?xml version="1.0"?>'
4624: #.'<?xml-stylesheet type="text/css" href="/adm/MathML/mathml.css"?>'."\n"
4625: # .'<!DOCTYPE html SYSTEM "/adm/MathML/mathml.dtd" '
4626:
4627: # .'<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd" [<!ENTITY mathns "http://www.w3.org/1998/Math/MathML">] >'
4628: .'<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1 plus MathML 2.0 plus SVG 1.1//EN" "http://www.w3.org/2002/04/xhtml-math-svg/xhtml-math-svg.dtd">'
4629: .'<html xmlns:math="http://www.w3.org/1998/Math/MathML" '
4630: .'xmlns="http://www.w3.org/1999/xhtml">';
4631: } else {
4632: $output='<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"><html>';
4633: }
4634: return $output;
4635: }
1.340 albertel 4636:
4637: =pod
4638:
1.306 albertel 4639: =item * &endheadtag()
4640:
4641: Returns a uniform </head> for LON-CAPA web pages.
4642:
4643: Inputs: none
4644:
4645: =cut
4646:
4647: sub endheadtag {
4648: return '</head>';
4649: }
4650:
4651: =pod
4652:
4653: =item * &head()
4654:
4655: Returns a uniform complete <head>..</head> section for LON-CAPA web pages.
4656:
4657: Inputs: $title - optional title for the page
1.307 albertel 4658: $head_extra - optional extra HTML to put inside the <head>
1.405 albertel 4659:
1.306 albertel 4660: =cut
4661:
4662: sub head {
1.325 albertel 4663: my ($title,$head_extra,$args) = @_;
4664: return &headtag($title,$head_extra,$args).&endheadtag();
1.306 albertel 4665: }
4666:
4667: =pod
4668:
4669: =item * &start_page()
4670:
4671: Returns a complete <html> .. <body> section for LON-CAPA web pages.
4672:
4673: Inputs: $title - optional title for the page
4674: $head_extra - optional extra HTML to incude inside the <head>
1.315 albertel 4675: $args - additional optional args supported are:
1.317 albertel 4676: only_body -> is true will set &bodytag() onlybodytag
4677: arg on
4678: no_nav_bar -> is true will set &bodytag() notopbar arg on
4679: add_entries -> additional attributes to add to the <body>
4680: domain -> force to color decorate a page for a
4681: specific domain
4682: function -> force usage of a specific rolish color
4683: scheme
4684: redirect -> see &headtag()
4685: bgcolor -> override the default page bg color
4686: js_ready -> return a string ready for being used in
4687: a javascript writeln
1.320 albertel 4688: html_encode -> return a string ready for being used in
4689: a html attribute
1.317 albertel 4690: force_register -> if is true will turn on the &bodytag()
4691: $forcereg arg
1.326 albertel 4692: body_title -> alternate text to use instead of $title
4693: in the title box that appears, this text
4694: is not auto translated like the $title is
1.330 albertel 4695: frameset -> if true will start with a <frameset>
4696: rather than <body>
1.338 albertel 4697: no_title -> if true the title bar won't be shown
4698: skip_phases -> hash ref of
4699: head -> skip the <html><head> generation
4700: body -> skip all <body> generation
1.337 albertel 4701:
1.361 albertel 4702: no_inline_link -> if true and in remote mode, don't show the
4703: 'Switch To Inline Menu' link
4704:
1.460 albertel 4705: no_auto_mt_title -> prevent &mt()ing the title arg
4706:
1.306 albertel 4707: =cut
4708:
4709: sub start_page {
1.309 albertel 4710: my ($title,$head_extra,$args) = @_;
1.318 albertel 4711: #&Apache::lonnet::logthis("start_page ".join(':',caller(0)));
1.313 albertel 4712: my %head_args;
1.352 albertel 4713: foreach my $arg ('redirect','force_register','domain','function',
1.460 albertel 4714: 'bgcolor','frameset','no_nav_bar','only_body',
4715: 'no_auto_mt_title') {
1.319 albertel 4716: if (defined($args->{$arg})) {
1.324 raeburn 4717: $head_args{$arg} = $args->{$arg};
1.319 albertel 4718: }
1.313 albertel 4719: }
1.319 albertel 4720:
1.315 albertel 4721: $env{'internal.start_page'}++;
1.338 albertel 4722: my $result;
4723: if (! exists($args->{'skip_phases'}{'head'}) ) {
4724: $result.=
1.341 albertel 4725: &xml_begin().
1.338 albertel 4726: &headtag($title,$head_extra,\%head_args).&endheadtag();
4727: }
4728:
4729: if (! exists($args->{'skip_phases'}{'body'}) ) {
4730: if ($args->{'frameset'}) {
4731: my $attr_string = &make_attr_string($args->{'force_register'},
4732: $args->{'add_entries'});
4733: $result .= "\n<frameset $attr_string>\n";
4734: } else {
4735: $result .=
4736: &bodytag($title,
4737: $args->{'function'}, $args->{'add_entries'},
4738: $args->{'only_body'}, $args->{'domain'},
4739: $args->{'force_register'}, $args->{'body_title'},
4740: $args->{'no_nav_bar'}, $args->{'bgcolor'},
1.460 albertel 4741: $args->{'no_title'}, $args->{'no_inline_link'},
4742: $args);
1.338 albertel 4743: }
1.330 albertel 4744: }
1.338 albertel 4745:
1.315 albertel 4746: if ($args->{'js_ready'}) {
1.317 albertel 4747: $result = &js_ready($result);
1.315 albertel 4748: }
1.320 albertel 4749: if ($args->{'html_encode'}) {
4750: $result = &html_encode($result);
4751: }
1.315 albertel 4752: return $result;
1.306 albertel 4753: }
4754:
1.330 albertel 4755:
1.306 albertel 4756: =pod
4757:
4758: =item * &head()
4759:
4760: Returns a complete </body></html> section for LON-CAPA web pages.
4761:
1.315 albertel 4762: Inputs: $args - additional optional args supported are:
4763: js_ready -> return a string ready for being used in
4764: a javascript writeln
1.320 albertel 4765: html_encode -> return a string ready for being used in
4766: a html attribute
1.330 albertel 4767: frameset -> if true will start with a <frameset>
4768: rather than <body>
1.493 albertel 4769: dicsussion -> if true will get discussion from
4770: lonxml::xmlend
4771: (you can pass the target and parser arguments
4772: through optional 'target' and 'parser' args
4773: to this routine)
1.306 albertel 4774:
4775: =cut
4776:
4777: sub end_page {
1.315 albertel 4778: my ($args) = @_;
4779: $env{'internal.end_page'}++;
1.330 albertel 4780: my $result;
1.335 albertel 4781: if ($args->{'discussion'}) {
4782: my ($target,$parser);
4783: if (ref($args->{'discussion'})) {
4784: ($target,$parser) =($args->{'discussion'}{'target'},
4785: $args->{'discussion'}{'parser'});
4786: }
4787: $result .= &Apache::lonxml::xmlend($target,$parser);
4788: }
4789:
1.330 albertel 4790: if ($args->{'frameset'}) {
4791: $result .= '</frameset>';
4792: } else {
4793: $result .= &endbodytag();
4794: }
4795: $result .= "\n</html>";
4796:
1.315 albertel 4797: if ($args->{'js_ready'}) {
1.317 albertel 4798: $result = &js_ready($result);
1.315 albertel 4799: }
1.335 albertel 4800:
1.320 albertel 4801: if ($args->{'html_encode'}) {
4802: $result = &html_encode($result);
4803: }
1.335 albertel 4804:
1.315 albertel 4805: return $result;
4806: }
4807:
1.320 albertel 4808: sub html_encode {
4809: my ($result) = @_;
4810:
1.322 albertel 4811: $result = &HTML::Entities::encode($result,'<>&"');
1.320 albertel 4812:
4813: return $result;
4814: }
1.317 albertel 4815: sub js_ready {
4816: my ($result) = @_;
4817:
1.323 albertel 4818: $result =~ s/[\n\r]/ /xmsg;
4819: $result =~ s/\\/\\\\/xmsg;
4820: $result =~ s/'/\\'/xmsg;
1.372 albertel 4821: $result =~ s{</}{<\\/}xmsg;
1.317 albertel 4822:
4823: return $result;
4824: }
4825:
1.315 albertel 4826: sub validate_page {
4827: if ( exists($env{'internal.start_page'})
1.316 albertel 4828: && $env{'internal.start_page'} > 1) {
4829: &Apache::lonnet::logthis('start_page called multiple times '.
1.318 albertel 4830: $env{'internal.start_page'}.' '.
1.316 albertel 4831: $ENV{'request.filename'});
1.315 albertel 4832: }
4833: if ( exists($env{'internal.end_page'})
1.316 albertel 4834: && $env{'internal.end_page'} > 1) {
4835: &Apache::lonnet::logthis('end_page called multiple times '.
1.318 albertel 4836: $env{'internal.end_page'}.' '.
1.316 albertel 4837: $env{'request.filename'});
1.315 albertel 4838: }
4839: if ( exists($env{'internal.start_page'})
4840: && ! exists($env{'internal.end_page'})) {
1.316 albertel 4841: &Apache::lonnet::logthis('start_page called without end_page '.
4842: $env{'request.filename'});
1.315 albertel 4843: }
4844: if ( ! exists($env{'internal.start_page'})
4845: && exists($env{'internal.end_page'})) {
1.316 albertel 4846: &Apache::lonnet::logthis('end_page called without start_page'.
4847: $env{'request.filename'});
1.315 albertel 4848: }
1.306 albertel 4849: }
1.315 albertel 4850:
1.318 albertel 4851: sub simple_error_page {
4852: my ($r,$title,$msg) = @_;
4853: my $page =
4854: &Apache::loncommon::start_page($title).
4855: &mt($msg).
4856: &Apache::loncommon::end_page();
4857: if (ref($r)) {
4858: $r->print($page);
1.327 albertel 4859: return;
1.318 albertel 4860: }
4861: return $page;
4862: }
1.347 albertel 4863:
4864: {
4865: my $row_count;
4866: sub start_data_table {
1.422 albertel 4867: my ($add_class) = @_;
4868: my $css_class = (join(' ','LC_data_table',$add_class));
1.347 albertel 4869: undef($row_count);
1.422 albertel 4870: return '<table class="'.$css_class.'">'."\n";
1.347 albertel 4871: }
4872:
4873: sub end_data_table {
4874: undef($row_count);
1.389 albertel 4875: return '</table>'."\n";;
1.347 albertel 4876: }
4877:
4878: sub start_data_table_row {
1.422 albertel 4879: my ($add_class) = @_;
1.347 albertel 4880: $row_count++;
1.422 albertel 4881: my $css_class = ($row_count % 2)?'':'LC_even_row';
1.428 albertel 4882: $css_class = (join(' ',$css_class,$add_class));
1.422 albertel 4883: return '<tr class="'.$css_class.'">'."\n";;
1.347 albertel 4884: }
1.471 banghart 4885:
4886: sub continue_data_table_row {
4887: my ($add_class) = @_;
4888: my $css_class = ($row_count % 2)?'':'LC_even_row';
4889: $css_class = (join(' ',$css_class,$add_class));
4890: return '<tr class="'.$css_class.'">'."\n";;
4891: }
1.347 albertel 4892:
4893: sub end_data_table_row {
1.389 albertel 4894: return '</tr>'."\n";;
1.347 albertel 4895: }
1.367 www 4896:
1.421 albertel 4897: sub start_data_table_empty_row {
4898: $row_count++;
4899: return '<tr class="LC_empty_row" >'."\n";;
4900: }
4901:
4902: sub end_data_table_empty_row {
4903: return '</tr>'."\n";;
4904: }
4905:
1.367 www 4906: sub start_data_table_header_row {
1.389 albertel 4907: return '<tr class="LC_header_row">'."\n";;
1.367 www 4908: }
4909:
4910: sub end_data_table_header_row {
1.389 albertel 4911: return '</tr>'."\n";;
1.367 www 4912: }
1.347 albertel 4913: }
4914:
1.548 albertel 4915: =pod
4916:
4917: =item * &inhibit_menu_check($arg)
4918:
4919: Checks for a inhibitmenu state and generates output to preserve it
4920:
4921: Inputs: $arg - can be any of
4922: - undef - in which case the return value is a string
4923: to add into arguments list of a uri
4924: - 'input' - in which case the return value is a HTML
4925: <form> <input> field of type hidden to
4926: preserve the value
4927: - a url - in which case the return value is the url with
4928: the neccesary cgi args added to preserve the
4929: inhibitmenu state
4930: - a ref to a url - no return value, but the string is
4931: updated to include the neccessary cgi
4932: args to preserve the inhibitmenu state
4933:
4934: =cut
4935:
4936: sub inhibit_menu_check {
4937: my ($arg) = @_;
4938: &get_unprocessed_cgi($ENV{'QUERY_STRING'}, ['inhibitmenu']);
4939: if ($arg eq 'input') {
4940: if ($env{'form.inhibitmenu'}) {
4941: return '<input type="hidden" name="inhibitmenu" value="'.$env{'form.inhibitmenu'}.'" />';
4942: } else {
4943: return
4944: }
4945: }
4946: if ($env{'form.inhibitmenu'}) {
4947: if (ref($arg)) {
4948: $$arg .= '?inhibitmenu='.$env{'form.inhibitmenu'};
4949: } elsif ($arg eq '') {
4950: $arg .= 'inhibitmenu='.$env{'form.inhibitmenu'};
4951: } else {
4952: $arg .= '?inhibitmenu='.$env{'form.inhibitmenu'};
4953: }
4954: }
4955: if (!ref($arg)) {
4956: return $arg;
4957: }
4958: }
4959:
1.251 albertel 4960: ###############################################
1.182 matthew 4961:
4962: =pod
4963:
1.549 albertel 4964: =back
4965:
4966: =head1 User Information Routines
4967:
4968: =over 4
4969:
1.405 albertel 4970: =item * &get_users_function()
1.182 matthew 4971:
4972: Used by &bodytag to determine the current users primary role.
4973: Returns either 'student','coordinator','admin', or 'author'.
4974:
4975: =cut
4976:
4977: ###############################################
4978: sub get_users_function {
4979: my $function = 'student';
1.258 albertel 4980: if ($env{'request.role'}=~/^(cc|in|ta|ep)/) {
1.182 matthew 4981: $function='coordinator';
4982: }
1.258 albertel 4983: if ($env{'request.role'}=~/^(su|dc|ad|li)/) {
1.182 matthew 4984: $function='admin';
4985: }
1.258 albertel 4986: if (($env{'request.role'}=~/^(au|ca)/) ||
1.182 matthew 4987: ($ENV{'REQUEST_URI'}=~/^(\/priv|\~)/)) {
4988: $function='author';
4989: }
4990: return $function;
1.54 www 4991: }
1.99 www 4992:
4993: ###############################################
4994:
1.233 raeburn 4995: =pod
4996:
1.542 raeburn 4997: =item * &check_user_status()
1.274 raeburn 4998:
4999: Determines current status of supplied role for a
5000: specific user. Roles can be active, previous or future.
5001:
5002: Inputs:
5003: user's domain, user's username, course's domain,
1.375 raeburn 5004: course's number, optional section ID.
1.274 raeburn 5005:
5006: Outputs:
5007: role status: active, previous or future.
5008:
5009: =cut
5010:
5011: sub check_user_status {
1.412 raeburn 5012: my ($udom,$uname,$cdom,$crs,$role,$sec) = @_;
1.274 raeburn 5013: my %userinfo = &Apache::lonnet::dump('roles',$udom,$uname);
5014: my @uroles = keys %userinfo;
5015: my $srchstr;
5016: my $active_chk = 'none';
1.412 raeburn 5017: my $now = time;
1.274 raeburn 5018: if (@uroles > 0) {
1.412 raeburn 5019: if (($role eq 'cc') || ($sec eq '') || (!defined($sec))) {
1.274 raeburn 5020: $srchstr = '/'.$cdom.'/'.$crs.'_'.$role;
5021: } else {
1.412 raeburn 5022: $srchstr = '/'.$cdom.'/'.$crs.'/'.$sec.'_'.$role;
5023: }
5024: if (grep/^\Q$srchstr\E$/,@uroles) {
1.274 raeburn 5025: my $role_end = 0;
5026: my $role_start = 0;
5027: $active_chk = 'active';
1.412 raeburn 5028: if ($userinfo{$srchstr} =~ m/^\Q$role\E_(\d+)/) {
5029: $role_end = $1;
5030: if ($userinfo{$srchstr} =~ m/^\Q$role\E_\Q$role_end\E_(\d+)$/) {
5031: $role_start = $1;
1.274 raeburn 5032: }
5033: }
5034: if ($role_start > 0) {
1.412 raeburn 5035: if ($now < $role_start) {
1.274 raeburn 5036: $active_chk = 'future';
5037: }
5038: }
5039: if ($role_end > 0) {
1.412 raeburn 5040: if ($now > $role_end) {
1.274 raeburn 5041: $active_chk = 'previous';
5042: }
5043: }
5044: }
5045: }
5046: return $active_chk;
5047: }
5048:
5049: ###############################################
5050:
5051: =pod
5052:
1.405 albertel 5053: =item * &get_sections()
1.233 raeburn 5054:
5055: Determines all the sections for a course including
5056: sections with students and sections containing other roles.
1.419 raeburn 5057: Incoming parameters:
5058:
5059: 1. domain
5060: 2. course number
5061: 3. reference to array containing roles for which sections should
5062: be gathered (optional).
5063: 4. reference to array containing status types for which sections
5064: should be gathered (optional).
5065:
5066: If the third argument is undefined, sections are gathered for any role.
5067: If the fourth argument is undefined, sections are gathered for any status.
5068: Permissible values are 'active' or 'future' or 'previous'.
1.233 raeburn 5069:
1.374 raeburn 5070: Returns section hash (keys are section IDs, values are
5071: number of users in each section), subject to the
1.419 raeburn 5072: optional roles filter, optional status filter
1.233 raeburn 5073:
5074: =cut
5075:
5076: ###############################################
5077: sub get_sections {
1.419 raeburn 5078: my ($cdom,$cnum,$possible_roles,$possible_status) = @_;
1.366 albertel 5079: if (!defined($cdom) || !defined($cnum)) {
5080: my $cid = $env{'request.course.id'};
5081:
5082: return if (!defined($cid));
5083:
5084: $cdom = $env{'course.'.$cid.'.domain'};
5085: $cnum = $env{'course.'.$cid.'.num'};
5086: }
5087:
5088: my %sectioncount;
1.419 raeburn 5089: my $now = time;
1.240 albertel 5090:
1.366 albertel 5091: if (!defined($possible_roles) || (grep(/^st$/,@$possible_roles))) {
1.276 albertel 5092: my ($classlist) = &Apache::loncoursedata::get_classlist($cdom,$cnum);
1.240 albertel 5093: my $sec_index = &Apache::loncoursedata::CL_SECTION();
5094: my $status_index = &Apache::loncoursedata::CL_STATUS();
1.419 raeburn 5095: my $start_index = &Apache::loncoursedata::CL_START();
5096: my $end_index = &Apache::loncoursedata::CL_END();
5097: my $status;
1.366 albertel 5098: while (my ($student,$data) = each(%$classlist)) {
1.419 raeburn 5099: my ($section,$stu_status,$start,$end) = ($data->[$sec_index],
5100: $data->[$status_index],
5101: $data->[$start_index],
5102: $data->[$end_index]);
5103: if ($stu_status eq 'Active') {
5104: $status = 'active';
5105: } elsif ($end < $now) {
5106: $status = 'previous';
5107: } elsif ($start > $now) {
5108: $status = 'future';
5109: }
5110: if ($section ne '-1' && $section !~ /^\s*$/) {
5111: if ((!defined($possible_status)) || (($status ne '') &&
5112: (grep/^\Q$status\E$/,@{$possible_status}))) {
5113: $sectioncount{$section}++;
5114: }
1.240 albertel 5115: }
5116: }
5117: }
5118: my %courseroles = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum);
5119: foreach my $user (sort(keys(%courseroles))) {
5120: if ($user !~ /^(\w{2})/) { next; }
5121: my ($role) = ($user =~ /^(\w{2})/);
5122: if ($possible_roles && !(grep(/^$role$/,@$possible_roles))) { next; }
1.419 raeburn 5123: my ($section,$status);
1.240 albertel 5124: if ($role eq 'cr' &&
5125: $user =~ m-^$role/[^/]*/[^/]*/[^/]*:[^:]*:[^:]*:(\w+)-) {
5126: $section=$1;
5127: }
5128: if ($user =~ /^$role:[^:]*:[^:]*:(\w+)/) { $section=$1; }
5129: if (!defined($section) || $section eq '-1') { next; }
1.419 raeburn 5130: my ($end,$start) = ($courseroles{$user} =~ /^([^:]*):([^:]*)$/);
5131: if ($end == -1 && $start == -1) {
5132: next; #deleted role
5133: }
5134: if (!defined($possible_status)) {
5135: $sectioncount{$section}++;
5136: } else {
5137: if ((!$end || $end >= $now) && (!$start || $start <= $now)) {
5138: $status = 'active';
5139: } elsif ($end < $now) {
5140: $status = 'future';
5141: } elsif ($start > $now) {
5142: $status = 'previous';
5143: }
5144: if (($status ne '') && (grep/^\Q$status\E$/,@{$possible_status})) {
5145: $sectioncount{$section}++;
5146: }
5147: }
1.233 raeburn 5148: }
1.366 albertel 5149: return %sectioncount;
1.233 raeburn 5150: }
5151:
1.274 raeburn 5152: ###############################################
1.294 raeburn 5153:
5154: =pod
1.405 albertel 5155:
5156: =item * &get_course_users()
5157:
1.275 raeburn 5158: Retrieves usernames:domains for users in the specified course
5159: with specific role(s), and access status.
5160:
5161: Incoming parameters:
1.277 albertel 5162: 1. course domain
5163: 2. course number
5164: 3. access status: users must have - either active,
1.275 raeburn 5165: previous, future, or all.
1.277 albertel 5166: 4. reference to array of permissible roles
1.288 raeburn 5167: 5. reference to array of section restrictions (optional)
5168: 6. reference to results object (hash of hashes).
5169: 7. reference to optional userdata hash
1.275 raeburn 5170: Keys of top level hash are roles.
5171: Keys of inner hashes are username:domain, with
5172: values set to access type.
1.288 raeburn 5173: Optional userdata hash returns an array with arguments in the
5174: same order as loncoursedata::get_classlist() for student data.
5175:
5176: Entries for end, start, section and status are blank because
5177: of the possibility of multiple values for non-student roles.
5178:
1.275 raeburn 5179: =cut
1.405 albertel 5180:
1.275 raeburn 5181: ###############################################
1.405 albertel 5182:
1.275 raeburn 5183: sub get_course_users {
1.288 raeburn 5184: my ($cdom,$cnum,$types,$roles,$sections,$users,$userdata) = @_;
5185: my %idx = ();
1.419 raeburn 5186: my %seclists;
1.288 raeburn 5187:
5188: $idx{udom} = &Apache::loncoursedata::CL_SDOM();
5189: $idx{uname} = &Apache::loncoursedata::CL_SNAME();
5190: $idx{end} = &Apache::loncoursedata::CL_END();
5191: $idx{start} = &Apache::loncoursedata::CL_START();
5192: $idx{id} = &Apache::loncoursedata::CL_ID();
5193: $idx{section} = &Apache::loncoursedata::CL_SECTION();
5194: $idx{fullname} = &Apache::loncoursedata::CL_FULLNAME();
5195: $idx{status} = &Apache::loncoursedata::CL_STATUS();
5196:
1.290 albertel 5197: if (grep(/^st$/,@{$roles})) {
1.276 albertel 5198: my ($classlist,$keylist)=&Apache::loncoursedata::get_classlist($cdom,$cnum);
1.278 raeburn 5199: my $now = time;
1.277 albertel 5200: foreach my $student (keys(%{$classlist})) {
1.288 raeburn 5201: my $match = 0;
1.412 raeburn 5202: my $secmatch = 0;
1.419 raeburn 5203: my $section = $$classlist{$student}[$idx{section}];
5204: if ($section eq '') {
5205: $section = 'none';
5206: }
1.291 albertel 5207: if ((ref($sections) eq 'ARRAY') && (@{$sections} > 0)) {
1.420 albertel 5208: if (grep(/^all$/,@{$sections})) {
1.412 raeburn 5209: $secmatch = 1;
5210: } elsif ($$classlist{$student}[$idx{section}] eq '') {
1.420 albertel 5211: if (grep(/^none$/,@{$sections})) {
1.412 raeburn 5212: $secmatch = 1;
5213: }
5214: } else {
1.419 raeburn 5215: if (grep(/^\Q$section\E$/,@{$sections})) {
1.412 raeburn 5216: $secmatch = 1;
5217: }
1.290 albertel 5218: }
1.412 raeburn 5219: if (!$secmatch) {
5220: next;
5221: }
1.419 raeburn 5222: }
1.420 albertel 5223: push(@{$seclists{$student}},$section);
1.275 raeburn 5224: if (defined($$types{'active'})) {
1.288 raeburn 5225: if ($$classlist{$student}[$idx{status}] eq 'Active') {
1.275 raeburn 5226: push(@{$$users{st}{$student}},'active');
1.288 raeburn 5227: $match = 1;
1.275 raeburn 5228: }
5229: }
5230: if (defined($$types{'previous'})) {
1.288 raeburn 5231: if ($$classlist{$student}[$idx{end}] <= $now) {
1.275 raeburn 5232: push(@{$$users{st}{$student}},'previous');
1.288 raeburn 5233: $match = 1;
1.275 raeburn 5234: }
5235: }
5236: if (defined($$types{'future'})) {
1.288 raeburn 5237: if (($$classlist{$student}[$idx{start}] > $now) && ($$classlist{$student}[$idx{end}] > $now) || ($$classlist{$student}[$idx{end}] == 0) || ($$classlist{$student}[$idx{end}] eq '')) {
1.275 raeburn 5238: push(@{$$users{st}{$student}},'future');
1.288 raeburn 5239: $match = 1;
1.275 raeburn 5240: }
5241: }
1.412 raeburn 5242: if ($match && ref($userdata) eq 'HASH') {
1.288 raeburn 5243: $$userdata{$student} = $$classlist{$student};
5244: }
1.275 raeburn 5245: }
5246: }
1.412 raeburn 5247: if ((@{$roles} > 1) || ((@{$roles} == 1) && ($$roles[0] ne "st"))) {
1.439 raeburn 5248: my %coursepersonnel = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum);
5249: my $now = time;
5250: foreach my $person (sort(keys(%coursepersonnel))) {
1.288 raeburn 5251: my $match = 0;
1.412 raeburn 5252: my $secmatch = 0;
1.439 raeburn 5253: my $status;
1.412 raeburn 5254: my ($role,$user,$usec) = ($person =~ /^([^:]*):([^:]+:[^:]+):([^:]*)/);
1.275 raeburn 5255: $user =~ s/:$//;
1.439 raeburn 5256: my ($end,$start) = split(/:/,$coursepersonnel{$person});
5257: if ($end == -1 || $start == -1) {
5258: next;
5259: }
5260: if (($role) && ((grep(/^\Q$role\E$/,@{$roles})) ||
5261: (grep(/^cr$/,@{$roles}) && $role =~ /^cr\//))) {
1.412 raeburn 5262: my ($uname,$udom) = split(/:/,$user);
5263: if ((ref($sections) eq 'ARRAY') && (@{$sections} > 0)) {
1.420 albertel 5264: if (grep(/^all$/,@{$sections})) {
1.412 raeburn 5265: $secmatch = 1;
5266: } elsif ($usec eq '') {
1.420 albertel 5267: if (grep(/^none$/,@{$sections})) {
1.412 raeburn 5268: $secmatch = 1;
5269: }
5270: } else {
5271: if (grep(/^\Q$usec\E$/,@{$sections})) {
5272: $secmatch = 1;
5273: }
5274: }
5275: if (!$secmatch) {
5276: next;
5277: }
1.288 raeburn 5278: }
1.419 raeburn 5279: if ($usec eq '') {
5280: $usec = 'none';
5281: }
1.275 raeburn 5282: if ($uname ne '' && $udom ne '') {
1.503 raeburn 5283: if ($end > 0 && $end < $now) {
1.439 raeburn 5284: $status = 'previous';
5285: } elsif ($start > $now) {
5286: $status = 'future';
5287: } else {
5288: $status = 'active';
5289: }
1.277 albertel 5290: foreach my $type (keys(%{$types})) {
1.275 raeburn 5291: if ($status eq $type) {
1.420 albertel 5292: if (!grep(/^\Q$type\E$/,@{$$users{$role}{$user}})) {
1.419 raeburn 5293: push(@{$$users{$role}{$user}},$type);
5294: }
1.288 raeburn 5295: $match = 1;
5296: }
5297: }
1.419 raeburn 5298: if (($match) && (ref($userdata) eq 'HASH')) {
5299: if (!exists($$userdata{$uname.':'.$udom})) {
5300: &get_user_info($udom,$uname,\%idx,$userdata);
5301: }
1.420 albertel 5302: if (!grep(/^\Q$usec\E$/,@{$seclists{$uname.':'.$udom}})) {
1.419 raeburn 5303: push(@{$seclists{$uname.':'.$udom}},$usec);
5304: }
1.275 raeburn 5305: }
5306: }
5307: }
5308: }
1.290 albertel 5309: if (grep(/^ow$/,@{$roles})) {
1.279 raeburn 5310: if ((defined($cdom)) && (defined($cnum))) {
5311: my %csettings = &Apache::lonnet::get('environment',['internal.courseowner'],$cdom,$cnum);
5312: if ( defined($csettings{'internal.courseowner'}) ) {
5313: my $owner = $csettings{'internal.courseowner'};
1.439 raeburn 5314: if ($owner !~ /^[^:]+:[^:]+$/) {
5315: $owner = $owner.':'.$cdom;
5316: }
5317: @{$$users{'ow'}{$owner}} = 'any';
1.290 albertel 5318: if (defined($userdata) &&
5319: !exists($$userdata{$owner.':'.$cdom})) {
5320: &get_user_info($cdom,$owner,\%idx,$userdata);
1.420 albertel 5321: if (!grep(/^none$/,@{$seclists{$owner.':'.$cdom}})) {
1.419 raeburn 5322: push(@{$seclists{$owner.':'.$cdom}},'none');
5323: }
1.290 albertel 5324: }
1.279 raeburn 5325: }
5326: }
5327: }
1.419 raeburn 5328: foreach my $user (keys(%seclists)) {
5329: @{$seclists{$user}} = (sort {$a <=> $b} @{$seclists{$user}});
5330: $$userdata{$user}[$idx{section}] = join(',',@{$seclists{$user}});
5331: }
1.275 raeburn 5332: }
5333: return;
5334: }
5335:
1.288 raeburn 5336: sub get_user_info {
5337: my ($udom,$uname,$idx,$userdata) = @_;
1.289 albertel 5338: $$userdata{$uname.':'.$udom}[$$idx{fullname}] =
5339: &plainname($uname,$udom,'lastname');
1.291 albertel 5340: $$userdata{$uname.':'.$udom}[$$idx{uname}] = $uname;
1.297 raeburn 5341: $$userdata{$uname.':'.$udom}[$$idx{udom}] = $udom;
1.288 raeburn 5342: return;
5343: }
1.275 raeburn 5344:
1.472 raeburn 5345: ###############################################
5346:
5347: =pod
5348:
5349: =item * &get_user_quota()
5350:
5351: Retrieves quota assigned for storage of portfolio files for a user
5352:
5353: Incoming parameters:
5354: 1. user's username
5355: 2. user's domain
5356:
5357: Returns:
1.536 raeburn 5358: 1. Disk quota (in Mb) assigned to student.
5359: 2. (Optional) Type of setting: custom or default
5360: (individually assigned or default for user's
5361: institutional status).
5362: 3. (Optional) - User's institutional status (e.g., faculty, staff
5363: or student - types as defined in localenroll::inst_usertypes
5364: for user's domain, which determines default quota for user.
5365: 4. (Optional) - Default quota which would apply to the user.
1.472 raeburn 5366:
5367: If a value has been stored in the user's environment,
1.536 raeburn 5368: it will return that, otherwise it returns the maximal default
5369: defined for the user's instituional status(es) in the domain.
1.472 raeburn 5370:
5371: =cut
5372:
5373: ###############################################
5374:
5375:
5376: sub get_user_quota {
5377: my ($uname,$udom) = @_;
1.536 raeburn 5378: my ($quota,$quotatype,$settingstatus,$defquota);
1.472 raeburn 5379: if (!defined($udom)) {
5380: $udom = $env{'user.domain'};
5381: }
5382: if (!defined($uname)) {
5383: $uname = $env{'user.name'};
5384: }
5385: if (($udom eq '' || $uname eq '') ||
5386: ($udom eq 'public') && ($uname eq 'public')) {
5387: $quota = 0;
1.536 raeburn 5388: $quotatype = 'default';
5389: $defquota = 0;
1.472 raeburn 5390: } else {
1.536 raeburn 5391: my $inststatus;
1.472 raeburn 5392: if ($udom eq $env{'user.domain'} && $uname eq $env{'user.name'}) {
5393: $quota = $env{'environment.portfolioquota'};
1.536 raeburn 5394: $inststatus = $env{'environment.inststatus'};
1.472 raeburn 5395: } else {
1.536 raeburn 5396: my %userenv =
5397: &Apache::lonnet::get('environment',['portfolioquota',
5398: 'inststatus'],$udom,$uname);
1.472 raeburn 5399: my ($tmp) = keys(%userenv);
5400: if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
5401: $quota = $userenv{'portfolioquota'};
1.536 raeburn 5402: $inststatus = $userenv{'inststatus'};
1.472 raeburn 5403: } else {
5404: undef(%userenv);
5405: }
5406: }
1.536 raeburn 5407: ($defquota,$settingstatus) = &default_quota($udom,$inststatus);
1.472 raeburn 5408: if ($quota eq '') {
1.536 raeburn 5409: $quota = $defquota;
5410: $quotatype = 'default';
5411: } else {
5412: $quotatype = 'custom';
1.472 raeburn 5413: }
5414: }
1.536 raeburn 5415: if (wantarray) {
5416: return ($quota,$quotatype,$settingstatus,$defquota);
5417: } else {
5418: return $quota;
5419: }
1.472 raeburn 5420: }
5421:
5422: ###############################################
5423:
5424: =pod
5425:
5426: =item * &default_quota()
5427:
1.536 raeburn 5428: Retrieves default quota assigned for storage of user portfolio files,
5429: given an (optional) user's institutional status.
1.472 raeburn 5430:
5431: Incoming parameters:
5432: 1. domain
1.536 raeburn 5433: 2. (Optional) institutional status(es). This is a : separated list of
5434: status types (e.g., faculty, staff, student etc.)
5435: which apply to the user for whom the default is being retrieved.
5436: If the institutional status string in undefined, the domain
5437: default quota will be returned.
1.472 raeburn 5438:
5439: Returns:
5440: 1. Default disk quota (in Mb) for user portfolios in the domain.
1.536 raeburn 5441: 2. (Optional) institutional type which determined the value of the
5442: default quota.
1.472 raeburn 5443:
5444: If a value has been stored in the domain's configuration db,
5445: it will return that, otherwise it returns 20 (for backwards
5446: compatibility with domains which have not set up a configuration
5447: db file; the original statically defined portfolio quota was 20 Mb).
5448:
1.536 raeburn 5449: If the user's status includes multiple types (e.g., staff and student),
5450: the largest default quota which applies to the user determines the
5451: default quota returned.
5452:
1.472 raeburn 5453: =cut
5454:
5455: ###############################################
5456:
5457:
5458: sub default_quota {
1.536 raeburn 5459: my ($udom,$inststatus) = @_;
5460: my ($defquota,$settingstatus);
5461: my %quotahash = &Apache::lonnet::get_dom('configuration',
5462: ['quota'],$udom);
5463: if (ref($quotahash{'quota'}) eq 'HASH') {
5464: if ($inststatus ne '') {
5465: my @statuses = split(/:/,$inststatus);
5466: foreach my $item (@statuses) {
5467: if ($quotahash{'quota'}{$item} ne '') {
5468: if ($defquota eq '') {
5469: $defquota = $quotahash{'quota'}{$item};
5470: $settingstatus = $item;
5471: } elsif ($quotahash{'quota'}{$item} > $defquota) {
5472: $defquota = $quotahash{'quota'}{$item};
5473: $settingstatus = $item;
5474: }
5475: }
5476: }
5477: }
5478: if ($defquota eq '') {
5479: $defquota = $quotahash{'quota'}{'default'};
5480: $settingstatus = 'default';
5481: }
5482: } else {
5483: $settingstatus = 'default';
5484: $defquota = 20;
5485: }
5486: if (wantarray) {
5487: return ($defquota,$settingstatus);
1.472 raeburn 5488: } else {
1.536 raeburn 5489: return $defquota;
1.472 raeburn 5490: }
5491: }
5492:
1.384 raeburn 5493: sub get_secgrprole_info {
5494: my ($cdom,$cnum,$needroles,$type) = @_;
5495: my %sections_count = &get_sections($cdom,$cnum);
5496: my @sections = (sort {$a <=> $b} keys(%sections_count));
5497: my %curr_groups = &Apache::longroup::coursegroups($cdom,$cnum);
5498: my @groups = sort(keys(%curr_groups));
5499: my $allroles = [];
5500: my $rolehash;
5501: my $accesshash = {
5502: active => 'Currently has access',
5503: future => 'Will have future access',
5504: previous => 'Previously had access',
5505: };
5506: if ($needroles) {
5507: $rolehash = {'all' => 'all'};
1.385 albertel 5508: my %user_roles = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum);
5509: if (&Apache::lonnet::error(%user_roles)) {
5510: undef(%user_roles);
5511: }
5512: foreach my $item (keys(%user_roles)) {
1.384 raeburn 5513: my ($role)=split(/\:/,$item,2);
5514: if ($role eq 'cr') { next; }
5515: if ($role =~ /^cr/) {
5516: $$rolehash{$role} = (split('/',$role))[3];
5517: } else {
5518: $$rolehash{$role} = &Apache::lonnet::plaintext($role,$type);
5519: }
5520: }
5521: foreach my $key (sort(keys(%{$rolehash}))) {
5522: push(@{$allroles},$key);
5523: }
5524: push (@{$allroles},'st');
5525: $$rolehash{'st'} = &Apache::lonnet::plaintext('st',$type);
5526: }
5527: return (\@sections,\@groups,$allroles,$rolehash,$accesshash);
5528: }
5529:
1.112 bowersj2 5530: =pod
5531:
1.549 albertel 5532: =back
5533:
5534: =head1 HTTP Helpers
5535:
5536: =over 4
5537:
1.112 bowersj2 5538: =item * get_unprocessed_cgi($query,$possible_names)
5539:
1.258 albertel 5540: Modify the %env hash to contain unprocessed CGI form parameters held in
1.112 bowersj2 5541: $query. The parameters listed in $possible_names (an array reference),
1.258 albertel 5542: will be set in $env{'form.name'} if they do not already exist.
1.112 bowersj2 5543:
5544: Typically called with $ENV{'QUERY_STRING'} as the first parameter.
5545: $possible_names is an ref to an array of form element names. As an example:
5546: get_unprocessed_cgi($ENV{'QUERY_STRING'},['uname','udom']);
1.258 albertel 5547: will result in $env{'form.uname'} and $env{'form.udom'} being set.
1.112 bowersj2 5548:
5549: =cut
1.1 albertel 5550:
1.6 albertel 5551: sub get_unprocessed_cgi {
1.25 albertel 5552: my ($query,$possible_names)= @_;
1.26 matthew 5553: # $Apache::lonxml::debug=1;
1.356 albertel 5554: foreach my $pair (split(/&/,$query)) {
5555: my ($name, $value) = split(/=/,$pair);
1.369 www 5556: $name = &unescape($name);
1.25 albertel 5557: if (!defined($possible_names) || (grep {$_ eq $name} @$possible_names)) {
5558: $value =~ tr/+/ /;
5559: $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
1.258 albertel 5560: unless (defined($env{'form.'.$name})) { &add_to_env('form.'.$name,$value) };
1.25 albertel 5561: }
1.16 harris41 5562: }
1.6 albertel 5563: }
5564:
1.112 bowersj2 5565: =pod
5566:
5567: =item * cacheheader()
5568:
5569: returns cache-controlling header code
5570:
5571: =cut
5572:
1.7 albertel 5573: sub cacheheader {
1.258 albertel 5574: unless ($env{'request.method'} eq 'GET') { return ''; }
1.216 albertel 5575: my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
5576: my $output .='<meta HTTP-EQUIV="Expires" CONTENT="'.$date.'" />
1.7 albertel 5577: <meta HTTP-EQUIV="Cache-control" CONTENT="no-cache" />
5578: <meta HTTP-EQUIV="Pragma" CONTENT="no-cache" />';
1.216 albertel 5579: return $output;
1.7 albertel 5580: }
5581:
1.112 bowersj2 5582: =pod
5583:
5584: =item * no_cache($r)
5585:
5586: specifies header code to not have cache
5587:
5588: =cut
5589:
1.9 albertel 5590: sub no_cache {
1.216 albertel 5591: my ($r) = @_;
5592: if ($ENV{'REQUEST_METHOD'} ne 'GET' &&
1.258 albertel 5593: $env{'request.method'} ne 'GET') { return ''; }
1.216 albertel 5594: my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime(time));
5595: $r->no_cache(1);
5596: $r->header_out("Expires" => $date);
5597: $r->header_out("Pragma" => "no-cache");
1.123 www 5598: }
5599:
5600: sub content_type {
1.181 albertel 5601: my ($r,$type,$charset) = @_;
1.299 foxr 5602: if ($r) {
5603: # Note that printout.pl calls this with undef for $r.
5604: &no_cache($r);
5605: }
1.258 albertel 5606: if ($env{'browser.mathml'} && $type eq 'text/html') { $type='text/xml'; }
1.181 albertel 5607: unless ($charset) {
5608: $charset=&Apache::lonlocal::current_encoding;
5609: }
5610: if ($charset) { $type.='; charset='.$charset; }
5611: if ($r) {
5612: $r->content_type($type);
5613: } else {
5614: print("Content-type: $type\n\n");
5615: }
1.9 albertel 5616: }
1.25 albertel 5617:
1.112 bowersj2 5618: =pod
5619:
5620: =item * add_to_env($name,$value)
5621:
1.258 albertel 5622: adds $name to the %env hash with value
1.112 bowersj2 5623: $value, if $name already exists, the entry is converted to an array
5624: reference and $value is added to the array.
5625:
5626: =cut
5627:
1.25 albertel 5628: sub add_to_env {
5629: my ($name,$value)=@_;
1.258 albertel 5630: if (defined($env{$name})) {
5631: if (ref($env{$name})) {
1.25 albertel 5632: #already have multiple values
1.258 albertel 5633: push(@{ $env{$name} },$value);
1.25 albertel 5634: } else {
5635: #first time seeing multiple values, convert hash entry to an arrayref
1.258 albertel 5636: my $first=$env{$name};
5637: undef($env{$name});
5638: push(@{ $env{$name} },$first,$value);
1.25 albertel 5639: }
5640: } else {
1.258 albertel 5641: $env{$name}=$value;
1.25 albertel 5642: }
1.31 albertel 5643: }
1.149 albertel 5644:
5645: =pod
5646:
5647: =item * get_env_multiple($name)
5648:
1.258 albertel 5649: gets $name from the %env hash, it seemlessly handles the cases where multiple
1.149 albertel 5650: values may be defined and end up as an array ref.
5651:
5652: returns an array of values
5653:
5654: =cut
5655:
5656: sub get_env_multiple {
5657: my ($name) = @_;
5658: my @values;
1.258 albertel 5659: if (defined($env{$name})) {
1.149 albertel 5660: # exists is it an array
1.258 albertel 5661: if (ref($env{$name})) {
5662: @values=@{ $env{$name} };
1.149 albertel 5663: } else {
1.258 albertel 5664: $values[0]=$env{$name};
1.149 albertel 5665: }
5666: }
5667: return(@values);
5668: }
5669:
1.31 albertel 5670:
1.41 ng 5671: =pod
1.45 matthew 5672:
1.464 albertel 5673: =back
1.41 ng 5674:
1.112 bowersj2 5675: =head1 CSV Upload/Handling functions
1.38 albertel 5676:
1.41 ng 5677: =over 4
5678:
1.112 bowersj2 5679: =item * upfile_store($r)
1.41 ng 5680:
5681: Store uploaded file, $r should be the HTTP Request object,
1.258 albertel 5682: needs $env{'form.upfile'}
1.41 ng 5683: returns $datatoken to be put into hidden field
5684:
5685: =cut
1.31 albertel 5686:
5687: sub upfile_store {
5688: my $r=shift;
1.258 albertel 5689: $env{'form.upfile'}=~s/\r/\n/gs;
5690: $env{'form.upfile'}=~s/\f/\n/gs;
5691: $env{'form.upfile'}=~s/\n+/\n/gs;
5692: $env{'form.upfile'}=~s/\n+$//gs;
1.31 albertel 5693:
1.258 albertel 5694: my $datatoken=$env{'user.name'}.'_'.$env{'user.domain'}.
5695: '_enroll_'.$env{'request.course.id'}.'_'.time.'_'.$$;
1.31 albertel 5696: {
1.158 raeburn 5697: my $datafile = $r->dir_config('lonDaemons').
5698: '/tmp/'.$datatoken.'.tmp';
5699: if ( open(my $fh,">$datafile") ) {
1.258 albertel 5700: print $fh $env{'form.upfile'};
1.158 raeburn 5701: close($fh);
5702: }
1.31 albertel 5703: }
5704: return $datatoken;
5705: }
5706:
1.56 matthew 5707: =pod
5708:
1.112 bowersj2 5709: =item * load_tmp_file($r)
1.41 ng 5710:
5711: Load uploaded file from tmp, $r should be the HTTP Request object,
1.258 albertel 5712: needs $env{'form.datatoken'},
5713: sets $env{'form.upfile'} to the contents of the file
1.41 ng 5714:
5715: =cut
1.31 albertel 5716:
5717: sub load_tmp_file {
5718: my $r=shift;
5719: my @studentdata=();
5720: {
1.158 raeburn 5721: my $studentfile = $r->dir_config('lonDaemons').
1.258 albertel 5722: '/tmp/'.$env{'form.datatoken'}.'.tmp';
1.158 raeburn 5723: if ( open(my $fh,"<$studentfile") ) {
5724: @studentdata=<$fh>;
5725: close($fh);
5726: }
1.31 albertel 5727: }
1.258 albertel 5728: $env{'form.upfile'}=join('',@studentdata);
1.31 albertel 5729: }
5730:
1.56 matthew 5731: =pod
5732:
1.112 bowersj2 5733: =item * upfile_record_sep()
1.41 ng 5734:
5735: Separate uploaded file into records
5736: returns array of records,
1.258 albertel 5737: needs $env{'form.upfile'} and $env{'form.upfiletype'}
1.41 ng 5738:
5739: =cut
1.31 albertel 5740:
5741: sub upfile_record_sep {
1.258 albertel 5742: if ($env{'form.upfiletype'} eq 'xml') {
1.31 albertel 5743: } else {
1.248 albertel 5744: my @records;
1.258 albertel 5745: foreach my $line (split(/\n/,$env{'form.upfile'})) {
1.248 albertel 5746: if ($line=~/^\s*$/) { next; }
5747: push(@records,$line);
5748: }
5749: return @records;
1.31 albertel 5750: }
5751: }
5752:
1.56 matthew 5753: =pod
5754:
1.112 bowersj2 5755: =item * record_sep($record)
1.41 ng 5756:
1.258 albertel 5757: Separate a record into fields $record should be an item from the upfile_record_sep(), needs $env{'form.upfiletype'}
1.41 ng 5758:
5759: =cut
5760:
1.263 www 5761: sub takeleft {
5762: my $index=shift;
5763: return substr('0000'.$index,-4,4);
5764: }
5765:
1.31 albertel 5766: sub record_sep {
5767: my $record=shift;
5768: my %components=();
1.258 albertel 5769: if ($env{'form.upfiletype'} eq 'xml') {
5770: } elsif ($env{'form.upfiletype'} eq 'space') {
1.31 albertel 5771: my $i=0;
1.356 albertel 5772: foreach my $field (split(/\s+/,$record)) {
1.31 albertel 5773: $field=~s/^(\"|\')//;
5774: $field=~s/(\"|\')$//;
1.263 www 5775: $components{&takeleft($i)}=$field;
1.31 albertel 5776: $i++;
5777: }
1.258 albertel 5778: } elsif ($env{'form.upfiletype'} eq 'tab') {
1.31 albertel 5779: my $i=0;
1.356 albertel 5780: foreach my $field (split(/\t/,$record)) {
1.31 albertel 5781: $field=~s/^(\"|\')//;
5782: $field=~s/(\"|\')$//;
1.263 www 5783: $components{&takeleft($i)}=$field;
1.31 albertel 5784: $i++;
5785: }
5786: } else {
1.480 banghart 5787: my @allfields;
5788: if ($env{'form.upfiletype'} eq 'semisv') {
1.504 albertel 5789: @allfields=split(/;/,$record,-1);
1.480 banghart 5790: } else {
1.504 albertel 5791: @allfields=split(/\,/,$record,-1);
1.480 banghart 5792: }
1.31 albertel 5793: my $i=0;
5794: my $j;
5795: for ($j=0;$j<=$#allfields;$j++) {
5796: my $field=$allfields[$j];
5797: if ($field=~/^\s*(\"|\')/) {
5798: my $delimiter=$1;
5799: while (($field!~/$delimiter$/) && ($j<$#allfields)) {
5800: $j++;
5801: $field.=','.$allfields[$j];
5802: }
5803: $field=~s/^\s*$delimiter//;
5804: $field=~s/$delimiter\s*$//;
5805: }
1.263 www 5806: $components{&takeleft($i)}=$field;
1.31 albertel 5807: $i++;
5808: }
5809: }
5810: return %components;
5811: }
5812:
1.144 matthew 5813: ######################################################
5814: ######################################################
5815:
1.56 matthew 5816: =pod
5817:
1.112 bowersj2 5818: =item * upfile_select_html()
1.41 ng 5819:
1.144 matthew 5820: Return HTML code to select a file from the users machine and specify
5821: the file type.
1.41 ng 5822:
5823: =cut
5824:
1.144 matthew 5825: ######################################################
5826: ######################################################
1.31 albertel 5827: sub upfile_select_html {
1.144 matthew 5828: my %Types = (
5829: csv => &mt('CSV (comma separated values, spreadsheet)'),
1.480 banghart 5830: semisv => &mt('Semicolon separated values'),
1.144 matthew 5831: space => &mt('Space separated'),
5832: tab => &mt('Tabulator separated'),
5833: # xml => &mt('HTML/XML'),
5834: );
5835: my $Str = '<input type="file" name="upfile" size="50" />'.
5836: '<br />Type: <select name="upfiletype">';
5837: foreach my $type (sort(keys(%Types))) {
5838: $Str .= '<option value="'.$type.'" >'.$Types{$type}."</option>\n";
5839: }
5840: $Str .= "</select>\n";
5841: return $Str;
1.31 albertel 5842: }
5843:
1.301 albertel 5844: sub get_samples {
5845: my ($records,$toget) = @_;
5846: my @samples=({});
5847: my $got=0;
5848: foreach my $rec (@$records) {
5849: my %temp = &record_sep($rec);
5850: if (! grep(/\S/, values(%temp))) { next; }
5851: if (%temp) {
5852: $samples[$got]=\%temp;
5853: $got++;
5854: if ($got == $toget) { last; }
5855: }
5856: }
5857: return \@samples;
5858: }
5859:
1.144 matthew 5860: ######################################################
5861: ######################################################
5862:
1.56 matthew 5863: =pod
5864:
1.112 bowersj2 5865: =item * csv_print_samples($r,$records)
1.41 ng 5866:
5867: Prints a table of sample values from each column uploaded $r is an
5868: Apache Request ref, $records is an arrayref from
5869: &Apache::loncommon::upfile_record_sep
5870:
5871: =cut
5872:
1.144 matthew 5873: ######################################################
5874: ######################################################
1.31 albertel 5875: sub csv_print_samples {
5876: my ($r,$records) = @_;
1.301 albertel 5877: my $samples = &get_samples($records,3);
5878:
1.144 matthew 5879: $r->print(&mt('Samples').'<br /><table border="2"><tr>');
1.356 albertel 5880: foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
5881: $r->print('<th>'.&mt('Column [_1]',($sample+1)).'</th>'); }
1.31 albertel 5882: $r->print('</tr>');
1.301 albertel 5883: foreach my $hash (@$samples) {
1.31 albertel 5884: $r->print('<tr>');
1.356 albertel 5885: foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
1.31 albertel 5886: $r->print('<td>');
1.356 albertel 5887: if (defined($$hash{$sample})) { $r->print($$hash{$sample}); }
1.31 albertel 5888: $r->print('</td>');
5889: }
5890: $r->print('</tr>');
5891: }
5892: $r->print('</tr></table><br />'."\n");
5893: }
5894:
1.144 matthew 5895: ######################################################
5896: ######################################################
5897:
1.56 matthew 5898: =pod
5899:
1.112 bowersj2 5900: =item * csv_print_select_table($r,$records,$d)
1.41 ng 5901:
5902: Prints a table to create associations between values and table columns.
1.144 matthew 5903:
1.41 ng 5904: $r is an Apache Request ref,
5905: $records is an arrayref from &Apache::loncommon::upfile_record_sep,
1.174 matthew 5906: $d is an array of 2 element arrays (internal name, displayed name,defaultcol)
1.41 ng 5907:
5908: =cut
5909:
1.144 matthew 5910: ######################################################
5911: ######################################################
1.31 albertel 5912: sub csv_print_select_table {
5913: my ($r,$records,$d) = @_;
1.301 albertel 5914: my $i=0;
5915: my $samples = &get_samples($records,1);
1.144 matthew 5916: $r->print(&mt('Associate columns with student attributes.')."\n".
5917: '<table border="2"><tr>'.
5918: '<th>'.&mt('Attribute').'</th>'.
5919: '<th>'.&mt('Column').'</th></tr>'."\n");
1.356 albertel 5920: foreach my $array_ref (@$d) {
5921: my ($value,$display,$defaultcol)=@{ $array_ref };
1.31 albertel 5922: $r->print('<tr><td>'.$display.'</td>');
5923:
5924: $r->print('<td><select name=f'.$i.
1.32 matthew 5925: ' onchange="javascript:flip(this.form,'.$i.');">');
1.31 albertel 5926: $r->print('<option value="none"></option>');
1.356 albertel 5927: foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
5928: $r->print('<option value="'.$sample.'"'.
5929: ($sample eq $defaultcol ? ' selected="selected" ' : '').
5930: '>Column '.($sample+1).'</option>');
1.31 albertel 5931: }
5932: $r->print('</select></td></tr>'."\n");
5933: $i++;
5934: }
5935: $i--;
5936: return $i;
5937: }
1.56 matthew 5938:
1.144 matthew 5939: ######################################################
5940: ######################################################
5941:
1.56 matthew 5942: =pod
1.31 albertel 5943:
1.112 bowersj2 5944: =item * csv_samples_select_table($r,$records,$d)
1.41 ng 5945:
5946: Prints a table of sample values from the upload and can make associate samples to internal names.
5947:
5948: $r is an Apache Request ref,
5949: $records is an arrayref from &Apache::loncommon::upfile_record_sep,
5950: $d is an array of 2 element arrays (internal name, displayed name)
5951:
5952: =cut
5953:
1.144 matthew 5954: ######################################################
5955: ######################################################
1.31 albertel 5956: sub csv_samples_select_table {
5957: my ($r,$records,$d) = @_;
5958: my $i=0;
1.144 matthew 5959: #
1.301 albertel 5960: my $samples = &get_samples($records,3);
1.144 matthew 5961: $r->print('<table border=2><tr><th>'.
5962: &mt('Field').'</th><th>'.&mt('Samples').'</th></tr>');
1.301 albertel 5963:
5964: foreach my $key (sort(keys(%{ $samples->[0] }))) {
1.144 matthew 5965: $r->print('<tr><td><select name="f'.$i.'"'.
1.32 matthew 5966: ' onchange="javascript:flip(this.form,'.$i.');">');
1.301 albertel 5967: foreach my $option (@$d) {
5968: my ($value,$display,$defaultcol)=@{ $option };
1.174 matthew 5969: $r->print('<option value="'.$value.'"'.
1.253 albertel 5970: ($i eq $defaultcol ? ' selected="selected" ':'').'>'.
1.174 matthew 5971: $display.'</option>');
1.31 albertel 5972: }
5973: $r->print('</select></td><td>');
1.301 albertel 5974: foreach my $line (0..2) {
5975: if (defined($samples->[$line]{$key})) {
5976: $r->print($samples->[$line]{$key}."<br />\n");
5977: }
5978: }
1.31 albertel 5979: $r->print('</td></tr>');
5980: $i++;
5981: }
5982: $i--;
5983: return($i);
1.115 matthew 5984: }
5985:
1.144 matthew 5986: ######################################################
5987: ######################################################
5988:
1.115 matthew 5989: =pod
5990:
5991: =item clean_excel_name($name)
5992:
5993: Returns a replacement for $name which does not contain any illegal characters.
5994:
5995: =cut
5996:
1.144 matthew 5997: ######################################################
5998: ######################################################
1.115 matthew 5999: sub clean_excel_name {
6000: my ($name) = @_;
6001: $name =~ s/[:\*\?\/\\]//g;
6002: if (length($name) > 31) {
6003: $name = substr($name,0,31);
6004: }
6005: return $name;
1.25 albertel 6006: }
1.84 albertel 6007:
1.85 albertel 6008: =pod
6009:
1.112 bowersj2 6010: =item * check_if_partid_hidden($id,$symb,$udom,$uname)
1.85 albertel 6011:
6012: Returns either 1 or undef
6013:
6014: 1 if the part is to be hidden, undef if it is to be shown
6015:
6016: Arguments are:
6017:
6018: $id the id of the part to be checked
6019: $symb, optional the symb of the resource to check
6020: $udom, optional the domain of the user to check for
6021: $uname, optional the username of the user to check for
6022:
6023: =cut
1.84 albertel 6024:
6025: sub check_if_partid_hidden {
6026: my ($id,$symb,$udom,$uname) = @_;
1.133 albertel 6027: my $hiddenparts=&Apache::lonnet::EXT('resource.0.hiddenparts',
1.84 albertel 6028: $symb,$udom,$uname);
1.141 albertel 6029: my $truth=1;
6030: #if the string starts with !, then the list is the list to show not hide
6031: if ($hiddenparts=~s/^\s*!//) { $truth=undef; }
1.84 albertel 6032: my @hiddenlist=split(/,/,$hiddenparts);
6033: foreach my $checkid (@hiddenlist) {
1.141 albertel 6034: if ($checkid =~ /^\s*\Q$id\E\s*$/) { return $truth; }
1.84 albertel 6035: }
1.141 albertel 6036: return !$truth;
1.84 albertel 6037: }
1.127 matthew 6038:
1.138 matthew 6039:
6040: ############################################################
6041: ############################################################
6042:
6043: =pod
6044:
1.157 matthew 6045: =back
6046:
1.138 matthew 6047: =head1 cgi-bin script and graphing routines
6048:
1.157 matthew 6049: =over 4
6050:
1.138 matthew 6051: =item get_cgi_id
6052:
6053: Inputs: none
6054:
6055: Returns an id which can be used to pass environment variables
6056: to various cgi-bin scripts. These environment variables will
6057: be removed from the users environment after a given time by
6058: the routine &Apache::lonnet::transfer_profile_to_env.
6059:
6060: =cut
6061:
6062: ############################################################
6063: ############################################################
1.152 albertel 6064: my $uniq=0;
1.136 matthew 6065: sub get_cgi_id {
1.154 albertel 6066: $uniq=($uniq+1)%100000;
1.280 albertel 6067: return (time.'_'.$$.'_'.$uniq);
1.136 matthew 6068: }
6069:
1.127 matthew 6070: ############################################################
6071: ############################################################
6072:
6073: =pod
6074:
1.134 matthew 6075: =item DrawBarGraph
1.127 matthew 6076:
1.138 matthew 6077: Facilitates the plotting of data in a (stacked) bar graph.
6078: Puts plot definition data into the users environment in order for
6079: graph.png to plot it. Returns an <img> tag for the plot.
6080: The bars on the plot are labeled '1','2',...,'n'.
6081:
6082: Inputs:
6083:
6084: =over 4
6085:
6086: =item $Title: string, the title of the plot
6087:
6088: =item $xlabel: string, text describing the X-axis of the plot
6089:
6090: =item $ylabel: string, text describing the Y-axis of the plot
6091:
6092: =item $Max: scalar, the maximum Y value to use in the plot
6093: If $Max is < any data point, the graph will not be rendered.
6094:
1.140 matthew 6095: =item $colors: array ref holding the colors to be used for the data sets when
1.138 matthew 6096: they are plotted. If undefined, default values will be used.
6097:
1.178 matthew 6098: =item $labels: array ref holding the labels to use on the x-axis for the bars.
6099:
1.138 matthew 6100: =item @Values: An array of array references. Each array reference holds data
6101: to be plotted in a stacked bar chart.
6102:
1.239 matthew 6103: =item If the final element of @Values is a hash reference the key/value
6104: pairs will be added to the graph definition.
6105:
1.138 matthew 6106: =back
6107:
6108: Returns:
6109:
6110: An <img> tag which references graph.png and the appropriate identifying
6111: information for the plot.
6112:
1.127 matthew 6113: =cut
6114:
6115: ############################################################
6116: ############################################################
1.134 matthew 6117: sub DrawBarGraph {
1.178 matthew 6118: my ($Title,$xlabel,$ylabel,$Max,$colors,$labels,@Values)=@_;
1.134 matthew 6119: #
6120: if (! defined($colors)) {
6121: $colors = ['#33ff00',
6122: '#0033cc', '#990000', '#aaaa66', '#663399', '#ff9933',
6123: '#66ccff', '#ff9999', '#cccc33', '#660000', '#33cc66',
6124: ];
6125: }
1.228 matthew 6126: my $extra_settings = {};
6127: if (ref($Values[-1]) eq 'HASH') {
6128: $extra_settings = pop(@Values);
6129: }
1.127 matthew 6130: #
1.136 matthew 6131: my $identifier = &get_cgi_id();
6132: my $id = 'cgi.'.$identifier;
1.129 matthew 6133: if (! @Values || ref($Values[0]) ne 'ARRAY') {
1.127 matthew 6134: return '';
6135: }
1.225 matthew 6136: #
6137: my @Labels;
6138: if (defined($labels)) {
6139: @Labels = @$labels;
6140: } else {
6141: for (my $i=0;$i<@{$Values[0]};$i++) {
6142: push (@Labels,$i+1);
6143: }
6144: }
6145: #
1.129 matthew 6146: my $NumBars = scalar(@{$Values[0]});
1.225 matthew 6147: if ($NumBars < scalar(@Labels)) { $NumBars = scalar(@Labels); }
1.129 matthew 6148: my %ValuesHash;
6149: my $NumSets=1;
6150: foreach my $array (@Values) {
6151: next if (! ref($array));
1.136 matthew 6152: $ValuesHash{$id.'.data.'.$NumSets++} =
1.132 matthew 6153: join(',',@$array);
1.129 matthew 6154: }
1.127 matthew 6155: #
1.136 matthew 6156: my ($height,$width,$xskip,$bar_width) = (200,120,1,15);
1.225 matthew 6157: if ($NumBars < 3) {
6158: $width = 120+$NumBars*32;
1.220 matthew 6159: $xskip = 1;
1.225 matthew 6160: $bar_width = 30;
6161: } elsif ($NumBars < 5) {
6162: $width = 120+$NumBars*20;
6163: $xskip = 1;
6164: $bar_width = 20;
1.220 matthew 6165: } elsif ($NumBars < 10) {
1.136 matthew 6166: $width = 120+$NumBars*15;
6167: $xskip = 1;
6168: $bar_width = 15;
6169: } elsif ($NumBars <= 25) {
6170: $width = 120+$NumBars*11;
6171: $xskip = 5;
6172: $bar_width = 8;
6173: } elsif ($NumBars <= 50) {
6174: $width = 120+$NumBars*8;
6175: $xskip = 5;
6176: $bar_width = 4;
6177: } else {
6178: $width = 120+$NumBars*8;
6179: $xskip = 5;
6180: $bar_width = 4;
6181: }
6182: #
1.137 matthew 6183: $Max = 1 if ($Max < 1);
6184: if ( int($Max) < $Max ) {
6185: $Max++;
6186: $Max = int($Max);
6187: }
1.127 matthew 6188: $Title = '' if (! defined($Title));
6189: $xlabel = '' if (! defined($xlabel));
6190: $ylabel = '' if (! defined($ylabel));
1.369 www 6191: $ValuesHash{$id.'.title'} = &escape($Title);
6192: $ValuesHash{$id.'.xlabel'} = &escape($xlabel);
6193: $ValuesHash{$id.'.ylabel'} = &escape($ylabel);
1.137 matthew 6194: $ValuesHash{$id.'.y_max_value'} = $Max;
1.136 matthew 6195: $ValuesHash{$id.'.NumBars'} = $NumBars;
6196: $ValuesHash{$id.'.NumSets'} = $NumSets;
6197: $ValuesHash{$id.'.PlotType'} = 'bar';
6198: $ValuesHash{$id.'.Colors'} = join(',',@{$colors});
6199: $ValuesHash{$id.'.height'} = $height;
6200: $ValuesHash{$id.'.width'} = $width;
6201: $ValuesHash{$id.'.xskip'} = $xskip;
6202: $ValuesHash{$id.'.bar_width'} = $bar_width;
6203: $ValuesHash{$id.'.labels'} = join(',',@Labels);
1.127 matthew 6204: #
1.228 matthew 6205: # Deal with other parameters
6206: while (my ($key,$value) = each(%$extra_settings)) {
6207: $ValuesHash{$id.'.'.$key} = $value;
6208: }
6209: #
1.137 matthew 6210: &Apache::lonnet::appenv(%ValuesHash);
6211: return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';
6212: }
6213:
6214: ############################################################
6215: ############################################################
6216:
6217: =pod
6218:
6219: =item DrawXYGraph
6220:
1.138 matthew 6221: Facilitates the plotting of data in an XY graph.
6222: Puts plot definition data into the users environment in order for
6223: graph.png to plot it. Returns an <img> tag for the plot.
6224:
6225: Inputs:
6226:
6227: =over 4
6228:
6229: =item $Title: string, the title of the plot
6230:
6231: =item $xlabel: string, text describing the X-axis of the plot
6232:
6233: =item $ylabel: string, text describing the Y-axis of the plot
6234:
6235: =item $Max: scalar, the maximum Y value to use in the plot
6236: If $Max is < any data point, the graph will not be rendered.
6237:
6238: =item $colors: Array ref containing the hex color codes for the data to be
6239: plotted in. If undefined, default values will be used.
6240:
6241: =item $Xlabels: Array ref containing the labels to be used for the X-axis.
6242:
6243: =item $Ydata: Array ref containing Array refs.
1.185 www 6244: Each of the contained arrays will be plotted as a separate curve.
1.138 matthew 6245:
6246: =item %Values: hash indicating or overriding any default values which are
6247: passed to graph.png.
6248: Possible values are: width, xskip, x_ticks, x_tick_offset, among others.
6249:
6250: =back
6251:
6252: Returns:
6253:
6254: An <img> tag which references graph.png and the appropriate identifying
6255: information for the plot.
6256:
1.137 matthew 6257: =cut
6258:
6259: ############################################################
6260: ############################################################
6261: sub DrawXYGraph {
6262: my ($Title,$xlabel,$ylabel,$Max,$colors,$Xlabels,$Ydata,%Values)=@_;
6263: #
6264: # Create the identifier for the graph
6265: my $identifier = &get_cgi_id();
6266: my $id = 'cgi.'.$identifier;
6267: #
6268: $Title = '' if (! defined($Title));
6269: $xlabel = '' if (! defined($xlabel));
6270: $ylabel = '' if (! defined($ylabel));
6271: my %ValuesHash =
6272: (
1.369 www 6273: $id.'.title' => &escape($Title),
6274: $id.'.xlabel' => &escape($xlabel),
6275: $id.'.ylabel' => &escape($ylabel),
1.137 matthew 6276: $id.'.y_max_value'=> $Max,
6277: $id.'.labels' => join(',',@$Xlabels),
6278: $id.'.PlotType' => 'XY',
6279: );
6280: #
6281: if (defined($colors) && ref($colors) eq 'ARRAY') {
6282: $ValuesHash{$id.'.Colors'} = join(',',@{$colors});
6283: }
6284: #
6285: if (! ref($Ydata) || ref($Ydata) ne 'ARRAY') {
6286: return '';
6287: }
6288: my $NumSets=1;
1.138 matthew 6289: foreach my $array (@{$Ydata}){
1.137 matthew 6290: next if (! ref($array));
6291: $ValuesHash{$id.'.data.'.$NumSets++} = join(',',@$array);
6292: }
1.138 matthew 6293: $ValuesHash{$id.'.NumSets'} = $NumSets-1;
1.137 matthew 6294: #
6295: # Deal with other parameters
6296: while (my ($key,$value) = each(%Values)) {
6297: $ValuesHash{$id.'.'.$key} = $value;
1.127 matthew 6298: }
6299: #
1.136 matthew 6300: &Apache::lonnet::appenv(%ValuesHash);
6301: return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';
6302: }
6303:
6304: ############################################################
6305: ############################################################
6306:
6307: =pod
6308:
1.138 matthew 6309: =item DrawXYYGraph
6310:
6311: Facilitates the plotting of data in an XY graph with two Y axes.
6312: Puts plot definition data into the users environment in order for
6313: graph.png to plot it. Returns an <img> tag for the plot.
6314:
6315: Inputs:
6316:
6317: =over 4
6318:
6319: =item $Title: string, the title of the plot
6320:
6321: =item $xlabel: string, text describing the X-axis of the plot
6322:
6323: =item $ylabel: string, text describing the Y-axis of the plot
6324:
6325: =item $colors: Array ref containing the hex color codes for the data to be
6326: plotted in. If undefined, default values will be used.
6327:
6328: =item $Xlabels: Array ref containing the labels to be used for the X-axis.
6329:
6330: =item $Ydata1: The first data set
6331:
6332: =item $Min1: The minimum value of the left Y-axis
6333:
6334: =item $Max1: The maximum value of the left Y-axis
6335:
6336: =item $Ydata2: The second data set
6337:
6338: =item $Min2: The minimum value of the right Y-axis
6339:
6340: =item $Max2: The maximum value of the left Y-axis
6341:
6342: =item %Values: hash indicating or overriding any default values which are
6343: passed to graph.png.
6344: Possible values are: width, xskip, x_ticks, x_tick_offset, among others.
6345:
6346: =back
6347:
6348: Returns:
6349:
6350: An <img> tag which references graph.png and the appropriate identifying
6351: information for the plot.
1.136 matthew 6352:
6353: =cut
6354:
6355: ############################################################
6356: ############################################################
1.137 matthew 6357: sub DrawXYYGraph {
6358: my ($Title,$xlabel,$ylabel,$colors,$Xlabels,$Ydata1,$Min1,$Max1,
6359: $Ydata2,$Min2,$Max2,%Values)=@_;
1.136 matthew 6360: #
6361: # Create the identifier for the graph
6362: my $identifier = &get_cgi_id();
6363: my $id = 'cgi.'.$identifier;
6364: #
6365: $Title = '' if (! defined($Title));
6366: $xlabel = '' if (! defined($xlabel));
6367: $ylabel = '' if (! defined($ylabel));
6368: my %ValuesHash =
6369: (
1.369 www 6370: $id.'.title' => &escape($Title),
6371: $id.'.xlabel' => &escape($xlabel),
6372: $id.'.ylabel' => &escape($ylabel),
1.136 matthew 6373: $id.'.labels' => join(',',@$Xlabels),
6374: $id.'.PlotType' => 'XY',
6375: $id.'.NumSets' => 2,
1.137 matthew 6376: $id.'.two_axes' => 1,
6377: $id.'.y1_max_value' => $Max1,
6378: $id.'.y1_min_value' => $Min1,
6379: $id.'.y2_max_value' => $Max2,
6380: $id.'.y2_min_value' => $Min2,
1.136 matthew 6381: );
6382: #
1.137 matthew 6383: if (defined($colors) && ref($colors) eq 'ARRAY') {
6384: $ValuesHash{$id.'.Colors'} = join(',',@{$colors});
6385: }
6386: #
6387: if (! ref($Ydata1) || ref($Ydata1) ne 'ARRAY' ||
6388: ! ref($Ydata2) || ref($Ydata2) ne 'ARRAY'){
1.136 matthew 6389: return '';
6390: }
6391: my $NumSets=1;
1.137 matthew 6392: foreach my $array ($Ydata1,$Ydata2){
1.136 matthew 6393: next if (! ref($array));
6394: $ValuesHash{$id.'.data.'.$NumSets++} = join(',',@$array);
1.137 matthew 6395: }
6396: #
6397: # Deal with other parameters
6398: while (my ($key,$value) = each(%Values)) {
6399: $ValuesHash{$id.'.'.$key} = $value;
1.136 matthew 6400: }
6401: #
6402: &Apache::lonnet::appenv(%ValuesHash);
1.130 albertel 6403: return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';
1.139 matthew 6404: }
6405:
6406: ############################################################
6407: ############################################################
6408:
6409: =pod
6410:
1.157 matthew 6411: =back
6412:
1.139 matthew 6413: =head1 Statistics helper routines?
6414:
6415: Bad place for them but what the hell.
6416:
1.157 matthew 6417: =over 4
6418:
1.139 matthew 6419: =item &chartlink
6420:
6421: Returns a link to the chart for a specific student.
6422:
6423: Inputs:
6424:
6425: =over 4
6426:
6427: =item $linktext: The text of the link
6428:
6429: =item $sname: The students username
6430:
6431: =item $sdomain: The students domain
6432:
6433: =back
6434:
1.157 matthew 6435: =back
6436:
1.139 matthew 6437: =cut
6438:
6439: ############################################################
6440: ############################################################
6441: sub chartlink {
6442: my ($linktext, $sname, $sdomain) = @_;
6443: my $link = '<a href="/adm/statistics?reportSelected=student_assessment'.
1.369 www 6444: '&SelectedStudent='.&escape($sname.':'.$sdomain).
1.219 albertel 6445: '&chartoutputmode='.HTML::Entities::encode('html, with all links').
1.139 matthew 6446: '">'.$linktext.'</a>';
1.153 matthew 6447: }
6448:
6449: #######################################################
6450: #######################################################
6451:
6452: =pod
6453:
6454: =head1 Course Environment Routines
1.157 matthew 6455:
6456: =over 4
1.153 matthew 6457:
6458: =item &restore_course_settings
6459:
6460: =item &store_course_settings
6461:
6462: Restores/Store indicated form parameters from the course environment.
6463: Will not overwrite existing values of the form parameters.
6464:
6465: Inputs:
6466: a scalar describing the data (e.g. 'chart', 'problem_analysis')
6467:
6468: a hash ref describing the data to be stored. For example:
6469:
6470: %Save_Parameters = ('Status' => 'scalar',
6471: 'chartoutputmode' => 'scalar',
6472: 'chartoutputdata' => 'scalar',
6473: 'Section' => 'array',
1.373 raeburn 6474: 'Group' => 'array',
1.153 matthew 6475: 'StudentData' => 'array',
6476: 'Maps' => 'array');
6477:
6478: Returns: both routines return nothing
6479:
6480: =cut
6481:
6482: #######################################################
6483: #######################################################
6484: sub store_course_settings {
1.496 albertel 6485: return &store_settings($env{'request.course.id'},@_);
6486: }
6487:
6488: sub store_settings {
1.153 matthew 6489: # save to the environment
6490: # appenv the same items, just to be safe
1.300 albertel 6491: my $udom = $env{'user.domain'};
6492: my $uname = $env{'user.name'};
1.496 albertel 6493: my ($context,$prefix,$Settings) = @_;
1.153 matthew 6494: my %SaveHash;
6495: my %AppHash;
6496: while (my ($setting,$type) = each(%$Settings)) {
1.496 albertel 6497: my $basename = join('.','internal',$context,$prefix,$setting);
1.300 albertel 6498: my $envname = 'environment.'.$basename;
1.258 albertel 6499: if (exists($env{'form.'.$setting})) {
1.153 matthew 6500: # Save this value away
6501: if ($type eq 'scalar' &&
1.258 albertel 6502: (! exists($env{$envname}) ||
6503: $env{$envname} ne $env{'form.'.$setting})) {
6504: $SaveHash{$basename} = $env{'form.'.$setting};
6505: $AppHash{$envname} = $env{'form.'.$setting};
1.153 matthew 6506: } elsif ($type eq 'array') {
6507: my $stored_form;
1.258 albertel 6508: if (ref($env{'form.'.$setting})) {
1.153 matthew 6509: $stored_form = join(',',
6510: map {
1.369 www 6511: &escape($_);
1.258 albertel 6512: } sort(@{$env{'form.'.$setting}}));
1.153 matthew 6513: } else {
6514: $stored_form =
1.369 www 6515: &escape($env{'form.'.$setting});
1.153 matthew 6516: }
6517: # Determine if the array contents are the same.
1.258 albertel 6518: if ($stored_form ne $env{$envname}) {
1.153 matthew 6519: $SaveHash{$basename} = $stored_form;
6520: $AppHash{$envname} = $stored_form;
6521: }
6522: }
6523: }
6524: }
6525: my $put_result = &Apache::lonnet::put('environment',\%SaveHash,
1.300 albertel 6526: $udom,$uname);
1.153 matthew 6527: if ($put_result !~ /^(ok|delayed)/) {
6528: &Apache::lonnet::logthis('unable to save form parameters, '.
6529: 'got error:'.$put_result);
6530: }
6531: # Make sure these settings stick around in this session, too
6532: &Apache::lonnet::appenv(%AppHash);
6533: return;
6534: }
6535:
6536: sub restore_course_settings {
1.499 albertel 6537: return &restore_settings($env{'request.course.id'},@_);
1.496 albertel 6538: }
6539:
6540: sub restore_settings {
6541: my ($context,$prefix,$Settings) = @_;
1.153 matthew 6542: while (my ($setting,$type) = each(%$Settings)) {
1.258 albertel 6543: next if (exists($env{'form.'.$setting}));
1.496 albertel 6544: my $envname = 'environment.internal.'.$context.'.'.$prefix.
1.153 matthew 6545: '.'.$setting;
1.258 albertel 6546: if (exists($env{$envname})) {
1.153 matthew 6547: if ($type eq 'scalar') {
1.258 albertel 6548: $env{'form.'.$setting} = $env{$envname};
1.153 matthew 6549: } elsif ($type eq 'array') {
1.258 albertel 6550: $env{'form.'.$setting} = [
1.153 matthew 6551: map {
1.369 www 6552: &unescape($_);
1.258 albertel 6553: } split(',',$env{$envname})
1.153 matthew 6554: ];
6555: }
6556: }
6557: }
1.127 matthew 6558: }
6559:
6560: ############################################################
6561: ############################################################
1.154 albertel 6562:
1.443 albertel 6563: sub commit_customrole {
6564: my ($udom,$uname,$url,$three,$four,$five,$start,$end) = @_;
6565: my $output = &mt('Assigning custom role').' "'.$five.'" by '.$four.'@'.$three.' in '.$url.
6566: ($start?', '.&mt('starting').' '.localtime($start):'').
6567: ($end?', ending '.localtime($end):'').': <b>'.
6568: &Apache::lonnet::assigncustomrole(
6569: $udom,$uname,$url,$three,$four,$five,$end,$start).
6570: '</b><br />';
6571: return $output;
6572: }
6573:
6574: sub commit_standardrole {
1.541 raeburn 6575: my ($udom,$uname,$url,$three,$start,$end,$one,$two,$sec,$context) = @_;
6576: my ($output,$logmsg,$linefeed);
6577: if ($context eq 'auto') {
6578: $linefeed = "\n";
6579: } else {
6580: $linefeed = "<br />\n";
6581: }
1.443 albertel 6582: if ($three eq 'st') {
1.541 raeburn 6583: my $result = &commit_studentrole(\$logmsg,$udom,$uname,$url,$three,$start,$end,
6584: $one,$two,$sec,$context);
6585: if (($result =~ /^error/) || ($result eq 'not_in_class') ||
6586: ($result eq 'unknown_course')) {
1.443 albertel 6587: $output = "Error: $result\n";
6588: } else {
1.541 raeburn 6589: $output = $logmsg.$linefeed.&mt('Assigning').' '.$three.' in '.$url.
1.443 albertel 6590: ($start?', '.&mt('starting').' '.localtime($start):'').
1.541 raeburn 6591: ($end?', '.&mt('ending').' '.localtime($end):'').': ';
6592: if ($context eq 'auto') {
6593: $output .= $result.$linefeed.&mt('Add to classlist').': ok';
6594: } else {
6595: $output .= '<b>'.$result.'</b>'.$linefeed.
6596: &mt('Add to classlist').': <b>ok</b>';
6597: }
6598: $output .= $linefeed;
1.443 albertel 6599: }
6600: } else {
6601: $output = &mt('Assigning').' '.$three.' in '.$url.
6602: ($start?', '.&mt('starting').' '.localtime($start):'').
1.541 raeburn 6603: ($end?', '.&mt('ending').' '.localtime($end):'').': ';
6604: my $result = &Apache::lonnet::assignrole($udom,$uname,$url,$three,$end,$start);
6605: if ($context eq 'auto') {
6606: $output .= $result.$linefeed;
6607: } else {
6608: $output .= '<b>'.$result.'</b>'.$linefeed;
6609: }
1.443 albertel 6610: }
6611: return $output;
6612: }
6613:
6614: sub commit_studentrole {
1.541 raeburn 6615: my ($logmsg,$udom,$uname,$url,$three,$start,$end,$one,$two,$sec,$context) = @_;
6616: my ($result,$linefeed);
6617: if ($context eq 'auto') {
6618: $linefeed = "\n";
6619: } else {
6620: $linefeed = '<br />'."\n";
6621: }
1.443 albertel 6622: if (defined($one) && defined($two)) {
6623: my $cid=$one.'_'.$two;
6624: my $oldsec=&Apache::lonnet::getsection($udom,$uname,$cid);
6625: my $secchange = 0;
6626: my $expire_role_result;
6627: my $modify_section_result;
6628: unless ($oldsec eq '-1') {
6629: unless ($sec eq $oldsec) {
6630: $secchange = 1;
6631: my $uurl='/'.$cid;
6632: $uurl=~s/\_/\//g;
6633: if ($oldsec) {
6634: $uurl.='/'.$oldsec;
6635: }
6636: $expire_role_result = &Apache::lonnet::assignrole($udom,$uname,$uurl,'st',time);
6637: $result = $expire_role_result;
6638: }
6639: }
6640: if (($expire_role_result eq 'ok') || ($secchange == 0)) {
6641: $modify_section_result = &Apache::lonnet::modify_student_enrollment($udom,$uname,undef,undef,undef,undef,undef,$sec,$end,$start,'','',$cid);
6642: if ($modify_section_result =~ /^ok/) {
6643: if ($secchange == 1) {
6644: $$logmsg .= "Section for $uname switched from old section: $oldsec to new section: $sec".$linefeed;
6645: } elsif ($oldsec eq '-1') {
6646: $$logmsg .= "New student role for $uname in section $sec in course $cid".$linefeed;
6647: } else {
6648: $$logmsg .= "Student $uname assigned to unchanged section $sec in course $cid".$linefeed;
6649: }
6650: } else {
6651: $$logmsg .= "Error when attempting section change for $uname from old section $oldsec to new section: $sec in course $cid -error: $modify_section_result".$linefeed;
6652: }
6653: $result = $modify_section_result;
6654: } elsif ($secchange == 1) {
6655: $$logmsg .= "Error when attempting to expire role for $uname in old section $oldsec in course $cid -error: $expire_role_result".$linefeed;
6656: }
6657: } else {
6658: $$logmsg .= "Incomplete course id defined. Addition of user $uname from domain $udom to course $one\_$two, section $sec not completed.$linefeed";
6659: $result = "error: incomplete course id\n";
6660: }
6661: return $result;
6662: }
6663:
6664: ############################################################
6665: ############################################################
6666:
1.444 albertel 6667: sub construct_course {
1.541 raeburn 6668: my ($args,$logmsg,$courseid,$crsudom,$crsunum,$udom,$uname,$context) = @_;
1.444 albertel 6669: my $outcome;
1.541 raeburn 6670: my $linefeed = '<br />'."\n";
6671: if ($context eq 'auto') {
6672: $linefeed = "\n";
6673: }
1.444 albertel 6674: #
6675: # Open course
6676: #
6677: my $crstype = lc($args->{'crstype'});
6678: my %cenv=();
6679: $$courseid=&Apache::lonnet::createcourse($args->{'course_domain'},
6680: $args->{'cdescr'},
6681: $args->{'curl'},
6682: $args->{'course_home'},
6683: $args->{'nonstandard'},
6684: $args->{'crscode'},
6685: $args->{'ccuname'}.':'.
6686: $args->{'ccdomain'},
6687: $args->{'crstype'});
6688:
6689: # Note: The testing routines depend on this being output; see
6690: # Utils::Course. This needs to at least be output as a comment
6691: # if anyone ever decides to not show this, and Utils::Course::new
6692: # will need to be suitably modified.
1.541 raeburn 6693: $outcome .= &mt('New LON-CAPA [_1] ID: [_2]',$crstype,$$courseid).$linefeed;
6694:
1.444 albertel 6695: #
6696: # Check if created correctly
6697: #
1.479 albertel 6698: ($$crsudom,$$crsunum)= &LONCAPA::split_courseid($$courseid);
1.444 albertel 6699: my $crsuhome=&Apache::lonnet::homeserver($$crsunum,$$crsudom);
1.541 raeburn 6700: $outcome .= &mt('Created on').': '.$crsuhome.$linefeed;
1.444 albertel 6701: #
6702: # Are we cloning?
6703: #
6704: my $cloneid='';
6705: if (($args->{'clonecourse'}) && ($args->{'clonedomain'})) {
1.541 raeburn 6706: my $can_clone = 0;
1.444 albertel 6707: $cloneid='/'.$args->{'clonedomain'}.'/'.$args->{'clonecourse'};
1.479 albertel 6708: my ($clonecrsudom,$clonecrsunum)= &LONCAPA::split_courseid($cloneid);
1.444 albertel 6709: my $clonehome=&Apache::lonnet::homeserver($clonecrsunum,$clonecrsudom);
1.541 raeburn 6710: my $clonemsg;
1.444 albertel 6711: if ($clonehome eq 'no_host') {
1.541 raeburn 6712: $clonemsg = &mt('Attempting to clone non-existing [_1]',$crstype);
6713: if ($context eq 'auto') {
6714: $outcome .= $clonemsg;
6715: } else {
6716: $outcome .= '<font color="red">'.$clonemsg.'</font>';
6717: }
6718: $outcome .= $linefeed;
1.444 albertel 6719: } else {
1.541 raeburn 6720: my %clonedesc = &Apache::lonnet::coursedescription($cloneid,{'one_time' => 1});
6721: if ($env{'request.role.domain'} eq $args->{'form.clonedomain'}) {
6722: $can_clone = 1;
6723: } else {
6724: my %clonehash = &Apache::lonnet::get('environment',['cloners'],
6725: $args->{'clonedomain'},$args->{'clonecourse'});
6726: my @cloners = split(/,/,$clonehash{'cloners'});
6727: my %roleshash =
6728: &Apache::lonnet::get_my_roles($args->{'ccuname'},
6729: $args->{'ccdomain'},'userroles',['active'],['cc'],
6730: [$args->{'clonedomain'}]);
6731: if (($roleshash{$args->{'clonecourse'}.':'.$args->{'clonedomain'}.':cc'}) || (grep(/^\Q$args->{'ccuname'}\E:\Q$args->{'ccdomain'}\E$/,@cloners))) {
6732: $can_clone = 1;
6733: } else {
6734: $clonemsg = &mt('The new course was not cloned from an existing course because the course owner ([_1]) does not have cloning rights in the existing course ([_2]).',$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'});
6735: if ($context eq 'auto') {
6736: $outcome .= $clonemsg;
6737: } else {
6738: $outcome .= '<font color="red">'.$clonemsg.'</font>';
6739: }
6740: $outcome .= $linefeed;
6741: }
6742: }
6743: }
6744: if ($can_clone) {
6745: $clonemsg = &mt('Cloning [_1] from [_2]',$crstype,$clonehome);
6746: if ($context eq 'auto') {
6747: $outcome = $clonemsg;
6748: } else {
6749: $outcome .= '<font color="green">'.$clonemsg.'</font>';
6750: }
6751: $outcome .= $linefeed;
1.444 albertel 6752: my %oldcenv=&Apache::lonnet::dump('environment',$$crsudom,$$crsunum);
6753: # Copy all files
6754: &Apache::lonclonecourse::copycoursefiles($cloneid,$$courseid);
6755: # Restore URL
6756: $cenv{'url'}=$oldcenv{'url'};
6757: # Restore title
6758: $cenv{'description'}=$oldcenv{'description'};
6759: # restore grading mode
6760: if (defined($oldcenv{'grading'})) {
6761: $cenv{'grading'}=$oldcenv{'grading'};
6762: }
6763: # Mark as cloned
6764: $cenv{'clonedfrom'}=$cloneid;
6765: delete($cenv{'default_enrollment_start_date'});
6766: delete($cenv{'default_enrollment_end_date'});
6767: }
6768: }
6769: #
6770: # Set environment (will override cloned, if existing)
6771: #
6772: my @sections = ();
6773: my @xlists = ();
6774: if ($args->{'crstype'}) {
6775: $cenv{'type'}=$args->{'crstype'};
6776: }
6777: if ($args->{'crsid'}) {
6778: $cenv{'courseid'}=$args->{'crsid'};
6779: }
6780: if ($args->{'crscode'}) {
6781: $cenv{'internal.coursecode'}=$args->{'crscode'};
6782: }
6783: if ($args->{'crsquota'} ne '') {
6784: $cenv{'internal.coursequota'}=$args->{'crsquota'};
6785: } else {
6786: $cenv{'internal.coursequota'}=$args->{'crsquota'} = 20;
6787: }
6788: if ($args->{'ccuname'}) {
6789: $cenv{'internal.courseowner'} = $args->{'ccuname'}.
6790: ':'.$args->{'ccdomain'};
6791: } else {
6792: $cenv{'internal.courseowner'} = $args->{'curruser'};
6793: }
6794:
6795: my @badclasses = (); # Used to accumulate sections/crosslistings that did not pass classlist access check for course owner.
6796: if ($args->{'crssections'}) {
6797: $cenv{'internal.sectionnums'} = '';
6798: if ($args->{'crssections'} =~ m/,/) {
6799: @sections = split/,/,$args->{'crssections'};
6800: } else {
6801: $sections[0] = $args->{'crssections'};
6802: }
6803: if (@sections > 0) {
6804: foreach my $item (@sections) {
6805: my ($sec,$gp) = split/:/,$item;
6806: my $class = $args->{'crscode'}.$sec;
6807: my $addcheck = &Apache::lonnet::auto_new_course($$crsunum,$$crsudom,$class,$cenv{'internal.courseowner'});
6808: $cenv{'internal.sectionnums'} .= $item.',';
6809: unless ($addcheck eq 'ok') {
6810: push @badclasses, $class;
6811: }
6812: }
6813: $cenv{'internal.sectionnums'} =~ s/,$//;
6814: }
6815: }
6816: # do not hide course coordinator from staff listing,
6817: # even if privileged
6818: $cenv{'nothideprivileged'}=$args->{'ccuname'}.':'.$args->{'ccdomain'};
6819: # add crosslistings
6820: if ($args->{'crsxlist'}) {
6821: $cenv{'internal.crosslistings'}='';
6822: if ($args->{'crsxlist'} =~ m/,/) {
6823: @xlists = split/,/,$args->{'crsxlist'};
6824: } else {
6825: $xlists[0] = $args->{'crsxlist'};
6826: }
6827: if (@xlists > 0) {
6828: foreach my $item (@xlists) {
6829: my ($xl,$gp) = split/:/,$item;
6830: my $addcheck = &Apache::lonnet::auto_new_course($$crsunum,$$crsudom,$xl,$cenv{'internal.courseowner'});
6831: $cenv{'internal.crosslistings'} .= $item.',';
6832: unless ($addcheck eq 'ok') {
6833: push @badclasses, $xl;
6834: }
6835: }
6836: $cenv{'internal.crosslistings'} =~ s/,$//;
6837: }
6838: }
6839: if ($args->{'autoadds'}) {
6840: $cenv{'internal.autoadds'}=$args->{'autoadds'};
6841: }
6842: if ($args->{'autodrops'}) {
6843: $cenv{'internal.autodrops'}=$args->{'autodrops'};
6844: }
6845: # check for notification of enrollment changes
6846: my @notified = ();
6847: if ($args->{'notify_owner'}) {
6848: if ($args->{'ccuname'} ne '') {
6849: push(@notified,$args->{'ccuname'}.':'.$args->{'ccdomain'});
6850: }
6851: }
6852: if ($args->{'notify_dc'}) {
6853: if ($uname ne '') {
6854: push(@notified,$uname.'@'.$udom);
6855: }
6856: }
6857: if (@notified > 0) {
6858: my $notifylist;
6859: if (@notified > 1) {
6860: $notifylist = join(',',@notified);
6861: } else {
6862: $notifylist = $notified[0];
6863: }
6864: $cenv{'internal.notifylist'} = $notifylist;
6865: }
6866: if (@badclasses > 0) {
6867: my %lt=&Apache::lonlocal::texthash(
6868: 'tclb' => 'The courses listed below were included as sections or crosslistings affiliated with your new LON-CAPA course. However, if automated course roster updates are enabled for this class, these particular sections/crosslistings will not contribute towards enrollment, because the user identified as the course owner for this LON-CAPA course',
6869: 'dnhr' => 'does not have rights to access enrollment in these classes',
6870: 'adby' => 'as determined by the policies of your institution on access to official classlists'
6871: );
1.541 raeburn 6872: my $badclass_msg = $cenv{'internal.courseowner'}.') - '.$lt{'dnhr'}.
6873: ' ('.$lt{'adby'}.')';
6874: if ($context eq 'auto') {
6875: $outcome .= $badclass_msg.$linefeed;
6876: $outcome .= '<font color="red">'.$badclass_msg.$linefeed.'<ul>'."\n";
6877: foreach my $item (@badclasses) {
6878: if ($context eq 'auto') {
6879: $outcome .= " - $item\n";
6880: } else {
6881: $outcome .= "<li>$item</li>\n";
6882: }
6883: }
6884: if ($context eq 'auto') {
6885: $outcome .= $linefeed;
6886: } else {
6887: $outcome .= "</ul><br /><br /></font>\n";
6888: }
6889: }
1.444 albertel 6890: }
6891: if ($args->{'no_end_date'}) {
6892: $args->{'endaccess'} = 0;
6893: }
6894: $cenv{'internal.autostart'}=$args->{'enrollstart'};
6895: $cenv{'internal.autoend'}=$args->{'enrollend'};
6896: $cenv{'default_enrollment_start_date'}=$args->{'startaccess'};
6897: $cenv{'default_enrollment_end_date'}=$args->{'endaccess'};
6898: if ($args->{'showphotos'}) {
6899: $cenv{'internal.showphotos'}=$args->{'showphotos'};
6900: }
6901: $cenv{'internal.authtype'} = $args->{'authtype'};
6902: $cenv{'internal.autharg'} = $args->{'autharg'};
6903: if ( ($cenv{'internal.authtype'} =~ /^krb/) && ($cenv{'internal.autoadds'} == 1)) {
6904: if (! defined($cenv{'internal.autharg'}) || $cenv{'internal.autharg'} eq '') {
1.541 raeburn 6905: my $krb_msg = &mt('As you did not include the default Kerberos domain to be used for authentication in this class, the institutional data used by the automated enrollment process must include the Kerberos domain for each new student');
6906: if ($context eq 'auto') {
6907: $outcome .= $krb_msg;
6908: } else {
6909: $outcome .= '<font color="red" size="+1">'.$krb_msg.'</font>';
6910: }
6911: $outcome .= $linefeed;
1.444 albertel 6912: }
6913: }
6914: if (($args->{'ccdomain'}) && ($args->{'ccuname'})) {
6915: if ($args->{'setpolicy'}) {
6916: $cenv{'policy.email'}=$args->{'ccuname'}.':'.$args->{'ccdomain'};
6917: }
6918: if ($args->{'setcontent'}) {
6919: $cenv{'question.email'}=$args->{'ccuname'}.':'.$args->{'ccdomain'};
6920: }
6921: }
6922: if ($args->{'reshome'}) {
6923: $cenv{'reshome'}=$args->{'reshome'}.'/';
6924: $cenv{'reshome'}=~s/\/+$/\//;
6925: }
6926: #
6927: # course has keyed access
6928: #
6929: if ($args->{'setkeys'}) {
6930: $cenv{'keyaccess'}='yes';
6931: }
6932: # if specified, key authority is not course, but user
6933: # only active if keyaccess is yes
6934: if ($args->{'keyauth'}) {
1.487 albertel 6935: my ($user,$domain) = split(':',$args->{'keyauth'});
6936: $user = &LONCAPA::clean_username($user);
6937: $domain = &LONCAPA::clean_username($domain);
1.488 foxr 6938: if ($user ne '' && $domain ne '') {
1.487 albertel 6939: $cenv{'keyauth'}=$user.':'.$domain;
1.444 albertel 6940: }
6941: }
6942:
6943: if ($args->{'disresdis'}) {
6944: $cenv{'pch.roles.denied'}='st';
6945: }
6946: if ($args->{'disablechat'}) {
6947: $cenv{'plc.roles.denied'}='st';
6948: }
6949:
6950: # Record we've not yet viewed the Course Initialization Helper for this
6951: # course
6952: $cenv{'course.helper.not.run'} = 1;
6953: #
6954: # Use new Randomseed
6955: #
6956: $cenv{'rndseed'}=&Apache::lonnet::latest_rnd_algorithm_id();;
6957: $cenv{'receiptalg'}=&Apache::lonnet::latest_receipt_algorithm_id();;
6958: #
6959: # The encryption code and receipt prefix for this course
6960: #
6961: $cenv{'internal.encseed'}=$Apache::lonnet::perlvar{'lonReceipt'}.$$.time.int(rand(9999));
6962: $cenv{'internal.encpref'}=100+int(9*rand(99));
6963: #
6964: # By default, use standard grading
6965: if (!defined($cenv{'grading'})) { $cenv{'grading'} = 'standard'; }
6966:
1.541 raeburn 6967: $outcome .= $linefeed.&mt('Setting environment').': '.
6968: &Apache::lonnet::put('environment',\%cenv,$$crsudom,$$crsunum).$linefeed;
1.444 albertel 6969: #
6970: # Open all assignments
6971: #
6972: if ($args->{'openall'}) {
6973: my $storeunder=$$crsudom.'_'.$$crsunum.'.0.opendate';
6974: my %storecontent = ($storeunder => time,
6975: $storeunder.'.type' => 'date_start');
6976:
6977: $outcome .= &mt('Opening all assignments').': '.&Apache::lonnet::cput
1.541 raeburn 6978: ('resourcedata',\%storecontent,$$crsudom,$$crsunum).$linefeed;
1.444 albertel 6979: }
6980: #
6981: # Set first page
6982: #
6983: unless (($args->{'nonstandard'}) || ($args->{'firstres'} eq 'blank')
6984: || ($cloneid)) {
1.445 albertel 6985: use LONCAPA::map;
1.444 albertel 6986: $outcome .= &mt('Setting first resource').': ';
1.445 albertel 6987:
6988: my $map = '/uploaded/'.$$crsudom.'/'.$$crsunum.'/default.sequence';
6989: my ($errtext,$fatal)=&LONCAPA::map::mapread($map);
6990:
1.444 albertel 6991: $outcome .= ($fatal?$errtext:'read ok').' - ';
6992: my $title; my $url;
6993: if ($args->{'firstres'} eq 'syl') {
6994: $title='Syllabus';
6995: $url='/public/'.$$crsudom.'/'.$$crsunum.'/syllabus';
6996: } else {
6997: $title='Navigate Contents';
6998: $url='/adm/navmaps';
6999: }
1.445 albertel 7000:
7001: $LONCAPA::map::resources[1]=$title.':'.$url.':false:start:res';
7002: (my $outtext,$errtext) = &LONCAPA::map::storemap($map,1);
7003:
7004: if ($errtext) { $fatal=2; }
1.541 raeburn 7005: $outcome .= ($fatal?$errtext:'write ok').$linefeed;
1.444 albertel 7006: }
7007: return $outcome;
7008: }
7009:
7010: ############################################################
7011: ############################################################
7012:
1.378 raeburn 7013: sub course_type {
7014: my ($cid) = @_;
7015: if (!defined($cid)) {
7016: $cid = $env{'request.course.id'};
7017: }
1.404 albertel 7018: if (defined($env{'course.'.$cid.'.type'})) {
7019: return $env{'course.'.$cid.'.type'};
1.378 raeburn 7020: } else {
7021: return 'Course';
1.377 raeburn 7022: }
7023: }
1.156 albertel 7024:
1.406 raeburn 7025: sub group_term {
7026: my $crstype = &course_type();
7027: my %names = (
7028: 'Course' => 'group',
7029: 'Group' => 'team',
7030: );
7031: return $names{$crstype};
7032: }
7033:
1.156 albertel 7034: sub icon {
7035: my ($file)=@_;
1.505 albertel 7036: my $curfext = lc((split(/\./,$file))[-1]);
1.168 albertel 7037: my $iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/unknown.gif';
1.156 albertel 7038: my $embstyle = &Apache::loncommon::fileembstyle($curfext);
1.168 albertel 7039: if (!(!defined($embstyle) || $embstyle eq 'unk' || $embstyle eq 'hdn')) {
7040: if (-e $Apache::lonnet::perlvar{'lonDocRoot'}.'/'.
7041: $Apache::lonnet::perlvar{'lonIconsURL'}.'/'.
7042: $curfext.".gif") {
7043: $iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/'.
7044: $curfext.".gif";
7045: }
7046: }
1.249 albertel 7047: return &lonhttpdurl($iconname);
1.154 albertel 7048: }
1.84 albertel 7049:
1.215 albertel 7050: sub lonhttpdurl {
7051: my ($url)=@_;
7052: my $lonhttpd_port=$Apache::lonnet::perlvar{'lonhttpdPort'};
7053: if (!defined($lonhttpd_port)) { $lonhttpd_port='8080'; }
7054: return 'http://'.$ENV{'SERVER_NAME'}.':'.$lonhttpd_port.$url;
7055: }
7056:
1.213 albertel 7057: sub connection_aborted {
7058: my ($r)=@_;
7059: $r->print(" ");$r->rflush();
7060: my $c = $r->connection;
7061: return $c->aborted();
7062: }
7063:
1.221 foxr 7064: # Escapes strings that may have embedded 's that will be put into
1.222 foxr 7065: # strings as 'strings'.
7066: sub escape_single {
1.221 foxr 7067: my ($input) = @_;
1.223 albertel 7068: $input =~ s/\\/\\\\/g; # Escape the \'s..(must be first)>
1.221 foxr 7069: $input =~ s/\'/\\\'/g; # Esacpe the 's....
7070: return $input;
7071: }
1.223 albertel 7072:
1.222 foxr 7073: # Same as escape_single, but escape's "'s This
7074: # can be used for "strings"
7075: sub escape_double {
7076: my ($input) = @_;
7077: $input =~ s/\\/\\\\/g; # Escape the /'s..(must be first)>
7078: $input =~ s/\"/\\\"/g; # Esacpe the "s....
7079: return $input;
7080: }
1.223 albertel 7081:
1.222 foxr 7082: # Escapes the last element of a full URL.
7083: sub escape_url {
7084: my ($url) = @_;
1.238 raeburn 7085: my @urlslices = split(/\//, $url,-1);
1.369 www 7086: my $lastitem = &escape(pop(@urlslices));
1.223 albertel 7087: return join('/',@urlslices).'/'.$lastitem;
1.222 foxr 7088: }
1.462 albertel 7089:
7090: # -------------------------------------------------------- Initliaze user login
7091: sub init_user_environment {
1.463 albertel 7092: my ($r, $username, $domain, $authhost, $form, $args) = @_;
1.462 albertel 7093: my $lonids=$Apache::lonnet::perlvar{'lonIDsDir'};
7094:
7095: my $public=($username eq 'public' && $domain eq 'public');
7096:
7097: # See if old ID present, if so, remove
7098:
7099: my ($filename,$cookie,$userroles);
7100: my $now=time;
7101:
7102: if ($public) {
7103: my $max_public=100;
7104: my $oldest;
7105: my $oldest_time=0;
7106: for(my $next=1;$next<=$max_public;$next++) {
7107: if (-e $lonids."/publicuser_$next.id") {
7108: my $mtime=(stat($lonids."/publicuser_$next.id"))[9];
7109: if ($mtime<$oldest_time || !$oldest_time) {
7110: $oldest_time=$mtime;
7111: $oldest=$next;
7112: }
7113: } else {
7114: $cookie="publicuser_$next";
7115: last;
7116: }
7117: }
7118: if (!$cookie) { $cookie="publicuser_$oldest"; }
7119: } else {
1.463 albertel 7120: # if this isn't a robot, kill any existing non-robot sessions
7121: if (!$args->{'robot'}) {
7122: opendir(DIR,$lonids);
7123: while ($filename=readdir(DIR)) {
7124: if ($filename=~/^$username\_\d+\_$domain\_$authhost\.id$/) {
7125: unlink($lonids.'/'.$filename);
7126: }
1.462 albertel 7127: }
1.463 albertel 7128: closedir(DIR);
1.462 albertel 7129: }
7130: # Give them a new cookie
1.463 albertel 7131: my $id = ($args->{'robot'} ? 'robot'.$args->{'robot'}
7132: : $now);
7133: $cookie="$username\_$id\_$domain\_$authhost";
1.462 albertel 7134:
7135: # Initialize roles
7136:
7137: $userroles=&Apache::lonnet::rolesinit($domain,$username,$authhost);
7138: }
7139: # ------------------------------------ Check browser type and MathML capability
7140:
7141: my ($httpbrowser,$clientbrowser,$clientversion,$clientmathml,
7142: $clientunicode,$clientos) = &decode_user_agent($r);
7143:
7144: # -------------------------------------- Any accessibility options to remember?
7145: if (($form->{'interface'}) && ($form->{'remember'} eq 'true')) {
7146: foreach my $option ('imagesuppress','appletsuppress',
7147: 'embedsuppress','fontenhance','blackwhite') {
7148: if ($form->{$option} eq 'true') {
7149: &Apache::lonnet::put('environment',{$option => 'on'},
7150: $domain,$username);
7151: } else {
7152: &Apache::lonnet::del('environment',[$option],
7153: $domain,$username);
7154: }
7155: }
7156: }
7157: # ------------------------------------------------------------- Get environment
7158:
7159: my %userenv = &Apache::lonnet::dump('environment',$domain,$username);
7160: my ($tmp) = keys(%userenv);
7161: if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
7162: # default remote control to off
7163: if ($userenv{'remote'} ne 'on') { $userenv{'remote'} = 'off'; }
7164: } else {
7165: undef(%userenv);
7166: }
7167: if (($userenv{'interface'}) && (!$form->{'interface'})) {
7168: $form->{'interface'}=$userenv{'interface'};
7169: }
7170: $env{'environment.remote'}=$userenv{'remote'};
7171: if ($userenv{'texengine'} eq 'ttm') { $clientmathml=1; }
7172:
7173: # --------------- Do not trust query string to be put directly into environment
7174: foreach my $option ('imagesuppress','appletsuppress',
7175: 'embedsuppress','fontenhance','blackwhite',
7176: 'interface','localpath','localres') {
7177: $form->{$option}=~s/[\n\r\=]//gs;
7178: }
7179: # --------------------------------------------------------- Write first profile
7180:
7181: {
7182: my %initial_env =
7183: ("user.name" => $username,
7184: "user.domain" => $domain,
7185: "user.home" => $authhost,
7186: "browser.type" => $clientbrowser,
7187: "browser.version" => $clientversion,
7188: "browser.mathml" => $clientmathml,
7189: "browser.unicode" => $clientunicode,
7190: "browser.os" => $clientos,
7191: "server.domain" => $Apache::lonnet::perlvar{'lonDefDomain'},
7192: "request.course.fn" => '',
7193: "request.course.uri" => '',
7194: "request.course.sec" => '',
7195: "request.role" => 'cm',
7196: "request.role.adv" => $env{'user.adv'},
7197: "request.host" => $ENV{'REMOTE_ADDR'},);
7198:
7199: if ($form->{'localpath'}) {
7200: $initial_env{"browser.localpath"} = $form->{'localpath'};
7201: $initial_env{"browser.localres"} = $form->{'localres'};
7202: }
7203:
7204: if ($public) {
7205: $initial_env{"environment.remote"} = "off";
7206: }
7207: if ($form->{'interface'}) {
7208: $form->{'interface'}=~s/\W//gs;
7209: $initial_env{"browser.interface"} = $form->{'interface'};
7210: $env{'browser.interface'}=$form->{'interface'};
7211: foreach my $option ('imagesuppress','appletsuppress',
7212: 'embedsuppress','fontenhance','blackwhite') {
7213: if (($form->{$option} eq 'true') ||
7214: ($userenv{$option} eq 'on')) {
7215: $initial_env{"browser.$option"} = "on";
7216: }
7217: }
7218: }
7219:
7220: $env{'user.environment'} = "$lonids/$cookie.id";
7221:
7222: if (tie(my %disk_env,'GDBM_File',"$lonids/$cookie.id",
7223: &GDBM_WRCREAT(),0640)) {
7224: &_add_to_env(\%disk_env,\%initial_env);
7225: &_add_to_env(\%disk_env,\%userenv,'environment.');
7226: &_add_to_env(\%disk_env,$userroles);
1.463 albertel 7227: if (ref($args->{'extra_env'})) {
7228: &_add_to_env(\%disk_env,$args->{'extra_env'});
7229: }
1.462 albertel 7230: untie(%disk_env);
7231: } else {
7232: &Apache::lonnet::logthis("<font color=\"blue\">WARNING: ".
7233: 'Could not create environment storage in lonauth: '.$!.'</font>');
7234: return 'error: '.$!;
7235: }
7236: }
7237: $env{'request.role'}='cm';
7238: $env{'request.role.adv'}=$env{'user.adv'};
7239: $env{'browser.type'}=$clientbrowser;
7240:
7241: return $cookie;
7242:
7243: }
7244:
7245: sub _add_to_env {
7246: my ($idf,$env_data,$prefix) = @_;
7247: while (my ($key,$value) = each(%$env_data)) {
7248: $idf->{$prefix.$key} = $value;
7249: $env{$prefix.$key} = $value;
7250: }
7251: }
7252:
7253:
1.41 ng 7254: =pod
7255:
7256: =back
7257:
1.112 bowersj2 7258: =cut
1.41 ng 7259:
1.112 bowersj2 7260: 1;
7261: __END__;
1.41 ng 7262:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to loncommon.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / interface