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