Annotation of loncom/interface/loncommon.pm, revision 1.645
1.10 albertel 1: # The LearningOnline Network with CAPA
1.1 albertel 2: # a pile of common routines
1.10 albertel 3: #
1.645 ! raeburn 4: # $Id: loncommon.pm,v 1.644 2008/03/03 16:41:42 www Exp $
1.10 albertel 5: #
6: # Copyright Michigan State University Board of Trustees
7: #
8: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
9: #
10: # LON-CAPA is free software; you can redistribute it and/or modify
11: # it under the terms of the GNU General Public License as published by
12: # the Free Software Foundation; either version 2 of the License, or
13: # (at your option) any later version.
14: #
15: # LON-CAPA is distributed in the hope that it will be useful,
16: # but WITHOUT ANY WARRANTY; without even the implied warranty of
17: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18: # GNU General Public License for more details.
19: #
20: # You should have received a copy of the GNU General Public License
21: # along with LON-CAPA; if not, write to the Free Software
22: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
23: #
24: # /home/httpd/html/adm/gpl.txt
25: #
26: # http://www.lon-capa.org/
27: #
1.1 albertel 28:
29: # Makes a table out of the previous attempts
1.2 albertel 30: # Inputs result_from_symbread, user, domain, course_id
1.16 harris41 31: # Reads in non-network-related .tab files
1.1 albertel 32:
1.35 matthew 33: # POD header:
34:
1.45 matthew 35: =pod
36:
1.35 matthew 37: =head1 NAME
38:
39: Apache::loncommon - pile of common routines
40:
41: =head1 SYNOPSIS
42:
1.112 bowersj2 43: Common routines for manipulating connections, student answers,
44: domains, common Javascript fragments, etc.
1.35 matthew 45:
1.112 bowersj2 46: =head1 OVERVIEW
1.35 matthew 47:
1.112 bowersj2 48: A collection of commonly used subroutines that don't have a natural
49: home anywhere else. This collection helps remove
1.35 matthew 50: redundancy from other modules and increase efficiency of memory usage.
51:
52: =cut
53:
54: # End of POD header
1.1 albertel 55: package Apache::loncommon;
56:
57: use strict;
1.258 albertel 58: use Apache::lonnet;
1.46 matthew 59: use GDBM_File;
1.51 www 60: use POSIX qw(strftime mktime);
1.82 www 61: use Apache::lonmenu();
1.498 albertel 62: use Apache::lonenc();
1.117 www 63: use Apache::lonlocal;
1.139 matthew 64: use HTML::Entities;
1.334 albertel 65: use Apache::lonhtmlcommon();
66: use Apache::loncoursedata();
1.344 albertel 67: use Apache::lontexconvert();
1.444 albertel 68: use Apache::lonclonecourse();
1.479 albertel 69: use LONCAPA qw(:DEFAULT :match);
1.117 www 70:
1.517 raeburn 71: # ---------------------------------------------- Designs
72: use vars qw(%defaultdesign);
73:
1.22 www 74: my $readit;
75:
1.517 raeburn 76:
1.157 matthew 77: ##
78: ## Global Variables
79: ##
1.46 matthew 80:
1.643 foxr 81:
82: # ----------------------------------------------- SSI with retries:
83: #
84:
85: =pod
86:
87: =head1 Server Side incliude with retries:
88:
89: =over 4
90:
91: =item * ssi_with_retries(resource, retries form)
92:
93: Performs an ssi with some number of retries. Retries continue either
94: until the result is ok or until the retry count supplied by the
95: caller is exhausted.
96:
97: Inputs:
98: resource - Identifies the resource to insert.
99: retries - Count of the number of retries allowed.
100: form - Hash that identifies the rendering options.
101:
102: Returns:
103: content - The content of the response. If retries were exhausted this is empty.
104: response - The response from the last attempt (which may or may not have been successful.
105:
106: =cut
107:
108: sub ssi_with_retries {
109: my ($resource, $retries, %form) = @_;
110:
111:
112: my $ok = 0; # True if we got a good response.
113: my $content;
114: my $response;
115:
116: # Try to get the ssi done. within the retries count:
117:
118: do {
119: ($content, $response) = &Apache::lonnet::ssi($resource, %form);
120: $ok = $response->is_success;
121: $retries--;
122: } while (!$ok && ($retries > 0));
123:
124: if (!$ok) {
125: $content = ''; # On error return an empty content.
126: }
127: return ($content, $response);
128:
129: }
130:
131:
132:
1.20 www 133: # ----------------------------------------------- Filetypes/Languages/Copyright
1.12 harris41 134: my %language;
1.124 www 135: my %supported_language;
1.12 harris41 136: my %cprtag;
1.192 taceyjo1 137: my %scprtag;
1.351 www 138: my %fe; my %fd; my %fm;
1.41 ng 139: my %category_extensions;
1.12 harris41 140:
1.46 matthew 141: # ---------------------------------------------- Thesaurus variables
1.144 matthew 142: #
143: # %Keywords:
144: # A hash used by &keyword to determine if a word is considered a keyword.
145: # $thesaurus_db_file
146: # Scalar containing the full path to the thesaurus database.
1.46 matthew 147:
148: my %Keywords;
149: my $thesaurus_db_file;
150:
1.144 matthew 151: #
152: # Initialize values from language.tab, copyright.tab, filetypes.tab,
153: # thesaurus.tab, and filecategories.tab.
154: #
1.18 www 155: BEGIN {
1.46 matthew 156: # Variable initialization
157: $thesaurus_db_file = $Apache::lonnet::perlvar{'lonTabDir'}."/thesaurus.db";
158: #
1.22 www 159: unless ($readit) {
1.12 harris41 160: # ------------------------------------------------------------------- languages
161: {
1.158 raeburn 162: my $langtabfile = $Apache::lonnet::perlvar{'lonTabDir'}.
163: '/language.tab';
164: if ( open(my $fh,"<$langtabfile") ) {
1.356 albertel 165: while (my $line = <$fh>) {
166: next if ($line=~/^\#/);
167: chomp($line);
168: my ($key,$two,$country,$three,$enc,$val,$sup)=(split(/\t/,$line));
1.158 raeburn 169: $language{$key}=$val.' - '.$enc;
170: if ($sup) {
171: $supported_language{$key}=$sup;
172: }
173: }
174: close($fh);
175: }
1.12 harris41 176: }
177: # ------------------------------------------------------------------ copyrights
178: {
1.158 raeburn 179: my $copyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.
180: '/copyright.tab';
181: if ( open (my $fh,"<$copyrightfile") ) {
1.356 albertel 182: while (my $line = <$fh>) {
183: next if ($line=~/^\#/);
184: chomp($line);
185: my ($key,$val)=(split(/\s+/,$line,2));
1.158 raeburn 186: $cprtag{$key}=$val;
187: }
188: close($fh);
189: }
1.12 harris41 190: }
1.351 www 191: # ----------------------------------------------------------- source copyrights
1.192 taceyjo1 192: {
193: my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.
194: '/source_copyright.tab';
195: if ( open (my $fh,"<$sourcecopyrightfile") ) {
1.356 albertel 196: while (my $line = <$fh>) {
197: next if ($line =~ /^\#/);
198: chomp($line);
199: my ($key,$val)=(split(/\s+/,$line,2));
1.192 taceyjo1 200: $scprtag{$key}=$val;
201: }
202: close($fh);
203: }
204: }
1.63 www 205:
1.517 raeburn 206: # -------------------------------------------------------------- default domain designs
1.63 www 207: my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors';
1.517 raeburn 208: my $designfile = $designdir.'/default.tab';
209: if ( open (my $fh,"<$designfile") ) {
210: while (my $line = <$fh>) {
211: next if ($line =~ /^\#/);
212: chomp($line);
213: my ($key,$val)=(split(/\=/,$line));
214: if ($val) { $defaultdesign{$key}=$val; }
215: }
216: close($fh);
1.63 www 217: }
218:
1.15 harris41 219: # ------------------------------------------------------------- file categories
220: {
1.158 raeburn 221: my $categoryfile = $Apache::lonnet::perlvar{'lonTabDir'}.
222: '/filecategories.tab';
223: if ( open (my $fh,"<$categoryfile") ) {
1.356 albertel 224: while (my $line = <$fh>) {
225: next if ($line =~ /^\#/);
226: chomp($line);
227: my ($extension,$category)=(split(/\s+/,$line,2));
1.158 raeburn 228: push @{$category_extensions{lc($category)}},$extension;
229: }
230: close($fh);
231: }
232:
1.15 harris41 233: }
1.12 harris41 234: # ------------------------------------------------------------------ file types
235: {
1.158 raeburn 236: my $typesfile = $Apache::lonnet::perlvar{'lonTabDir'}.
237: '/filetypes.tab';
238: if ( open (my $fh,"<$typesfile") ) {
1.356 albertel 239: while (my $line = <$fh>) {
240: next if ($line =~ /^\#/);
241: chomp($line);
242: my ($ending,$emb,$mime,$descr)=split(/\s+/,$line,4);
1.158 raeburn 243: if ($descr ne '') {
244: $fe{$ending}=lc($emb);
245: $fd{$ending}=$descr;
1.351 www 246: if ($mime ne 'unk') { $fm{$ending}=$mime; }
1.158 raeburn 247: }
248: }
249: close($fh);
250: }
1.12 harris41 251: }
1.22 www 252: &Apache::lonnet::logthis(
1.46 matthew 253: "<font color=yellow>INFO: Read file types</font>");
1.22 www 254: $readit=1;
1.46 matthew 255: } # end of unless($readit)
1.32 matthew 256:
257: }
1.112 bowersj2 258:
1.42 matthew 259: ###############################################################
260: ## HTML and Javascript Helper Functions ##
261: ###############################################################
262:
263: =pod
264:
1.112 bowersj2 265: =head1 HTML and Javascript Functions
1.42 matthew 266:
1.112 bowersj2 267: =over 4
268:
269: =item * browser_and_searcher_javascript ()
270:
271: X<browsing, javascript>X<searching, javascript>Returns a string
272: containing javascript with two functions, C<openbrowser> and
273: C<opensearcher>. Returned string does not contain E<lt>scriptE<gt>
274: tags.
1.42 matthew 275:
1.112 bowersj2 276: =item * openbrowser(formname,elementname,only,omit) [javascript]
1.42 matthew 277:
278: inputs: formname, elementname, only, omit
279:
280: formname and elementname indicate the name of the html form and name of
281: the element that the results of the browsing selection are to be placed in.
282:
283: Specifying 'only' will restrict the browser to displaying only files
1.185 www 284: with the given extension. Can be a comma separated list.
1.42 matthew 285:
286: Specifying 'omit' will restrict the browser to NOT displaying files
1.185 www 287: with the given extension. Can be a comma separated list.
1.42 matthew 288:
1.112 bowersj2 289: =item * opensearcher(formname, elementname) [javascript]
1.42 matthew 290:
291: Inputs: formname, elementname
292:
293: formname and elementname specify the name of the html form and the name
294: of the element the selection from the search results will be placed in.
1.542 raeburn 295:
1.42 matthew 296: =cut
297:
298: sub browser_and_searcher_javascript {
1.199 albertel 299: my ($mode)=@_;
300: if (!defined($mode)) { $mode='edit'; }
1.453 albertel 301: my $resurl=&escape_single(&lastresurl());
1.42 matthew 302: return <<END;
1.219 albertel 303: // <!-- BEGIN LON-CAPA Internal
1.50 matthew 304: var editbrowser = null;
1.135 albertel 305: function openbrowser(formname,elementname,only,omit,titleelement) {
1.170 www 306: var url = '$resurl/?';
1.42 matthew 307: if (editbrowser == null) {
308: url += 'launch=1&';
309: }
310: url += 'catalogmode=interactive&';
1.199 albertel 311: url += 'mode=$mode&';
1.611 albertel 312: url += 'inhibitmenu=yes&';
1.42 matthew 313: url += 'form=' + formname + '&';
314: if (only != null) {
315: url += 'only=' + only + '&';
1.217 albertel 316: } else {
317: url += 'only=&';
318: }
1.42 matthew 319: if (omit != null) {
320: url += 'omit=' + omit + '&';
1.217 albertel 321: } else {
322: url += 'omit=&';
323: }
1.135 albertel 324: if (titleelement != null) {
325: url += 'titleelement=' + titleelement + '&';
1.217 albertel 326: } else {
327: url += 'titleelement=&';
328: }
1.42 matthew 329: url += 'element=' + elementname + '';
330: var title = 'Browser';
1.435 albertel 331: var options = 'scrollbars=1,resizable=1,menubar=0,toolbar=1,location=1';
1.42 matthew 332: options += ',width=700,height=600';
333: editbrowser = open(url,title,options,'1');
334: editbrowser.focus();
335: }
336: var editsearcher;
1.135 albertel 337: function opensearcher(formname,elementname,titleelement) {
1.42 matthew 338: var url = '/adm/searchcat?';
339: if (editsearcher == null) {
340: url += 'launch=1&';
341: }
342: url += 'catalogmode=interactive&';
1.199 albertel 343: url += 'mode=$mode&';
1.42 matthew 344: url += 'form=' + formname + '&';
1.135 albertel 345: if (titleelement != null) {
346: url += 'titleelement=' + titleelement + '&';
1.217 albertel 347: } else {
348: url += 'titleelement=&';
349: }
1.42 matthew 350: url += 'element=' + elementname + '';
351: var title = 'Search';
1.435 albertel 352: var options = 'scrollbars=1,resizable=1,menubar=0,toolbar=1,location=1';
1.42 matthew 353: options += ',width=700,height=600';
354: editsearcher = open(url,title,options,'1');
355: editsearcher.focus();
356: }
1.219 albertel 357: // END LON-CAPA Internal -->
1.42 matthew 358: END
1.170 www 359: }
360:
361: sub lastresurl {
1.258 albertel 362: if ($env{'environment.lastresurl'}) {
363: return $env{'environment.lastresurl'}
1.170 www 364: } else {
365: return '/res';
366: }
367: }
368:
369: sub storeresurl {
370: my $resurl=&Apache::lonnet::clutter(shift);
371: unless ($resurl=~/^\/res/) { return 0; }
372: $resurl=~s/\/$//;
373: &Apache::lonnet::put('environment',{'lastresurl' => $resurl});
374: &Apache::lonnet::appenv('environment.lastresurl' => $resurl);
375: return 1;
1.42 matthew 376: }
377:
1.74 www 378: sub studentbrowser_javascript {
1.111 www 379: unless (
1.258 albertel 380: (($env{'request.course.id'}) &&
1.302 albertel 381: (&Apache::lonnet::allowed('srm',$env{'request.course.id'})
382: || &Apache::lonnet::allowed('srm',$env{'request.course.id'}.
383: '/'.$env{'request.course.sec'})
384: ))
1.258 albertel 385: || ($env{'request.role'}=~/^(au|dc|su)/)
1.111 www 386: ) { return ''; }
1.74 www 387: return (<<'ENDSTDBRW');
388: <script type="text/javascript" language="Javascript" >
389: var stdeditbrowser;
1.558 albertel 390: function openstdbrowser(formname,uname,udom,roleflag,ignorefilter) {
1.74 www 391: var url = '/adm/pickstudent?';
392: var filter;
1.558 albertel 393: if (!ignorefilter) {
394: eval('filter=document.'+formname+'.'+uname+'.value;');
395: }
1.74 www 396: if (filter != null) {
397: if (filter != '') {
398: url += 'filter='+filter+'&';
399: }
400: }
401: url += 'form=' + formname + '&unameelement='+uname+
402: '&udomelement='+udom;
1.111 www 403: if (roleflag) { url+="&roles=1"; }
1.102 www 404: var title = 'Student_Browser';
1.74 www 405: var options = 'scrollbars=1,resizable=1,menubar=0';
406: options += ',width=700,height=600';
407: stdeditbrowser = open(url,title,options,'1');
408: stdeditbrowser.focus();
409: }
410: </script>
411: ENDSTDBRW
412: }
1.42 matthew 413:
1.74 www 414: sub selectstudent_link {
1.111 www 415: my ($form,$unameele,$udomele)=@_;
1.258 albertel 416: if ($env{'request.course.id'}) {
1.302 albertel 417: if (!&Apache::lonnet::allowed('srm',$env{'request.course.id'})
418: && !&Apache::lonnet::allowed('srm',$env{'request.course.id'}.
419: '/'.$env{'request.course.sec'})) {
1.111 www 420: return '';
421: }
422: return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele.
1.607 albertel 423: '","'.$udomele.'");'."'>".&mt('Select User')."</a>";
1.74 www 424: }
1.258 albertel 425: if ($env{'request.role'}=~/^(au|dc|su)/) {
1.111 www 426: return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele.
1.119 www 427: '","'.$udomele.'",1);'."'>".&mt('Select User')."</a>";
1.111 www 428: }
429: return '';
1.91 www 430: }
431:
432: sub coursebrowser_javascript {
1.468 raeburn 433: my ($domainfilter,$sec_element,$formname)=@_;
1.377 raeburn 434: 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 435: my $output = '
1.538 albertel 436: <script type="text/javascript">
1.468 raeburn 437: var stdeditbrowser;'."\n";
438: $output .= <<"ENDSTDBRW";
1.377 raeburn 439: function opencrsbrowser(formname,uname,udom,desc,extra_element,multflag,crstype) {
1.91 www 440: var url = '/adm/pickcourse?';
1.468 raeburn 441: var domainfilter = '';
442: var formid = getFormIdByName(formname);
443: if (formid > -1) {
444: var domid = getIndexByName(formid,udom);
445: if (domid > -1) {
446: if (document.forms[formid].elements[domid].type == 'select-one') {
447: domainfilter=document.forms[formid].elements[domid].options[document.forms[formid].elements[domid].selectedIndex].value;
448: }
449: if (document.forms[formid].elements[domid].type == 'hidden') {
450: domainfilter=document.forms[formid].elements[domid].value;
451: }
452: }
1.91 www 453: }
1.128 albertel 454: if (domainfilter != null) {
455: if (domainfilter != '') {
456: url += 'domainfilter='+domainfilter+'&';
457: }
458: }
1.91 www 459: url += 'form=' + formname + '&cnumelement='+uname+
1.187 albertel 460: '&cdomelement='+udom+
461: '&cnameelement='+desc;
1.468 raeburn 462: if (extra_element !=null && extra_element != '') {
1.594 raeburn 463: if (formname == 'rolechoice' || formname == 'studentform') {
1.468 raeburn 464: url += '&roleelement='+extra_element;
465: if (domainfilter == null || domainfilter == '') {
466: url += '&domainfilter='+extra_element;
467: }
1.234 raeburn 468: }
1.468 raeburn 469: else {
470: if (formname == 'portform') {
471: url += '&setroles='+extra_element;
472: }
473: }
1.230 raeburn 474: }
1.293 raeburn 475: if (multflag !=null && multflag != '') {
476: url += '&multiple='+multflag;
477: }
1.377 raeburn 478: if (crstype == 'Course/Group') {
479: if (formname == 'cu') {
480: crstype = document.cu.crstype.options[document.cu.crstype.selectedIndex].value;
481: if (crstype == "") {
482: alert("$crs_or_grp_alert");
483: return;
484: }
485: }
486: }
487: if (crstype !=null && crstype != '') {
488: url += '&type='+crstype;
489: }
1.102 www 490: var title = 'Course_Browser';
1.91 www 491: var options = 'scrollbars=1,resizable=1,menubar=0';
492: options += ',width=700,height=600';
493: stdeditbrowser = open(url,title,options,'1');
494: stdeditbrowser.focus();
495: }
1.468 raeburn 496:
497: function getFormIdByName(formname) {
498: for (var i=0;i<document.forms.length;i++) {
499: if (document.forms[i].name == formname) {
500: return i;
501: }
502: }
503: return -1;
504: }
505:
506: function getIndexByName(formid,item) {
507: for (var i=0;i<document.forms[formid].elements.length;i++) {
508: if (document.forms[formid].elements[i].name == item) {
509: return i;
510: }
511: }
512: return -1;
513: }
1.91 www 514: ENDSTDBRW
1.468 raeburn 515: if ($sec_element ne '') {
516: $output .= &setsec_javascript($sec_element,$formname);
517: }
518: $output .= '
519: </script>';
520: return $output;
521: }
522:
523: sub setsec_javascript {
524: my ($sec_element,$formname) = @_;
525: my $setsections = qq|
526: function setSect(sectionlist) {
1.629 raeburn 527: var sectionsArray = new Array();
528: if ((sectionlist != '') && (typeof sectionlist != "undefined")) {
529: sectionsArray = sectionlist.split(",");
530: }
1.468 raeburn 531: var numSections = sectionsArray.length;
532: document.$formname.$sec_element.length = 0;
533: if (numSections == 0) {
534: document.$formname.$sec_element.multiple=false;
535: document.$formname.$sec_element.size=1;
536: document.$formname.$sec_element.options[0] = new Option('No existing sections','',false,false)
537: } else {
538: if (numSections == 1) {
539: document.$formname.$sec_element.multiple=false;
540: document.$formname.$sec_element.size=1;
541: document.$formname.$sec_element.options[0] = new Option('Select','',true,true);
542: document.$formname.$sec_element.options[1] = new Option('No section','',false,false)
543: document.$formname.$sec_element.options[2] = new Option(sectionsArray[0],sectionsArray[0],false,false);
544: } else {
545: for (var i=0; i<numSections; i++) {
546: document.$formname.$sec_element.options[i] = new Option(sectionsArray[i],sectionsArray[i],false,false)
547: }
548: document.$formname.$sec_element.multiple=true
549: if (numSections < 3) {
550: document.$formname.$sec_element.size=numSections;
551: } else {
552: document.$formname.$sec_element.size=3;
553: }
554: document.$formname.$sec_element.options[0].selected = false
555: }
556: }
1.91 www 557: }
1.468 raeburn 558: |;
559: return $setsections;
560: }
561:
1.91 www 562:
563: sub selectcourse_link {
1.377 raeburn 564: my ($form,$unameele,$udomele,$desc,$extra_element,$multflag,$selecttype)=@_;
1.492 albertel 565: return "<a href='".'javascript:opencrsbrowser("'.$form.'","'.$unameele.
566: '","'.$udomele.'","'.$desc.'","'.$extra_element.'","'.$multflag.'","'.$selecttype.'");'."'>".&mt('Select Course')."</a>";
1.74 www 567: }
1.42 matthew 568:
1.273 raeburn 569: sub check_uncheck_jscript {
570: my $jscript = <<"ENDSCRT";
571: function checkAll(field) {
572: if (field.length > 0) {
573: for (i = 0; i < field.length; i++) {
574: field[i].checked = true ;
575: }
576: } else {
577: field.checked = true
578: }
579: }
580:
581: function uncheckAll(field) {
582: if (field.length > 0) {
583: for (i = 0; i < field.length; i++) {
584: field[i].checked = false ;
1.543 albertel 585: }
586: } else {
1.273 raeburn 587: field.checked = false ;
588: }
589: }
590: ENDSCRT
591: return $jscript;
592: }
593:
594:
1.42 matthew 595: =pod
1.36 matthew 596:
1.112 bowersj2 597: =item * linked_select_forms(...)
1.36 matthew 598:
599: linked_select_forms returns a string containing a <script></script> block
600: and html for two <select> menus. The select menus will be linked in that
601: changing the value of the first menu will result in new values being placed
602: in the second menu. The values in the select menu will appear in alphabetical
1.609 raeburn 603: order unless a defined order is provided.
1.36 matthew 604:
605: linked_select_forms takes the following ordered inputs:
606:
607: =over 4
608:
1.112 bowersj2 609: =item * $formname, the name of the <form> tag
1.36 matthew 610:
1.112 bowersj2 611: =item * $middletext, the text which appears between the <select> tags
1.36 matthew 612:
1.112 bowersj2 613: =item * $firstdefault, the default value for the first menu
1.36 matthew 614:
1.112 bowersj2 615: =item * $firstselectname, the name of the first <select> tag
1.36 matthew 616:
1.112 bowersj2 617: =item * $secondselectname, the name of the second <select> tag
1.36 matthew 618:
1.112 bowersj2 619: =item * $hashref, a reference to a hash containing the data for the menus.
1.36 matthew 620:
1.609 raeburn 621: =item * $menuorder, the order of values in the first menu
622:
1.41 ng 623: =back
624:
1.36 matthew 625: Below is an example of such a hash. Only the 'text', 'default', and
626: 'select2' keys must appear as stated. keys(%menu) are the possible
627: values for the first select menu. The text that coincides with the
1.41 ng 628: first menu value is given in $menu{$choice1}->{'text'}. The values
1.36 matthew 629: and text for the second menu are given in the hash pointed to by
630: $menu{$choice1}->{'select2'}.
631:
1.112 bowersj2 632: my %menu = ( A1 => { text =>"Choice A1" ,
633: default => "B3",
634: select2 => {
635: B1 => "Choice B1",
636: B2 => "Choice B2",
637: B3 => "Choice B3",
638: B4 => "Choice B4"
1.609 raeburn 639: },
640: order => ['B4','B3','B1','B2'],
1.112 bowersj2 641: },
642: A2 => { text =>"Choice A2" ,
643: default => "C2",
644: select2 => {
645: C1 => "Choice C1",
646: C2 => "Choice C2",
647: C3 => "Choice C3"
1.609 raeburn 648: },
649: order => ['C2','C1','C3'],
1.112 bowersj2 650: },
651: A3 => { text =>"Choice A3" ,
652: default => "D6",
653: select2 => {
654: D1 => "Choice D1",
655: D2 => "Choice D2",
656: D3 => "Choice D3",
657: D4 => "Choice D4",
658: D5 => "Choice D5",
659: D6 => "Choice D6",
660: D7 => "Choice D7"
1.609 raeburn 661: },
662: order => ['D4','D3','D2','D1','D7','D6','D5'],
1.112 bowersj2 663: }
664: );
1.36 matthew 665:
666: =cut
667:
668: sub linked_select_forms {
669: my ($formname,
670: $middletext,
671: $firstdefault,
672: $firstselectname,
673: $secondselectname,
1.609 raeburn 674: $hashref,
675: $menuorder,
1.36 matthew 676: ) = @_;
677: my $second = "document.$formname.$secondselectname";
678: my $first = "document.$formname.$firstselectname";
679: # output the javascript to do the changing
680: my $result = '';
1.219 albertel 681: $result.="<script type=\"text/javascript\">\n";
1.36 matthew 682: $result.="var select2data = new Object();\n";
683: $" = '","';
684: my $debug = '';
685: foreach my $s1 (sort(keys(%$hashref))) {
686: $result.="select2data.d_$s1 = new Object();\n";
687: $result.="select2data.d_$s1.def = new String('".
688: $hashref->{$s1}->{'default'}."');\n";
1.609 raeburn 689: $result.="select2data.d_$s1.values = new Array(";
1.36 matthew 690: my @s2values = sort(keys( %{ $hashref->{$s1}->{'select2'} } ));
1.609 raeburn 691: if (ref($hashref->{$s1}->{'order'}) eq 'ARRAY') {
692: @s2values = @{$hashref->{$s1}->{'order'}};
693: }
1.36 matthew 694: $result.="\"@s2values\");\n";
695: $result.="select2data.d_$s1.texts = new Array(";
696: my @s2texts;
697: foreach my $value (@s2values) {
698: push @s2texts, $hashref->{$s1}->{'select2'}->{$value};
699: }
700: $result.="\"@s2texts\");\n";
701: }
702: $"=' ';
703: $result.= <<"END";
704:
705: function select1_changed() {
706: // Determine new choice
707: var newvalue = "d_" + $first.value;
708: // update select2
709: var values = select2data[newvalue].values;
710: var texts = select2data[newvalue].texts;
711: var select2def = select2data[newvalue].def;
712: var i;
713: // out with the old
714: for (i = 0; i < $second.options.length; i++) {
715: $second.options[i] = null;
716: }
717: // in with the nuclear
718: for (i=0;i<values.length; i++) {
719: $second.options[i] = new Option(values[i]);
1.143 matthew 720: $second.options[i].value = values[i];
1.36 matthew 721: $second.options[i].text = texts[i];
722: if (values[i] == select2def) {
723: $second.options[i].selected = true;
724: }
725: }
726: }
727: </script>
728: END
729: # output the initial values for the selection lists
730: $result .= "<select size=\"1\" name=\"$firstselectname\" onchange=\"select1_changed()\">\n";
1.609 raeburn 731: my @order = sort(keys(%{$hashref}));
732: if (ref($menuorder) eq 'ARRAY') {
733: @order = @{$menuorder};
734: }
735: foreach my $value (@order) {
1.36 matthew 736: $result.=" <option value=\"$value\" ";
1.253 albertel 737: $result.=" selected=\"selected\" " if ($value eq $firstdefault);
1.119 www 738: $result.=">".&mt($hashref->{$value}->{'text'})."</option>\n";
1.36 matthew 739: }
740: $result .= "</select>\n";
741: my %select2 = %{$hashref->{$firstdefault}->{'select2'}};
742: $result .= $middletext;
743: $result .= "<select size=\"1\" name=\"$secondselectname\">\n";
744: my $seconddefault = $hashref->{$firstdefault}->{'default'};
1.609 raeburn 745:
746: my @secondorder = sort(keys(%select2));
747: if (ref($hashref->{$firstdefault}->{'order'}) eq 'ARRAY') {
748: @secondorder = @{$hashref->{$firstdefault}->{'order'}};
749: }
750: foreach my $value (@secondorder) {
1.36 matthew 751: $result.=" <option value=\"$value\" ";
1.253 albertel 752: $result.=" selected=\"selected\" " if ($value eq $seconddefault);
1.119 www 753: $result.=">".&mt($select2{$value})."</option>\n";
1.36 matthew 754: }
755: $result .= "</select>\n";
756: # return $debug;
757: return $result;
758: } # end of sub linked_select_forms {
759:
1.45 matthew 760: =pod
1.44 bowersj2 761:
1.112 bowersj2 762: =item * help_open_topic($topic, $text, $stayOnPage, $width, $height)
1.44 bowersj2 763:
1.112 bowersj2 764: Returns a string corresponding to an HTML link to the given help
765: $topic, where $topic corresponds to the name of a .tex file in
766: /home/httpd/html/adm/help/tex, with underscores replaced by
767: spaces.
768:
769: $text will optionally be linked to the same topic, allowing you to
770: link text in addition to the graphic. If you do not want to link
771: text, but wish to specify one of the later parameters, pass an
772: empty string.
773:
774: $stayOnPage is a value that will be interpreted as a boolean. If true,
775: the link will not open a new window. If false, the link will open
776: a new window using Javascript. (Default is false.)
777:
778: $width and $height are optional numerical parameters that will
779: override the width and height of the popped up window, which may
780: be useful for certain help topics with big pictures included.
1.44 bowersj2 781:
782: =cut
783:
784: sub help_open_topic {
1.48 bowersj2 785: my ($topic, $text, $stayOnPage, $width, $height) = @_;
786: $text = "" if (not defined $text);
1.44 bowersj2 787: $stayOnPage = 0 if (not defined $stayOnPage);
1.552 banghart 788: if ($env{'browser.interface'} eq 'textual') {
1.79 www 789: $stayOnPage=1;
790: }
1.44 bowersj2 791: $width = 350 if (not defined $width);
792: $height = 400 if (not defined $height);
793: my $filename = $topic;
794: $filename =~ s/ /_/g;
795:
1.48 bowersj2 796: my $template = "";
797: my $link;
1.572 banghart 798:
1.159 www 799: $topic=~s/\W/\_/g;
1.44 bowersj2 800:
1.572 banghart 801: if (!$stayOnPage) {
1.72 bowersj2 802: $link = "javascript:void(open('/adm/help/${filename}.hlp', 'Help_for_$topic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))";
1.572 banghart 803: } else {
1.48 bowersj2 804: $link = "/adm/help/${filename}.hlp";
805: }
806:
807: # Add the text
1.572 banghart 808: if ($text ne "") {
1.77 www 809: $template .=
1.572 banghart 810: "<table bgcolor='#3333AA' cellspacing='1' cellpadding='1' border='0'><tr>".
811: "<td bgcolor='#5555FF'><a target=\"_top\" href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";
1.48 bowersj2 812: }
813:
814: # Add the graphic
1.179 matthew 815: my $title = &mt('Online Help');
1.215 albertel 816: my $helpicon=&lonhttpdurl("/adm/help/gif/smallHelp.gif");
1.48 bowersj2 817: $template .= <<"ENDTEMPLATE";
1.436 albertel 818: <a target="_top" href="$link" title="$title"><img src="$helpicon" border="0" alt="(Help: $topic)" /></a>
1.44 bowersj2 819: ENDTEMPLATE
1.78 www 820: if ($text ne '') { $template.='</td></tr></table>' };
1.44 bowersj2 821: return $template;
822:
1.106 bowersj2 823: }
824:
825: # This is a quicky function for Latex cheatsheet editing, since it
826: # appears in at least four places
827: sub helpLatexCheatsheet {
828: my $other = shift;
829: my $addOther = '';
830: if ($other) {
831: $addOther = Apache::loncommon::help_open_topic($other, shift,
832: undef, undef, 600) .
833: '</td><td>';
834: }
835: return '<table><tr><td>'.
836: $addOther .
1.636 raeburn 837: &Apache::loncommon::help_open_topic("Greek_Symbols",&mt('Greek Symbols'),
1.106 bowersj2 838: undef,undef,600)
839: .'</td><td>'.
1.636 raeburn 840: &Apache::loncommon::help_open_topic("Other_Symbols",&mt('Other Symbols'),
1.106 bowersj2 841: undef,undef,600)
842: .'</td></tr></table>';
1.172 www 843: }
844:
1.430 albertel 845: sub general_help {
846: my $helptopic='Student_Intro';
847: if ($env{'request.role'}=~/^(ca|au)/) {
848: $helptopic='Authoring_Intro';
849: } elsif ($env{'request.role'}=~/^cc/) {
850: $helptopic='Course_Coordination_Intro';
851: }
852: return $helptopic;
853: }
854:
855: sub update_help_link {
856: my ($topic,$component_help,$faq,$bug,$stayOnPage) = @_;
857: my $origurl = $ENV{'REQUEST_URI'};
858: $origurl=~s|^/~|/priv/|;
859: my $timestamp = time;
860: foreach my $datum (\$topic,\$component_help,\$faq,\$bug,\$origurl) {
861: $$datum = &escape($$datum);
862: }
863:
864: my $banner_link = "/adm/helpmenu?page=banner&topic=$topic&component_help=$component_help&faq=$faq&bug=$bug&origurl=$origurl&stamp=$timestamp&stayonpage=$stayOnPage";
865: my $output .= <<"ENDOUTPUT";
866: <script type="text/javascript">
867: banner_link = '$banner_link';
868: </script>
869: ENDOUTPUT
870: return $output;
871: }
872:
873: # now just updates the help link and generates a blue icon
1.193 raeburn 874: sub help_open_menu {
1.430 albertel 875: my ($topic,$component_help,$faq,$bug,$stayOnPage,$width,$height,$text)
1.552 banghart 876: = @_;
1.430 albertel 877: $stayOnPage = 0 if (not defined $stayOnPage);
1.572 banghart 878: # only use pop-up help (stayOnPage == 0)
1.552 banghart 879: # if environment.remote is on (using remote control UI)
1.572 banghart 880: if ($env{'browser.interface'} eq 'textual' ||
881: $env{'environment.remote'} eq 'off' ) {
1.552 banghart 882: $stayOnPage=1;
1.430 albertel 883: }
884: my $output;
885: if ($component_help) {
886: if (!$text) {
887: $output=&help_open_topic($component_help,undef,$stayOnPage,
888: $width,$height);
889: } else {
890: my $help_text;
891: $help_text=&unescape($topic);
892: $output='<table><tr><td>'.
893: &help_open_topic($component_help,$help_text,$stayOnPage,
894: $width,$height).'</td></tr></table>';
895: }
896: }
897: my $banner_link = &update_help_link($topic,$component_help,$faq,$bug,$stayOnPage);
898: return $output.$banner_link;
899: }
900:
901: sub top_nav_help {
902: my ($text) = @_;
1.436 albertel 903: $text = &mt($text);
1.572 banghart 904: my $stay_on_page =
1.436 albertel 905: ($env{'browser.interface'} eq 'textual' ||
906: $env{'environment.remote'} eq 'off' );
1.572 banghart 907: my $link = ($stay_on_page) ? "javascript:helpMenu('display')"
1.436 albertel 908: : "javascript:helpMenu('open')";
1.572 banghart 909: my $banner_link = &update_help_link(undef,undef,undef,undef,$stay_on_page);
1.436 albertel 910:
1.201 raeburn 911: my $title = &mt('Get help');
1.436 albertel 912:
913: return <<"END";
914: $banner_link
915: <a href="$link" title="$title">$text</a>
916: END
917: }
918:
919: sub help_menu_js {
920: my ($text) = @_;
921:
922: my $stayOnPage =
923: ($env{'browser.interface'} eq 'textual' ||
924: $env{'environment.remote'} eq 'off' );
925:
926: my $width = 620;
927: my $height = 600;
1.430 albertel 928: my $helptopic=&general_help();
929: my $details_link = '/adm/help/'.$helptopic.'.hlp';
1.261 albertel 930: my $nothing=&Apache::lonhtmlcommon::javascript_nothing();
1.331 albertel 931: my $start_page =
932: &Apache::loncommon::start_page('Help Menu', undef,
933: {'frameset' => 1,
934: 'js_ready' => 1,
935: 'add_entries' => {
936: 'border' => '0',
1.579 raeburn 937: 'rows' => "110,*",},});
1.331 albertel 938: my $end_page =
939: &Apache::loncommon::end_page({'frameset' => 1,
940: 'js_ready' => 1,});
941:
1.436 albertel 942: my $template .= <<"ENDTEMPLATE";
943: <script type="text/javascript">
1.253 albertel 944: // <!-- BEGIN LON-CAPA Internal
945: // <![CDATA[
1.430 albertel 946: var banner_link = '';
1.243 raeburn 947: function helpMenu(target) {
948: var caller = this;
949: if (target == 'open') {
950: var newWindow = null;
951: try {
1.262 albertel 952: newWindow = window.open($nothing,"helpmenu","HEIGHT=$height,WIDTH=$width,resizable=yes,scrollbars=yes" )
1.243 raeburn 953: }
954: catch(error) {
955: writeHelp(caller);
956: return;
957: }
958: if (newWindow) {
959: caller = newWindow;
960: }
1.193 raeburn 961: }
1.243 raeburn 962: writeHelp(caller);
963: return;
964: }
965: function writeHelp(caller) {
1.430 albertel 966: caller.document.writeln('$start_page<frame name="bannerframe" src="'+banner_link+'" /><frame name="bodyframe" src="$details_link" /> $end_page')
1.243 raeburn 967: caller.document.close()
968: caller.focus()
1.193 raeburn 969: }
1.253 albertel 970: // ]]>
1.219 albertel 971: // END LON-CAPA Internal -->
1.436 albertel 972: </script>
1.193 raeburn 973: ENDTEMPLATE
974: return $template;
975: }
976:
1.172 www 977: sub help_open_bug {
978: my ($topic, $text, $stayOnPage, $width, $height) = @_;
1.258 albertel 979: unless ($env{'user.adv'}) { return ''; }
1.172 www 980: unless ($Apache::lonnet::perlvar{'BugzillaHost'}) { return ''; }
981: $text = "" if (not defined $text);
982: $stayOnPage = 0 if (not defined $stayOnPage);
1.258 albertel 983: if ($env{'browser.interface'} eq 'textual' ||
984: $env{'environment.remote'} eq 'off' ) {
1.172 www 985: $stayOnPage=1;
986: }
1.184 albertel 987: $width = 600 if (not defined $width);
988: $height = 600 if (not defined $height);
1.172 www 989:
990: $topic=~s/\W+/\+/g;
991: my $link='';
992: my $template='';
1.379 albertel 993: my $url=$Apache::lonnet::perlvar{'BugzillaHost'}.'enter_bug.cgi?product=LON-CAPA&bug_file_loc='.
994: &escape($ENV{'REQUEST_URI'}).'&component='.$topic;
1.172 www 995: if (!$stayOnPage)
996: {
997: $link = "javascript:void(open('$url', 'Bugzilla', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))";
998: }
999: else
1000: {
1001: $link = $url;
1002: }
1003: # Add the text
1004: if ($text ne "")
1005: {
1006: $template .=
1007: "<table bgcolor='#AA3333' cellspacing='1' cellpadding='1' border='0'><tr>".
1.436 albertel 1008: "<td bgcolor='#FF5555'><a target=\"_top\" href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";
1.172 www 1009: }
1010:
1011: # Add the graphic
1.179 matthew 1012: my $title = &mt('Report a Bug');
1.215 albertel 1013: my $bugicon=&lonhttpdurl("/adm/lonMisc/smallBug.gif");
1.172 www 1014: $template .= <<"ENDTEMPLATE";
1.436 albertel 1015: <a target="_top" href="$link" title="$title"><img src="$bugicon" border="0" alt="(Bug: $topic)" /></a>
1.172 www 1016: ENDTEMPLATE
1017: if ($text ne '') { $template.='</td></tr></table>' };
1018: return $template;
1019:
1020: }
1021:
1022: sub help_open_faq {
1023: my ($topic, $text, $stayOnPage, $width, $height) = @_;
1.258 albertel 1024: unless ($env{'user.adv'}) { return ''; }
1.172 www 1025: unless ($Apache::lonnet::perlvar{'FAQHost'}) { return ''; }
1026: $text = "" if (not defined $text);
1027: $stayOnPage = 0 if (not defined $stayOnPage);
1.258 albertel 1028: if ($env{'browser.interface'} eq 'textual' ||
1029: $env{'environment.remote'} eq 'off' ) {
1.172 www 1030: $stayOnPage=1;
1031: }
1032: $width = 350 if (not defined $width);
1033: $height = 400 if (not defined $height);
1034:
1035: $topic=~s/\W+/\+/g;
1036: my $link='';
1037: my $template='';
1038: my $url=$Apache::lonnet::perlvar{'FAQHost'}.'/fom/cache/'.$topic.'.html';
1039: if (!$stayOnPage)
1040: {
1041: $link = "javascript:void(open('$url', 'FAQ-O-Matic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))";
1042: }
1043: else
1044: {
1045: $link = $url;
1046: }
1047:
1048: # Add the text
1049: if ($text ne "")
1050: {
1051: $template .=
1.173 www 1052: "<table bgcolor='#337733' cellspacing='1' cellpadding='1' border='0'><tr>".
1.436 albertel 1053: "<td bgcolor='#448844'><a target=\"_top\" href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";
1.172 www 1054: }
1055:
1056: # Add the graphic
1.179 matthew 1057: my $title = &mt('View the FAQ');
1.215 albertel 1058: my $faqicon=&lonhttpdurl("/adm/lonMisc/smallFAQ.gif");
1.172 www 1059: $template .= <<"ENDTEMPLATE";
1.436 albertel 1060: <a target="_top" href="$link" title="$title"><img src="$faqicon" border="0" alt="(FAQ: $topic)" /></a>
1.172 www 1061: ENDTEMPLATE
1062: if ($text ne '') { $template.='</td></tr></table>' };
1063: return $template;
1064:
1.44 bowersj2 1065: }
1.37 matthew 1066:
1.180 matthew 1067: ###############################################################
1068: ###############################################################
1069:
1.45 matthew 1070: =pod
1071:
1.256 matthew 1072: =item * change_content_javascript():
1073:
1074: This and the next function allow you to create small sections of an
1075: otherwise static HTML page that you can update on the fly with
1076: Javascript, even in Netscape 4.
1077:
1078: The Javascript fragment returned by this function (no E<lt>scriptE<gt> tag)
1079: must be written to the HTML page once. It will prove the Javascript
1080: function "change(name, content)". Calling the change function with the
1081: name of the section
1082: you want to update, matching the name passed to C<changable_area>, and
1083: the new content you want to put in there, will put the content into
1084: that area.
1085:
1086: B<Note>: Netscape 4 only reserves enough space for the changable area
1087: to contain room for the original contents. You need to "make space"
1088: for whatever changes you wish to make, and be B<sure> to check your
1089: code in Netscape 4. This feature in Netscape 4 is B<not> powerful;
1090: it's adequate for updating a one-line status display, but little more.
1091: This script will set the space to 100% width, so you only need to
1092: worry about height in Netscape 4.
1093:
1094: Modern browsers are much less limiting, and if you can commit to the
1095: user not using Netscape 4, this feature may be used freely with
1096: pretty much any HTML.
1097:
1098: =cut
1099:
1100: sub change_content_javascript {
1101: # If we're on Netscape 4, we need to use Layer-based code
1.258 albertel 1102: if ($env{'browser.type'} eq 'netscape' &&
1103: $env{'browser.version'} =~ /^4\./) {
1.256 matthew 1104: return (<<NETSCAPE4);
1105: function change(name, content) {
1106: doc = document.layers[name+"___escape"].layers[0].document;
1107: doc.open();
1108: doc.write(content);
1109: doc.close();
1110: }
1111: NETSCAPE4
1112: } else {
1113: # Otherwise, we need to use semi-standards-compliant code
1114: # (technically, "innerHTML" isn't standard but the equivalent
1115: # is really scary, and every useful browser supports it
1116: return (<<DOMBASED);
1117: function change(name, content) {
1118: element = document.getElementById(name);
1119: element.innerHTML = content;
1120: }
1121: DOMBASED
1122: }
1123: }
1124:
1125: =pod
1126:
1127: =item * changable_area($name, $origContent):
1128:
1129: This provides a "changable area" that can be modified on the fly via
1130: the Javascript code provided in C<change_content_javascript>. $name is
1131: the name you will use to reference the area later; do not repeat the
1132: same name on a given HTML page more then once. $origContent is what
1133: the area will originally contain, which can be left blank.
1134:
1135: =cut
1136:
1137: sub changable_area {
1138: my ($name, $origContent) = @_;
1139:
1.258 albertel 1140: if ($env{'browser.type'} eq 'netscape' &&
1141: $env{'browser.version'} =~ /^4\./) {
1.256 matthew 1142: # If this is netscape 4, we need to use the Layer tag
1143: return "<ilayer width='100%' id='${name}___escape' overflow='none'><layer width='100%' id='$name' overflow='none'>$origContent</layer></ilayer>";
1144: } else {
1145: return "<span id='$name'>$origContent</span>";
1146: }
1147: }
1148:
1149: =pod
1150:
1.590 raeburn 1151: =item * viewport_geometry_js {
1152:
1153: Provides javascript object (Geometry) which can provide information about the viewport geometry for the client browser.
1154:
1155: =cut
1156:
1157:
1158: sub viewport_geometry_js {
1159: return <<"GEOMETRY";
1160: var Geometry = {};
1161: function init_geometry() {
1162: if (Geometry.init) { return };
1163: Geometry.init=1;
1164: if (window.innerHeight) {
1165: Geometry.getViewportHeight = function() { return window.innerHeight; };
1166: Geometry.getViewportWidth = function() { return window.innerWidth; };
1167: Geometry.getHorizontalScroll = function() { return window.pageXOffset; };
1168: Geometry.getVerticalScroll = function() { return window.pageYOffset; };
1169: }
1170: else if (document.documentElement && document.documentElement.clientHeight) {
1171: Geometry.getViewportHeight =
1172: function() { return document.documentElement.clientHeight; };
1173: Geometry.getViewportWidth =
1174: function() { return document.documentElement.clientWidth; };
1175:
1176: Geometry.getHorizontalScroll =
1177: function() { return document.documentElement.scrollLeft; };
1178: Geometry.getVerticalScroll =
1179: function() { return document.documentElement.scrollTop; };
1180: }
1181: else if (document.body.clientHeight) {
1182: Geometry.getViewportHeight =
1183: function() { return document.body.clientHeight; };
1184: Geometry.getViewportWidth =
1185: function() { return document.body.clientWidth; };
1186: Geometry.getHorizontalScroll =
1187: function() { return document.body.scrollLeft; };
1188: Geometry.getVerticalScroll =
1189: function() { return document.body.scrollTop; };
1190: }
1191: }
1192:
1193: GEOMETRY
1194: }
1195:
1196: =pod
1197:
1198: =item * viewport_size_js {
1199:
1200: Provides a javascript function to set values of two form elements - width and height (elements are passed in as arguments to the javascript function) to the dimensions of the user's browser window.
1201:
1202: =cut
1203:
1204: sub viewport_size_js {
1205: my $geometry = &viewport_geometry_js();
1206: return <<"DIMS";
1207:
1208: $geometry
1209:
1210: function getViewportDims(width,height) {
1211: init_geometry();
1212: width.value = Geometry.getViewportWidth();
1213: height.value = Geometry.getViewportHeight();
1214: return;
1215: }
1216:
1217: DIMS
1218: }
1219:
1220: =pod
1221:
1.565 albertel 1222: =item * resize_textarea_js
1223:
1224: emits the needed javascript to resize a textarea to be as big as possible
1225:
1226: creates a function resize_textrea that takes two IDs first should be
1227: the id of the element to resize, second should be the id of a div that
1228: surrounds everything that comes after the textarea, this routine needs
1229: to be attached to the <body> for the onload and onresize events.
1230:
1231:
1232: =cut
1233:
1234: sub resize_textarea_js {
1.590 raeburn 1235: my $geometry = &viewport_geometry_js();
1.565 albertel 1236: return <<"RESIZE";
1237: <script type="text/javascript">
1.590 raeburn 1238: $geometry
1.565 albertel 1239:
1.588 albertel 1240: function getX(element) {
1241: var x = 0;
1242: while (element) {
1243: x += element.offsetLeft;
1244: element = element.offsetParent;
1245: }
1246: return x;
1247: }
1248: function getY(element) {
1249: var y = 0;
1250: while (element) {
1251: y += element.offsetTop;
1252: element = element.offsetParent;
1253: }
1254: return y;
1255: }
1256:
1257:
1.565 albertel 1258: function resize_textarea(textarea_id,bottom_id) {
1259: init_geometry();
1260: var textarea = document.getElementById(textarea_id);
1261: //alert(textarea);
1262:
1.588 albertel 1263: var textarea_top = getY(textarea);
1.565 albertel 1264: var textarea_height = textarea.offsetHeight;
1265: var bottom = document.getElementById(bottom_id);
1.588 albertel 1266: var bottom_top = getY(bottom);
1.565 albertel 1267: var bottom_height = bottom.offsetHeight;
1268: var window_height = Geometry.getViewportHeight();
1.588 albertel 1269: var fudge = 23;
1.565 albertel 1270: var new_height = window_height-fudge-textarea_top-bottom_height;
1271: if (new_height < 300) {
1272: new_height = 300;
1273: }
1274: textarea.style.height=new_height+'px';
1275: }
1276: </script>
1277: RESIZE
1278:
1279: }
1280:
1281: =pod
1282:
1.256 matthew 1283: =back
1.542 raeburn 1284:
1.256 matthew 1285: =head1 Excel and CSV file utility routines
1286:
1287: =over 4
1288:
1289: =cut
1290:
1291: ###############################################################
1292: ###############################################################
1293:
1294: =pod
1295:
1.112 bowersj2 1296: =item * csv_translate($text)
1.37 matthew 1297:
1.185 www 1298: Translate $text to allow it to be output as a 'comma separated values'
1.37 matthew 1299: format.
1300:
1301: =cut
1302:
1.180 matthew 1303: ###############################################################
1304: ###############################################################
1.37 matthew 1305: sub csv_translate {
1306: my $text = shift;
1307: $text =~ s/\"/\"\"/g;
1.209 albertel 1308: $text =~ s/\n/ /g;
1.37 matthew 1309: return $text;
1310: }
1.180 matthew 1311:
1312: ###############################################################
1313: ###############################################################
1314:
1315: =pod
1316:
1317: =item * define_excel_formats
1318:
1319: Define some commonly used Excel cell formats.
1320:
1321: Currently supported formats:
1322:
1323: =over 4
1324:
1325: =item header
1326:
1327: =item bold
1328:
1329: =item h1
1330:
1331: =item h2
1332:
1333: =item h3
1334:
1.256 matthew 1335: =item h4
1336:
1337: =item i
1338:
1.180 matthew 1339: =item date
1340:
1341: =back
1342:
1343: Inputs: $workbook
1344:
1345: Returns: $format, a hash reference.
1346:
1347: =cut
1348:
1349: ###############################################################
1350: ###############################################################
1351: sub define_excel_formats {
1352: my ($workbook) = @_;
1353: my $format;
1354: $format->{'header'} = $workbook->add_format(bold => 1,
1355: bottom => 1,
1356: align => 'center');
1357: $format->{'bold'} = $workbook->add_format(bold=>1);
1358: $format->{'h1'} = $workbook->add_format(bold=>1, size=>18);
1359: $format->{'h2'} = $workbook->add_format(bold=>1, size=>16);
1360: $format->{'h3'} = $workbook->add_format(bold=>1, size=>14);
1.255 matthew 1361: $format->{'h4'} = $workbook->add_format(bold=>1, size=>12);
1.246 matthew 1362: $format->{'i'} = $workbook->add_format(italic=>1);
1.180 matthew 1363: $format->{'date'} = $workbook->add_format(num_format=>
1.207 matthew 1364: 'mm/dd/yyyy hh:mm:ss');
1.180 matthew 1365: return $format;
1366: }
1367:
1368: ###############################################################
1369: ###############################################################
1.113 bowersj2 1370:
1371: =pod
1372:
1.256 matthew 1373: =item * create_workbook
1.255 matthew 1374:
1375: Create an Excel worksheet. If it fails, output message on the
1376: request object and return undefs.
1377:
1378: Inputs: Apache request object
1379:
1380: Returns (undef) on failure,
1381: Excel worksheet object, scalar with filename, and formats
1382: from &Apache::loncommon::define_excel_formats on success
1383:
1384: =cut
1385:
1386: ###############################################################
1387: ###############################################################
1388: sub create_workbook {
1389: my ($r) = @_;
1390: #
1391: # Create the excel spreadsheet
1392: my $filename = '/prtspool/'.
1.258 albertel 1393: $env{'user.name'}.'_'.$env{'user.domain'}.'_'.
1.255 matthew 1394: time.'_'.rand(1000000000).'.xls';
1395: my $workbook = Spreadsheet::WriteExcel->new('/home/httpd'.$filename);
1396: if (! defined($workbook)) {
1397: $r->log_error("Error creating excel spreadsheet $filename: $!");
1398: $r->print('<p>'.&mt("Unable to create new Excel file. ".
1399: "This error has been logged. ".
1400: "Please alert your LON-CAPA administrator").
1401: '</p>');
1402: return (undef);
1403: }
1404: #
1405: $workbook->set_tempdir('/home/httpd/perl/tmp');
1406: #
1407: my $format = &Apache::loncommon::define_excel_formats($workbook);
1408: return ($workbook,$filename,$format);
1409: }
1410:
1411: ###############################################################
1412: ###############################################################
1413:
1414: =pod
1415:
1.256 matthew 1416: =item * create_text_file
1.113 bowersj2 1417:
1.542 raeburn 1418: Create a file to write to and eventually make available to the user.
1.256 matthew 1419: If file creation fails, outputs an error message on the request object and
1420: return undefs.
1.113 bowersj2 1421:
1.256 matthew 1422: Inputs: Apache request object, and file suffix
1.113 bowersj2 1423:
1.256 matthew 1424: Returns (undef) on failure,
1425: Filehandle and filename on success.
1.113 bowersj2 1426:
1427: =cut
1428:
1.256 matthew 1429: ###############################################################
1430: ###############################################################
1431: sub create_text_file {
1432: my ($r,$suffix) = @_;
1433: if (! defined($suffix)) { $suffix = 'txt'; };
1434: my $fh;
1435: my $filename = '/prtspool/'.
1.258 albertel 1436: $env{'user.name'}.'_'.$env{'user.domain'}.'_'.
1.256 matthew 1437: time.'_'.rand(1000000000).'.'.$suffix;
1438: $fh = Apache::File->new('>/home/httpd'.$filename);
1439: if (! defined($fh)) {
1440: $r->log_error("Couldn't open $filename for output $!");
1441: $r->print("Problems occured in creating the output file. ".
1442: "This error has been logged. ".
1443: "Please alert your LON-CAPA administrator.");
1.113 bowersj2 1444: }
1.256 matthew 1445: return ($fh,$filename)
1.113 bowersj2 1446: }
1447:
1448:
1.256 matthew 1449: =pod
1.113 bowersj2 1450:
1451: =back
1452:
1453: =cut
1.37 matthew 1454:
1455: ###############################################################
1.33 matthew 1456: ## Home server <option> list generating code ##
1457: ###############################################################
1.35 matthew 1458:
1.169 www 1459: # ------------------------------------------
1460:
1461: sub domain_select {
1462: my ($name,$value,$multiple)=@_;
1463: my %domains=map {
1.514 albertel 1464: $_ => $_.' '. &Apache::lonnet::domain($_,'description')
1.512 albertel 1465: } &Apache::lonnet::all_domains();
1.169 www 1466: if ($multiple) {
1467: $domains{''}=&mt('Any domain');
1.550 albertel 1468: $domains{'select_form_order'} = [sort {lc($a) cmp lc($b) } (keys(%domains))];
1.287 albertel 1469: return &multiple_select_form($name,$value,4,\%domains);
1.169 www 1470: } else {
1.550 albertel 1471: $domains{'select_form_order'} = [sort {lc($a) cmp lc($b) } (keys(%domains))];
1.169 www 1472: return &select_form($name,$value,%domains);
1473: }
1474: }
1475:
1.282 albertel 1476: #-------------------------------------------
1477:
1478: =pod
1479:
1.519 raeburn 1480: =head1 Routines for form select boxes
1481:
1482: =over 4
1483:
1.287 albertel 1484: =item * multiple_select_form($name,$value,$size,$hash,$order)
1.282 albertel 1485:
1486: Returns a string containing a <select> element int multiple mode
1487:
1488:
1489: Args:
1490: $name - name of the <select> element
1.506 raeburn 1491: $value - scalar or array ref of values that should already be selected
1.282 albertel 1492: $size - number of rows long the select element is
1.283 albertel 1493: $hash - the elements should be 'option' => 'shown text'
1.282 albertel 1494: (shown text should already have been &mt())
1.506 raeburn 1495: $order - (optional) array ref of the order to show the elements in
1.283 albertel 1496:
1.282 albertel 1497: =cut
1498:
1499: #-------------------------------------------
1.169 www 1500: sub multiple_select_form {
1.284 albertel 1501: my ($name,$value,$size,$hash,$order)=@_;
1.169 www 1502: my %selected = map { $_ => 1 } ref($value)?@{$value}:($value);
1503: my $output='';
1.191 matthew 1504: if (! defined($size)) {
1505: $size = 4;
1.283 albertel 1506: if (scalar(keys(%$hash))<4) {
1507: $size = scalar(keys(%$hash));
1.191 matthew 1508: }
1509: }
1.169 www 1510: $output.="\n<select name='$name' size='$size' multiple='1'>";
1.501 banghart 1511: my @order;
1.506 raeburn 1512: if (ref($order) eq 'ARRAY') {
1513: @order = @{$order};
1514: } else {
1515: @order = sort(keys(%$hash));
1.501 banghart 1516: }
1517: if (exists($$hash{'select_form_order'})) {
1518: @order = @{$$hash{'select_form_order'}};
1519: }
1520:
1.284 albertel 1521: foreach my $key (@order) {
1.356 albertel 1522: $output.='<option value="'.&HTML::Entities::encode($key,'"<>&').'" ';
1.284 albertel 1523: $output.='selected="selected" ' if ($selected{$key});
1524: $output.='>'.$hash->{$key}."</option>\n";
1.169 www 1525: }
1526: $output.="</select>\n";
1527: return $output;
1528: }
1529:
1.88 www 1530: #-------------------------------------------
1531:
1532: =pod
1533:
1.112 bowersj2 1534: =item * select_form($defdom,$name,%hash)
1.88 www 1535:
1536: Returns a string containing a <select name='$name' size='1'> form to
1537: allow a user to select options from a hash option_name => displayed text.
1538: See lonrights.pm for an example invocation and use.
1539:
1540: =cut
1541:
1542: #-------------------------------------------
1543: sub select_form {
1544: my ($def,$name,%hash) = @_;
1545: my $selectform = "<select name=\"$name\" size=\"1\">\n";
1.128 albertel 1546: my @keys;
1547: if (exists($hash{'select_form_order'})) {
1548: @keys=@{$hash{'select_form_order'}};
1549: } else {
1550: @keys=sort(keys(%hash));
1551: }
1.356 albertel 1552: foreach my $key (@keys) {
1553: $selectform.=
1554: '<option value="'.&HTML::Entities::encode($key,'"<>&').'" '.
1555: ($key eq $def ? 'selected="selected" ' : '').
1556: ">".&mt($hash{$key})."</option>\n";
1.88 www 1557: }
1558: $selectform.="</select>";
1559: return $selectform;
1560: }
1561:
1.475 www 1562: # For display filters
1563:
1564: sub display_filter {
1565: if (!$env{'form.show'}) { $env{'form.show'}=10; }
1.477 www 1566: if (!$env{'form.displayfilter'}) { $env{'form.displayfilter'}='currentfolder'; }
1.475 www 1567: return '<nobr><label>'.&mt('Records [_1]',
1568: &Apache::lonmeta::selectbox('show',$env{'form.show'},undef,
1569: (&mt('all'),10,20,50,100,1000,10000))).
1.478 www 1570: '</label></nobr> <nobr>'.
1.475 www 1571: &mt('Filter [_1]',
1.477 www 1572: &select_form($env{'form.displayfilter'},
1573: 'displayfilter',
1574: ('currentfolder' => 'Current folder/page',
1575: 'containing' => 'Containing phrase',
1576: 'none' => 'None'))).
1.478 www 1577: '<input type="text" name="containingphrase" size="30" value="'.&HTML::Entities::encode($env{'form.containingphrase'}).'" /></nobr>';
1.475 www 1578: }
1579:
1.167 www 1580: sub gradeleveldescription {
1581: my $gradelevel=shift;
1582: my %gradelevels=(0 => 'Not specified',
1583: 1 => 'Grade 1',
1584: 2 => 'Grade 2',
1585: 3 => 'Grade 3',
1586: 4 => 'Grade 4',
1587: 5 => 'Grade 5',
1588: 6 => 'Grade 6',
1589: 7 => 'Grade 7',
1590: 8 => 'Grade 8',
1591: 9 => 'Grade 9',
1592: 10 => 'Grade 10',
1593: 11 => 'Grade 11',
1594: 12 => 'Grade 12',
1595: 13 => 'Grade 13',
1596: 14 => '100 Level',
1597: 15 => '200 Level',
1598: 16 => '300 Level',
1599: 17 => '400 Level',
1600: 18 => 'Graduate Level');
1601: return &mt($gradelevels{$gradelevel});
1602: }
1603:
1.163 www 1604: sub select_level_form {
1605: my ($deflevel,$name)=@_;
1606: unless ($deflevel) { $deflevel=0; }
1.167 www 1607: my $selectform = "<select name=\"$name\" size=\"1\">\n";
1608: for (my $i=0; $i<=18; $i++) {
1609: $selectform.="<option value=\"$i\" ".
1.253 albertel 1610: ($i==$deflevel ? 'selected="selected" ' : '').
1.167 www 1611: ">".&gradeleveldescription($i)."</option>\n";
1612: }
1613: $selectform.="</select>";
1614: return $selectform;
1.163 www 1615: }
1.167 www 1616:
1.35 matthew 1617: #-------------------------------------------
1618:
1.45 matthew 1619: =pod
1620:
1.563 raeburn 1621: =item * select_dom_form($defdom,$name,$includeempty,$showdomdesc)
1.35 matthew 1622:
1623: Returns a string containing a <select name='$name' size='1'> form to
1624: allow a user to select the domain to preform an operation in.
1625: See loncreateuser.pm for an example invocation and use.
1626:
1.90 www 1627: If the $includeempty flag is set, it also includes an empty choice ("no domain
1628: selected");
1629:
1.563 raeburn 1630: If the $showdomdesc flag is set, the domain name is followed by the domain description.
1631:
1.35 matthew 1632: =cut
1633:
1634: #-------------------------------------------
1.34 matthew 1635: sub select_dom_form {
1.563 raeburn 1636: my ($defdom,$name,$includeempty,$showdomdesc) = @_;
1.550 albertel 1637: my @domains = sort {lc($a) cmp lc($b)} (&Apache::lonnet::all_domains());
1.90 www 1638: if ($includeempty) { @domains=('',@domains); }
1.34 matthew 1639: my $selectdomain = "<select name=\"$name\" size=\"1\">\n";
1.356 albertel 1640: foreach my $dom (@domains) {
1641: $selectdomain.="<option value=\"$dom\" ".
1.563 raeburn 1642: ($dom eq $defdom ? 'selected="selected" ' : '').'>'.$dom;
1643: if ($showdomdesc) {
1644: if ($dom ne '') {
1645: my $domdesc = &Apache::lonnet::domain($dom,'description');
1646: if ($domdesc ne '') {
1647: $selectdomain .= ' ('.$domdesc.')';
1648: }
1649: }
1650: }
1651: $selectdomain .= "</option>\n";
1.34 matthew 1652: }
1653: $selectdomain.="</select>";
1654: return $selectdomain;
1655: }
1656:
1.35 matthew 1657: #-------------------------------------------
1658:
1.45 matthew 1659: =pod
1660:
1.586 raeburn 1661: =item * home_server_form_item($domain,$name,$defaultflag)
1.35 matthew 1662:
1.586 raeburn 1663: input: 4 arguments (two required, two optional) -
1664: $domain - domain of new user
1665: $name - name of form element
1666: $default - Value of 'default' causes a default item to be first
1667: option, and selected by default.
1668: $hide - Value of 'hide' causes hiding of the name of the server,
1669: if 1 server found, or default, if 0 found.
1.594 raeburn 1670: output: returns 2 items:
1.586 raeburn 1671: (a) form element which contains either:
1672: (i) <select name="$name">
1673: <option value="$hostid1">$hostid $servers{$hostid}</option>
1674: <option value="$hostid2">$hostid $servers{$hostid}</option>
1675: </select>
1676: form item if there are multiple library servers in $domain, or
1677: (ii) an <input type="hidden" name="$name" value="$hostid" /> form item
1678: if there is only one library server in $domain.
1679:
1680: (b) number of library servers found.
1681:
1682: See loncreateuser.pm for example of use.
1.35 matthew 1683:
1684: =cut
1685:
1686: #-------------------------------------------
1.586 raeburn 1687: sub home_server_form_item {
1688: my ($domain,$name,$default,$hide) = @_;
1.513 albertel 1689: my %servers = &Apache::lonnet::get_servers($domain,'library');
1.586 raeburn 1690: my $result;
1691: my $numlib = keys(%servers);
1692: if ($numlib > 1) {
1693: $result .= '<select name="'.$name.'" />'."\n";
1694: if ($default) {
1695: $result .= '<option value="default" selected>'.&mt('default').
1696: '</option>'."\n";
1697: }
1698: foreach my $hostid (sort(keys(%servers))) {
1699: $result.= '<option value="'.$hostid.'">'.
1700: $hostid.' '.$servers{$hostid}."</option>\n";
1701: }
1702: $result .= '</select>'."\n";
1703: } elsif ($numlib == 1) {
1704: my $hostid;
1705: foreach my $item (keys(%servers)) {
1706: $hostid = $item;
1707: }
1708: $result .= '<input type="hidden" name="'.$name.'" value="'.
1709: $hostid.'" />';
1710: if (!$hide) {
1711: $result .= $hostid.' '.$servers{$hostid};
1712: }
1713: $result .= "\n";
1714: } elsif ($default) {
1715: $result .= '<input type="hidden" name="'.$name.
1716: '" value="default" />';
1717: if (!$hide) {
1718: $result .= &mt('default');
1719: }
1720: $result .= "\n";
1.33 matthew 1721: }
1.586 raeburn 1722: return ($result,$numlib);
1.33 matthew 1723: }
1.112 bowersj2 1724:
1725: =pod
1726:
1.534 albertel 1727: =back
1728:
1.112 bowersj2 1729: =cut
1.87 matthew 1730:
1731: ###############################################################
1.112 bowersj2 1732: ## Decoding User Agent ##
1.87 matthew 1733: ###############################################################
1734:
1735: =pod
1736:
1.112 bowersj2 1737: =head1 Decoding the User Agent
1738:
1739: =over 4
1740:
1741: =item * &decode_user_agent()
1.87 matthew 1742:
1743: Inputs: $r
1744:
1745: Outputs:
1746:
1747: =over 4
1748:
1.112 bowersj2 1749: =item * $httpbrowser
1.87 matthew 1750:
1.112 bowersj2 1751: =item * $clientbrowser
1.87 matthew 1752:
1.112 bowersj2 1753: =item * $clientversion
1.87 matthew 1754:
1.112 bowersj2 1755: =item * $clientmathml
1.87 matthew 1756:
1.112 bowersj2 1757: =item * $clientunicode
1.87 matthew 1758:
1.112 bowersj2 1759: =item * $clientos
1.87 matthew 1760:
1761: =back
1762:
1.157 matthew 1763: =back
1764:
1.87 matthew 1765: =cut
1766:
1767: ###############################################################
1768: ###############################################################
1769: sub decode_user_agent {
1.247 albertel 1770: my ($r)=@_;
1.87 matthew 1771: my @browsertype=split(/\&/,$Apache::lonnet::perlvar{"lonBrowsDet"});
1772: my %mathcap=split(/\&/,$$Apache::lonnet::perlvar{"lonMathML"});
1773: my $httpbrowser=$ENV{"HTTP_USER_AGENT"};
1.247 albertel 1774: if (!$httpbrowser && $r) { $httpbrowser=$r->header_in('User-Agent'); }
1.87 matthew 1775: my $clientbrowser='unknown';
1776: my $clientversion='0';
1777: my $clientmathml='';
1778: my $clientunicode='0';
1779: for (my $i=0;$i<=$#browsertype;$i++) {
1780: my ($bname,$match,$notmatch,$vreg,$minv,$univ)=split(/\:/,$browsertype[$i]);
1781: if (($httpbrowser=~/$match/i) && ($httpbrowser!~/$notmatch/i)) {
1782: $clientbrowser=$bname;
1783: $httpbrowser=~/$vreg/i;
1784: $clientversion=$1;
1785: $clientmathml=($clientversion>=$minv);
1786: $clientunicode=($clientversion>=$univ);
1787: }
1788: }
1789: my $clientos='unknown';
1790: if (($httpbrowser=~/linux/i) ||
1791: ($httpbrowser=~/unix/i) ||
1792: ($httpbrowser=~/ux/i) ||
1793: ($httpbrowser=~/solaris/i)) { $clientos='unix'; }
1794: if (($httpbrowser=~/vax/i) ||
1795: ($httpbrowser=~/vms/i)) { $clientos='vms'; }
1796: if ($httpbrowser=~/next/i) { $clientos='next'; }
1797: if (($httpbrowser=~/mac/i) ||
1798: ($httpbrowser=~/powerpc/i)) { $clientos='mac'; }
1799: if ($httpbrowser=~/win/i) { $clientos='win'; }
1800: if ($httpbrowser=~/embed/i) { $clientos='pda'; }
1801: return ($httpbrowser,$clientbrowser,$clientversion,$clientmathml,
1802: $clientunicode,$clientos,);
1803: }
1804:
1.32 matthew 1805: ###############################################################
1806: ## Authentication changing form generation subroutines ##
1807: ###############################################################
1808: ##
1809: ## All of the authform_xxxxxxx subroutines take their inputs in a
1810: ## hash, and have reasonable default values.
1811: ##
1812: ## formname = the name given in the <form> tag.
1.35 matthew 1813: #-------------------------------------------
1814:
1.45 matthew 1815: =pod
1816:
1.112 bowersj2 1817: =head1 Authentication Routines
1818:
1819: =over 4
1820:
1821: =item * authform_xxxxxx
1.35 matthew 1822:
1823: The authform_xxxxxx subroutines provide javascript and html forms which
1824: handle some of the conveniences required for authentication forms.
1825: This is not an optimal method, but it works.
1826:
1827: See loncreateuser.pm for invocation and use examples.
1828:
1829: =over 4
1830:
1.112 bowersj2 1831: =item * authform_header
1.35 matthew 1832:
1.112 bowersj2 1833: =item * authform_authorwarning
1.35 matthew 1834:
1.112 bowersj2 1835: =item * authform_nochange
1.35 matthew 1836:
1.112 bowersj2 1837: =item * authform_kerberos
1.35 matthew 1838:
1.112 bowersj2 1839: =item * authform_internal
1.35 matthew 1840:
1.112 bowersj2 1841: =item * authform_filesystem
1.35 matthew 1842:
1843: =back
1844:
1.157 matthew 1845: =back
1846:
1.35 matthew 1847: =cut
1848:
1849: #-------------------------------------------
1.32 matthew 1850: sub authform_header{
1851: my %in = (
1852: formname => 'cu',
1.80 albertel 1853: kerb_def_dom => '',
1.32 matthew 1854: @_,
1855: );
1856: $in{'formname'} = 'document.' . $in{'formname'};
1857: my $result='';
1.80 albertel 1858:
1859: #---------------------------------------------- Code for upper case translation
1860: my $Javascript_toUpperCase;
1861: unless ($in{kerb_def_dom}) {
1862: $Javascript_toUpperCase =<<"END";
1863: switch (choice) {
1864: case 'krb': currentform.elements[choicearg].value =
1865: currentform.elements[choicearg].value.toUpperCase();
1866: break;
1867: default:
1868: }
1869: END
1870: } else {
1871: $Javascript_toUpperCase = "";
1872: }
1873:
1.165 raeburn 1874: my $radioval = "'nochange'";
1.591 raeburn 1875: if (defined($in{'curr_authtype'})) {
1876: if ($in{'curr_authtype'} ne '') {
1877: $radioval = "'".$in{'curr_authtype'}."arg'";
1878: }
1.174 matthew 1879: }
1.165 raeburn 1880: my $argfield = 'null';
1.591 raeburn 1881: if (defined($in{'mode'})) {
1.165 raeburn 1882: if ($in{'mode'} eq 'modifycourse') {
1.591 raeburn 1883: if (defined($in{'curr_autharg'})) {
1884: if ($in{'curr_autharg'} ne '') {
1.165 raeburn 1885: $argfield = "'$in{'curr_autharg'}'";
1886: }
1887: }
1888: }
1889: }
1890:
1.32 matthew 1891: $result.=<<"END";
1892: var current = new Object();
1.165 raeburn 1893: current.radiovalue = $radioval;
1894: current.argfield = $argfield;
1.32 matthew 1895:
1896: function changed_radio(choice,currentform) {
1897: var choicearg = choice + 'arg';
1898: // If a radio button in changed, we need to change the argfield
1899: if (current.radiovalue != choice) {
1900: current.radiovalue = choice;
1901: if (current.argfield != null) {
1902: currentform.elements[current.argfield].value = '';
1903: }
1904: if (choice == 'nochange') {
1905: current.argfield = null;
1906: } else {
1907: current.argfield = choicearg;
1908: switch(choice) {
1909: case 'krb':
1910: currentform.elements[current.argfield].value =
1911: "$in{'kerb_def_dom'}";
1912: break;
1913: default:
1914: break;
1915: }
1916: }
1917: }
1918: return;
1919: }
1.22 www 1920:
1.32 matthew 1921: function changed_text(choice,currentform) {
1922: var choicearg = choice + 'arg';
1923: if (currentform.elements[choicearg].value !='') {
1.80 albertel 1924: $Javascript_toUpperCase
1.32 matthew 1925: // clear old field
1926: if ((current.argfield != choicearg) && (current.argfield != null)) {
1927: currentform.elements[current.argfield].value = '';
1928: }
1929: current.argfield = choicearg;
1930: }
1931: set_auth_radio_buttons(choice,currentform);
1932: return;
1.20 www 1933: }
1.32 matthew 1934:
1935: function set_auth_radio_buttons(newvalue,currentform) {
1936: var i=0;
1937: while (i < currentform.login.length) {
1938: if (currentform.login[i].value == newvalue) { break; }
1939: i++;
1940: }
1941: if (i == currentform.login.length) {
1942: return;
1943: }
1944: current.radiovalue = newvalue;
1945: currentform.login[i].checked = true;
1946: return;
1947: }
1948: END
1949: return $result;
1950: }
1951:
1952: sub authform_authorwarning{
1953: my $result='';
1.144 matthew 1954: $result='<i>'.
1955: &mt('As a general rule, only authors or co-authors should be '.
1956: 'filesystem authenticated '.
1957: '(which allows access to the server filesystem).')."</i>\n";
1.32 matthew 1958: return $result;
1959: }
1960:
1961: sub authform_nochange{
1962: my %in = (
1963: formname => 'document.cu',
1964: kerb_def_dom => 'MSU.EDU',
1965: @_,
1966: );
1.586 raeburn 1967: my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'});
1968: my $result;
1969: if (keys(%can_assign) == 0) {
1970: $result = &mt('Under you current role you are not permitted to change login settings for this user');
1971: } else {
1972: $result = '<label>'.&mt('[_1] Do not change login data',
1973: '<input type="radio" name="login" value="nochange" '.
1974: 'checked="checked" onclick="'.
1.281 albertel 1975: "javascript:changed_radio('nochange',$in{'formname'});".'" />').
1976: '</label>';
1.586 raeburn 1977: }
1.32 matthew 1978: return $result;
1979: }
1980:
1.591 raeburn 1981: sub authform_kerberos {
1.32 matthew 1982: my %in = (
1983: formname => 'document.cu',
1984: kerb_def_dom => 'MSU.EDU',
1.80 albertel 1985: kerb_def_auth => 'krb4',
1.32 matthew 1986: @_,
1987: );
1.586 raeburn 1988: my ($check4,$check5,$krbcheck,$krbarg,$krbver,$result,$authtype,
1989: $autharg,$jscall);
1990: my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'});
1.80 albertel 1991: if ($in{'kerb_def_auth'} eq 'krb5') {
1.586 raeburn 1992: $check5 = ' checked="on"';
1.80 albertel 1993: } else {
1.586 raeburn 1994: $check4 = ' checked="on"';
1.80 albertel 1995: }
1.165 raeburn 1996: $krbarg = $in{'kerb_def_dom'};
1.591 raeburn 1997: if (defined($in{'curr_authtype'})) {
1998: if ($in{'curr_authtype'} eq 'krb') {
1.586 raeburn 1999: $krbcheck = ' checked="on"';
1.623 raeburn 2000: if (defined($in{'mode'})) {
2001: if ($in{'mode'} eq 'modifyuser') {
2002: $krbcheck = '';
2003: }
2004: }
1.591 raeburn 2005: if (defined($in{'curr_kerb_ver'})) {
2006: if ($in{'curr_krb_ver'} eq '5') {
2007: $check5 = ' checked="on"';
2008: $check4 = '';
2009: } else {
2010: $check4 = ' checked="on"';
2011: $check5 = '';
2012: }
1.586 raeburn 2013: }
1.591 raeburn 2014: if (defined($in{'curr_autharg'})) {
1.165 raeburn 2015: $krbarg = $in{'curr_autharg'};
2016: }
1.586 raeburn 2017: if (!$can_assign{'krb4'} && !$can_assign{'krb5'}) {
1.591 raeburn 2018: if (defined($in{'curr_autharg'})) {
1.586 raeburn 2019: $result =
2020: &mt('Currently Kerberos authenticated with domain [_1] Version [_2].',
2021: $in{'curr_autharg'},$krbver);
2022: } else {
2023: $result =
2024: &mt('Currently Kerberos authenticated, Version [_1].',$krbver);
2025: }
2026: return $result;
2027: }
2028: }
2029: } else {
2030: if ($authnum == 1) {
2031: $authtype = '<input type="hidden" name="login" value="krb">';
1.165 raeburn 2032: }
2033: }
1.586 raeburn 2034: if (!$can_assign{'krb4'} && !$can_assign{'krb5'}) {
2035: return;
1.587 raeburn 2036: } elsif ($authtype eq '') {
1.591 raeburn 2037: if (defined($in{'mode'})) {
1.587 raeburn 2038: if ($in{'mode'} eq 'modifycourse') {
2039: if ($authnum == 1) {
2040: $authtype = '<input type="hidden" name="login" value="krb">';
2041: }
2042: }
2043: }
1.586 raeburn 2044: }
2045: $jscall = "javascript:changed_radio('krb',$in{'formname'});";
2046: if ($authtype eq '') {
2047: $authtype = '<input type="radio" name="login" value="krb" '.
2048: 'onclick="'.$jscall.'" onchange="'.$jscall.'"'.
2049: $krbcheck.' />';
2050: }
2051: if (($can_assign{'krb4'} && $can_assign{'krb5'}) ||
2052: ($can_assign{'krb4'} && !$can_assign{'krb5'} &&
2053: $in{'curr_authtype'} eq 'krb5') ||
2054: (!$can_assign{'krb4'} && $can_assign{'krb5'} &&
2055: $in{'curr_authtype'} eq 'krb4')) {
2056: $result .= &mt
1.144 matthew 2057: ('[_1] Kerberos authenticated with domain [_2] '.
1.281 albertel 2058: '[_3] Version 4 [_4] Version 5 [_5]',
1.586 raeburn 2059: '<label>'.$authtype,
1.281 albertel 2060: '</label><input type="text" size="10" name="krbarg" '.
1.165 raeburn 2061: 'value="'.$krbarg.'" '.
1.144 matthew 2062: 'onchange="'.$jscall.'" />',
1.281 albertel 2063: '<label><input type="radio" name="krbver" value="4" '.$check4.' />',
2064: '</label><label><input type="radio" name="krbver" value="5" '.$check5.' />',
2065: '</label>');
1.586 raeburn 2066: } elsif ($can_assign{'krb4'}) {
2067: $result .= &mt
2068: ('[_1] Kerberos authenticated with domain [_2] '.
2069: '[_3] Version 4 [_4]',
2070: '<label>'.$authtype,
2071: '</label><input type="text" size="10" name="krbarg" '.
2072: 'value="'.$krbarg.'" '.
2073: 'onchange="'.$jscall.'" />',
2074: '<label><input type="hidden" name="krbver" value="4" />',
2075: '</label>');
2076: } elsif ($can_assign{'krb5'}) {
2077: $result .= &mt
2078: ('[_1] Kerberos authenticated with domain [_2] '.
2079: '[_3] Version 5 [_4]',
2080: '<label>'.$authtype,
2081: '</label><input type="text" size="10" name="krbarg" '.
2082: 'value="'.$krbarg.'" '.
2083: 'onchange="'.$jscall.'" />',
2084: '<label><input type="hidden" name="krbver" value="5" />',
2085: '</label>');
2086: }
1.32 matthew 2087: return $result;
2088: }
2089:
2090: sub authform_internal{
1.586 raeburn 2091: my %in = (
1.32 matthew 2092: formname => 'document.cu',
2093: kerb_def_dom => 'MSU.EDU',
2094: @_,
2095: );
1.586 raeburn 2096: my ($intcheck,$intarg,$result,$authtype,$autharg,$jscall);
2097: my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'});
1.591 raeburn 2098: if (defined($in{'curr_authtype'})) {
2099: if ($in{'curr_authtype'} eq 'int') {
1.586 raeburn 2100: if ($can_assign{'int'}) {
2101: $intcheck = 'checked="on" ';
1.623 raeburn 2102: if (defined($in{'mode'})) {
2103: if ($in{'mode'} eq 'modifyuser') {
2104: $intcheck = '';
2105: }
2106: }
1.591 raeburn 2107: if (defined($in{'curr_autharg'})) {
1.586 raeburn 2108: $intarg = $in{'curr_autharg'};
2109: }
2110: } else {
2111: $result = &mt('Currently internally authenticated.');
2112: return $result;
1.165 raeburn 2113: }
2114: }
1.586 raeburn 2115: } else {
2116: if ($authnum == 1) {
2117: $authtype = '<input type="hidden" name="login" value="int">';
2118: }
2119: }
2120: if (!$can_assign{'int'}) {
2121: return;
1.587 raeburn 2122: } elsif ($authtype eq '') {
1.591 raeburn 2123: if (defined($in{'mode'})) {
1.587 raeburn 2124: if ($in{'mode'} eq 'modifycourse') {
2125: if ($authnum == 1) {
2126: $authtype = '<input type="hidden" name="login" value="int">';
2127: }
2128: }
2129: }
1.165 raeburn 2130: }
1.586 raeburn 2131: $jscall = "javascript:changed_radio('int',$in{'formname'});";
2132: if ($authtype eq '') {
2133: $authtype = '<input type="radio" name="login" value="int" '.$intcheck.
2134: ' onchange="'.$jscall.'" onclick="'.$jscall.'" />';
2135: }
1.605 bisitz 2136: $autharg = '<input type="password" size="10" name="intarg" value="'.
1.586 raeburn 2137: $intarg.'" onchange="'.$jscall.'" />';
2138: $result = &mt
1.144 matthew 2139: ('[_1] Internally authenticated (with initial password [_2])',
1.586 raeburn 2140: '<label>'.$authtype,'</label>'.$autharg);
1.620 www 2141: $result.="<label><input type=\"checkbox\" name=\"visible\" onClick='if (this.checked) { this.form.intarg.type=\"text\" } else { this.form.intarg.type=\"password\" }' />".&mt('Visible input').'</label>';
1.32 matthew 2142: return $result;
2143: }
2144:
2145: sub authform_local{
2146: my %in = (
2147: formname => 'document.cu',
2148: kerb_def_dom => 'MSU.EDU',
2149: @_,
2150: );
1.586 raeburn 2151: my ($loccheck,$locarg,$result,$authtype,$autharg,$jscall);
2152: my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'});
1.591 raeburn 2153: if (defined($in{'curr_authtype'})) {
2154: if ($in{'curr_authtype'} eq 'loc') {
1.586 raeburn 2155: if ($can_assign{'loc'}) {
2156: $loccheck = 'checked="on" ';
1.623 raeburn 2157: if (defined($in{'mode'})) {
2158: if ($in{'mode'} eq 'modifyuser') {
2159: $loccheck = '';
2160: }
2161: }
1.591 raeburn 2162: if (defined($in{'curr_autharg'})) {
1.586 raeburn 2163: $locarg = $in{'curr_autharg'};
2164: }
2165: } else {
2166: $result = &mt('Currently using local (institutional) authentication.');
2167: return $result;
1.165 raeburn 2168: }
2169: }
1.586 raeburn 2170: } else {
2171: if ($authnum == 1) {
2172: $authtype = '<input type="hidden" name="login" value="loc">';
2173: }
2174: }
2175: if (!$can_assign{'loc'}) {
2176: return;
1.587 raeburn 2177: } elsif ($authtype eq '') {
1.591 raeburn 2178: if (defined($in{'mode'})) {
1.587 raeburn 2179: if ($in{'mode'} eq 'modifycourse') {
2180: if ($authnum == 1) {
2181: $authtype = '<input type="hidden" name="login" value="loc">';
2182: }
2183: }
2184: }
1.165 raeburn 2185: }
1.586 raeburn 2186: $jscall = "javascript:changed_radio('loc',$in{'formname'});";
2187: if ($authtype eq '') {
2188: $authtype = '<input type="radio" name="login" value="loc" '.
2189: $loccheck.' onchange="'.$jscall.'" onclick="'.
2190: $jscall.'" />';
2191: }
2192: $autharg = '<input type="text" size="10" name="locarg" value="'.
2193: $locarg.'" onchange="'.$jscall.'" />';
2194: $result = &mt('[_1] Local Authentication with argument [_2]',
2195: '<label>'.$authtype,'</label>'.$autharg);
1.32 matthew 2196: return $result;
2197: }
2198:
2199: sub authform_filesystem{
2200: my %in = (
2201: formname => 'document.cu',
2202: kerb_def_dom => 'MSU.EDU',
2203: @_,
2204: );
1.586 raeburn 2205: my ($fsyscheck,$result,$authtype,$autharg,$jscall);
2206: my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'});
1.591 raeburn 2207: if (defined($in{'curr_authtype'})) {
2208: if ($in{'curr_authtype'} eq 'fsys') {
1.586 raeburn 2209: if ($can_assign{'fsys'}) {
2210: $fsyscheck = 'checked="on" ';
1.623 raeburn 2211: if (defined($in{'mode'})) {
2212: if ($in{'mode'} eq 'modifyuser') {
2213: $fsyscheck = '';
2214: }
2215: }
1.586 raeburn 2216: } else {
2217: $result = &mt('Currently Filesystem Authenticated.');
2218: return $result;
2219: }
2220: }
2221: } else {
2222: if ($authnum == 1) {
2223: $authtype = '<input type="hidden" name="login" value="fsys">';
2224: }
2225: }
2226: if (!$can_assign{'fsys'}) {
2227: return;
1.587 raeburn 2228: } elsif ($authtype eq '') {
1.591 raeburn 2229: if (defined($in{'mode'})) {
1.587 raeburn 2230: if ($in{'mode'} eq 'modifycourse') {
2231: if ($authnum == 1) {
2232: $authtype = '<input type="hidden" name="login" value="fsys">';
2233: }
2234: }
2235: }
1.586 raeburn 2236: }
2237: $jscall = "javascript:changed_radio('fsys',$in{'formname'});";
2238: if ($authtype eq '') {
2239: $authtype = '<input type="radio" name="login" value="fsys" '.
2240: $fsyscheck.' onchange="'.$jscall.'" onclick="'.
2241: $jscall.'" />';
2242: }
2243: $autharg = '<input type="text" size="10" name="fsysarg" value=""'.
2244: ' onchange="'.$jscall.'" />';
2245: $result = &mt
1.144 matthew 2246: ('[_1] Filesystem Authenticated (with initial password [_2])',
1.281 albertel 2247: '<label><input type="radio" name="login" value="fsys" '.
1.586 raeburn 2248: $fsyscheck.'onchange="'.$jscall.'" onclick="'.$jscall.'" />',
1.605 bisitz 2249: '</label><input type="password" size="10" name="fsysarg" value="" '.
1.144 matthew 2250: 'onchange="'.$jscall.'" />');
1.32 matthew 2251: return $result;
2252: }
2253:
1.586 raeburn 2254: sub get_assignable_auth {
2255: my ($dom) = @_;
2256: if ($dom eq '') {
2257: $dom = $env{'request.role.domain'};
2258: }
2259: my %can_assign = (
2260: krb4 => 1,
2261: krb5 => 1,
2262: int => 1,
2263: loc => 1,
2264: );
2265: my %domconfig = &Apache::lonnet::get_dom('configuration',['usercreation'],$dom);
2266: if (ref($domconfig{'usercreation'}) eq 'HASH') {
2267: if (ref($domconfig{'usercreation'}{'authtypes'}) eq 'HASH') {
2268: my $authhash = $domconfig{'usercreation'}{'authtypes'};
2269: my $context;
2270: if ($env{'request.role'} =~ /^au/) {
2271: $context = 'author';
2272: } elsif ($env{'request.role'} =~ /^dc/) {
2273: $context = 'domain';
2274: } elsif ($env{'request.course.id'}) {
2275: $context = 'course';
2276: }
2277: if ($context) {
2278: if (ref($authhash->{$context}) eq 'HASH') {
2279: %can_assign = %{$authhash->{$context}};
2280: }
2281: }
2282: }
2283: }
2284: my $authnum = 0;
2285: foreach my $key (keys(%can_assign)) {
2286: if ($can_assign{$key}) {
2287: $authnum ++;
2288: }
2289: }
2290: if ($can_assign{'krb4'} && $can_assign{'krb5'}) {
2291: $authnum --;
2292: }
2293: return ($authnum,%can_assign);
2294: }
2295:
1.80 albertel 2296: ###############################################################
2297: ## Get Kerberos Defaults for Domain ##
2298: ###############################################################
2299: ##
2300: ## Returns default kerberos version and an associated argument
2301: ## as listed in file domain.tab. If not listed, provides
2302: ## appropriate default domain and kerberos version.
2303: ##
2304: #-------------------------------------------
2305:
2306: =pod
2307:
1.112 bowersj2 2308: =item * get_kerberos_defaults
1.80 albertel 2309:
2310: get_kerberos_defaults($target_domain) returns the default kerberos
1.641 raeburn 2311: version and domain. If not found, it defaults to version 4 and the
2312: domain of the server.
1.80 albertel 2313:
2314: ($def_version, $def_krb_domain) = &get_kerberos_defaults($target_domain);
2315:
2316: =cut
2317:
2318: #-------------------------------------------
2319: sub get_kerberos_defaults {
2320: my $domain=shift;
1.641 raeburn 2321: my ($krbdef,$krbdefdom);
2322: my %domdefaults = &Apache::lonnet::get_domain_defaults($domain);
2323: if (($domdefaults{'auth_def'} =~/^krb(4|5)$/) && ($domdefaults{'auth_arg_def'} ne '')) {
2324: $krbdef = $domdefaults{'auth_def'};
2325: $krbdefdom = $domdefaults{'auth_arg_def'};
2326: } else {
1.80 albertel 2327: $ENV{'SERVER_NAME'}=~/(\w+\.\w+)$/;
2328: my $krbdefdom=$1;
2329: $krbdefdom=~tr/a-z/A-Z/;
2330: $krbdef = "krb4";
2331: }
2332: return ($krbdef,$krbdefdom);
2333: }
1.112 bowersj2 2334:
2335: =pod
2336:
2337: =back
2338:
2339: =cut
1.32 matthew 2340:
1.46 matthew 2341: ###############################################################
2342: ## Thesaurus Functions ##
2343: ###############################################################
1.20 www 2344:
1.46 matthew 2345: =pod
1.20 www 2346:
1.112 bowersj2 2347: =head1 Thesaurus Functions
2348:
2349: =over 4
2350:
2351: =item * initialize_keywords
1.46 matthew 2352:
2353: Initializes the package variable %Keywords if it is empty. Uses the
2354: package variable $thesaurus_db_file.
2355:
2356: =cut
2357:
2358: ###################################################
2359:
2360: sub initialize_keywords {
2361: return 1 if (scalar keys(%Keywords));
2362: # If we are here, %Keywords is empty, so fill it up
2363: # Make sure the file we need exists...
2364: if (! -e $thesaurus_db_file) {
2365: &Apache::lonnet::logthis("Attempt to access $thesaurus_db_file".
2366: " failed because it does not exist");
2367: return 0;
2368: }
2369: # Set up the hash as a database
2370: my %thesaurus_db;
2371: if (! tie(%thesaurus_db,'GDBM_File',
1.53 albertel 2372: $thesaurus_db_file,&GDBM_READER(),0640)){
1.46 matthew 2373: &Apache::lonnet::logthis("Could not tie \%thesaurus_db to ".
2374: $thesaurus_db_file);
2375: return 0;
2376: }
2377: # Get the average number of appearances of a word.
2378: my $avecount = $thesaurus_db{'average.count'};
2379: # Put keywords (those that appear > average) into %Keywords
2380: while (my ($word,$data)=each (%thesaurus_db)) {
2381: my ($count,undef) = split /:/,$data;
2382: $Keywords{$word}++ if ($count > $avecount);
2383: }
2384: untie %thesaurus_db;
2385: # Remove special values from %Keywords.
1.356 albertel 2386: foreach my $value ('total.count','average.count') {
2387: delete($Keywords{$value}) if (exists($Keywords{$value}));
1.586 raeburn 2388: }
1.46 matthew 2389: return 1;
2390: }
2391:
2392: ###################################################
2393:
2394: =pod
2395:
1.112 bowersj2 2396: =item * keyword($word)
1.46 matthew 2397:
2398: Returns true if $word is a keyword. A keyword is a word that appears more
2399: than the average number of times in the thesaurus database. Calls
2400: &initialize_keywords
2401:
2402: =cut
2403:
2404: ###################################################
1.20 www 2405:
2406: sub keyword {
1.46 matthew 2407: return if (!&initialize_keywords());
2408: my $word=lc(shift());
2409: $word=~s/\W//g;
2410: return exists($Keywords{$word});
1.20 www 2411: }
1.46 matthew 2412:
2413: ###############################################################
2414:
2415: =pod
1.20 www 2416:
1.112 bowersj2 2417: =item * get_related_words
1.46 matthew 2418:
1.160 matthew 2419: Look up a word in the thesaurus. Takes a scalar argument and returns
1.46 matthew 2420: an array of words. If the keyword is not in the thesaurus, an empty array
2421: will be returned. The order of the words returned is determined by the
2422: database which holds them.
2423:
2424: Uses global $thesaurus_db_file.
2425:
2426: =cut
2427:
2428: ###############################################################
2429: sub get_related_words {
2430: my $keyword = shift;
2431: my %thesaurus_db;
2432: if (! -e $thesaurus_db_file) {
2433: &Apache::lonnet::logthis("Attempt to access $thesaurus_db_file ".
2434: "failed because the file does not exist");
2435: return ();
2436: }
2437: if (! tie(%thesaurus_db,'GDBM_File',
1.53 albertel 2438: $thesaurus_db_file,&GDBM_READER(),0640)){
1.46 matthew 2439: return ();
2440: }
2441: my @Words=();
1.429 www 2442: my $count=0;
1.46 matthew 2443: if (exists($thesaurus_db{$keyword})) {
1.356 albertel 2444: # The first element is the number of times
2445: # the word appears. We do not need it now.
1.429 www 2446: my (undef,@RelatedWords) = (split(/:/,$thesaurus_db{$keyword}));
2447: my (undef,$mostfrequentcount)=split(/\,/,$RelatedWords[0]);
2448: my $threshold=$mostfrequentcount/10;
2449: foreach my $possibleword (@RelatedWords) {
2450: my ($word,$wordcount)=split(/\,/,$possibleword);
2451: if ($wordcount>$threshold) {
2452: push(@Words,$word);
2453: $count++;
2454: if ($count>10) { last; }
2455: }
1.20 www 2456: }
2457: }
1.46 matthew 2458: untie %thesaurus_db;
2459: return @Words;
1.14 harris41 2460: }
1.46 matthew 2461:
1.112 bowersj2 2462: =pod
2463:
2464: =back
2465:
2466: =cut
1.61 www 2467:
2468: # -------------------------------------------------------------- Plaintext name
1.81 albertel 2469: =pod
2470:
1.112 bowersj2 2471: =head1 User Name Functions
2472:
2473: =over 4
2474:
1.226 albertel 2475: =item * plainname($uname,$udom,$first)
1.81 albertel 2476:
1.112 bowersj2 2477: Takes a users logon name and returns it as a string in
1.226 albertel 2478: "first middle last generation" form
2479: if $first is set to 'lastname' then it returns it as
2480: 'lastname generation, firstname middlename' if their is a lastname
1.81 albertel 2481:
2482: =cut
1.61 www 2483:
1.295 www 2484:
1.81 albertel 2485: ###############################################################
1.61 www 2486: sub plainname {
1.226 albertel 2487: my ($uname,$udom,$first)=@_;
1.537 albertel 2488: return if (!defined($uname) || !defined($udom));
1.295 www 2489: my %names=&getnames($uname,$udom);
1.226 albertel 2490: my $name=&Apache::lonnet::format_name($names{'firstname'},
2491: $names{'middlename'},
2492: $names{'lastname'},
2493: $names{'generation'},$first);
2494: $name=~s/^\s+//;
1.62 www 2495: $name=~s/\s+$//;
2496: $name=~s/\s+/ /g;
1.353 albertel 2497: if ($name !~ /\S/) { $name=$uname.':'.$udom; }
1.62 www 2498: return $name;
1.61 www 2499: }
1.66 www 2500:
2501: # -------------------------------------------------------------------- Nickname
1.81 albertel 2502: =pod
2503:
1.112 bowersj2 2504: =item * nickname($uname,$udom)
1.81 albertel 2505:
2506: Gets a users name and returns it as a string as
2507:
2508: ""nickname""
1.66 www 2509:
1.81 albertel 2510: if the user has a nickname or
2511:
2512: "first middle last generation"
2513:
2514: if the user does not
2515:
2516: =cut
1.66 www 2517:
2518: sub nickname {
2519: my ($uname,$udom)=@_;
1.537 albertel 2520: return if (!defined($uname) || !defined($udom));
1.295 www 2521: my %names=&getnames($uname,$udom);
1.68 albertel 2522: my $name=$names{'nickname'};
1.66 www 2523: if ($name) {
2524: $name='"'.$name.'"';
2525: } else {
2526: $name=$names{'firstname'}.' '.$names{'middlename'}.' '.
2527: $names{'lastname'}.' '.$names{'generation'};
2528: $name=~s/\s+$//;
2529: $name=~s/\s+/ /g;
2530: }
2531: return $name;
2532: }
2533:
1.295 www 2534: sub getnames {
2535: my ($uname,$udom)=@_;
1.537 albertel 2536: return if (!defined($uname) || !defined($udom));
1.433 albertel 2537: if ($udom eq 'public' && $uname eq 'public') {
2538: return ('lastname' => &mt('Public'));
2539: }
1.295 www 2540: my $id=$uname.':'.$udom;
2541: my ($names,$cached)=&Apache::lonnet::is_cached_new('namescache',$id);
2542: if ($cached) {
2543: return %{$names};
2544: } else {
2545: my %loadnames=&Apache::lonnet::get('environment',
2546: ['firstname','middlename','lastname','generation','nickname'],
2547: $udom,$uname);
2548: &Apache::lonnet::do_cache_new('namescache',$id,\%loadnames);
2549: return %loadnames;
2550: }
2551: }
1.61 www 2552:
1.542 raeburn 2553: # -------------------------------------------------------------------- getemails
2554: =pod
2555:
2556: =item * getemails($uname,$udom)
2557:
2558: Gets a user's email information and returns it as a hash with keys:
2559: notification, critnotification, permanentemail
2560:
2561: For notification and critnotification, values are comma-separated lists
2562: of e-mail address(es); for permanentemail, value is a single e-mail address.
2563:
2564: =cut
2565:
1.466 albertel 2566: sub getemails {
2567: my ($uname,$udom)=@_;
2568: if ($udom eq 'public' && $uname eq 'public') {
2569: return;
2570: }
1.467 www 2571: if (!$udom) { $udom=$env{'user.domain'}; }
2572: if (!$uname) { $uname=$env{'user.name'}; }
1.466 albertel 2573: my $id=$uname.':'.$udom;
2574: my ($names,$cached)=&Apache::lonnet::is_cached_new('emailscache',$id);
2575: if ($cached) {
2576: return %{$names};
2577: } else {
2578: my %loadnames=&Apache::lonnet::get('environment',
2579: ['notification','critnotification',
2580: 'permanentemail'],
2581: $udom,$uname);
2582: &Apache::lonnet::do_cache_new('emailscache',$id,\%loadnames);
2583: return %loadnames;
2584: }
2585: }
2586:
1.551 albertel 2587: sub flush_email_cache {
2588: my ($uname,$udom)=@_;
2589: if (!$udom) { $udom =$env{'user.domain'}; }
2590: if (!$uname) { $uname=$env{'user.name'}; }
2591: return if ($udom eq 'public' && $uname eq 'public');
2592: my $id=$uname.':'.$udom;
2593: &Apache::lonnet::devalidate_cache_new('emailscache',$id);
2594: }
2595:
1.61 www 2596: # ------------------------------------------------------------------ Screenname
1.81 albertel 2597:
2598: =pod
2599:
1.112 bowersj2 2600: =item * screenname($uname,$udom)
1.81 albertel 2601:
2602: Gets a users screenname and returns it as a string
2603:
2604: =cut
1.61 www 2605:
2606: sub screenname {
2607: my ($uname,$udom)=@_;
1.258 albertel 2608: if ($uname eq $env{'user.name'} &&
2609: $udom eq $env{'user.domain'}) {return $env{'environment.screenname'};}
1.212 albertel 2610: my %names=&Apache::lonnet::get('environment',['screenname'],$udom,$uname);
1.68 albertel 2611: return $names{'screenname'};
1.62 www 2612: }
2613:
1.212 albertel 2614:
1.62 www 2615: # ------------------------------------------------------------- Message Wrapper
2616:
2617: sub messagewrapper {
1.369 www 2618: my ($link,$username,$domain,$subject,$text)=@_;
1.62 www 2619: return
1.441 albertel 2620: '<a href="/adm/email?compose=individual&'.
2621: 'recname='.$username.'&recdom='.$domain.
2622: '&subject='.&escape($subject).'&text='.&escape($text).'" '.
1.200 matthew 2623: 'title="'.&mt('Send message').'">'.$link.'</a>';
1.74 www 2624: }
2625: # --------------------------------------------------------------- Notes Wrapper
2626:
2627: sub noteswrapper {
2628: my ($link,$un,$do)=@_;
2629: return
2630: "<a href='/adm/email?recordftf=retrieve&recname=$un&recdom=$do'>$link</a>";
1.62 www 2631: }
2632: # ------------------------------------------------------------- Aboutme Wrapper
2633:
2634: sub aboutmewrapper {
1.166 www 2635: my ($link,$username,$domain,$target)=@_;
1.447 raeburn 2636: if (!defined($username) && !defined($domain)) {
2637: return;
2638: }
1.205 www 2639: return '<a href="/adm/'.$domain.'/'.$username.'/aboutme"'.
1.454 banghart 2640: ($target?' target="$target"':'').' title="'.&mt("View this user's personal page").'">'.$link.'</a>';
1.62 www 2641: }
2642:
2643: # ------------------------------------------------------------ Syllabus Wrapper
2644:
2645:
2646: sub syllabuswrapper {
1.109 matthew 2647: my ($linktext,$coursedir,$domain,$fontcolor)=@_;
2648: if ($fontcolor) {
2649: $linktext='<font color="'.$fontcolor.'">'.$linktext.'</font>';
2650: }
1.208 matthew 2651: return qq{<a href="/public/$domain/$coursedir/syllabus">$linktext</a>};
1.61 www 2652: }
1.14 harris41 2653:
1.208 matthew 2654: sub track_student_link {
1.268 albertel 2655: my ($linktext,$sname,$sdom,$target,$start) = @_;
2656: my $link ="/adm/trackstudent?";
1.208 matthew 2657: my $title = 'View recent activity';
2658: if (defined($sname) && $sname !~ /^\s*$/ &&
2659: defined($sdom) && $sdom !~ /^\s*$/) {
1.268 albertel 2660: $link .= "selected_student=$sname:$sdom";
1.208 matthew 2661: $title .= ' of this student';
1.268 albertel 2662: }
1.208 matthew 2663: if (defined($target) && $target !~ /^\s*$/) {
2664: $target = qq{target="$target"};
2665: } else {
2666: $target = '';
2667: }
1.268 albertel 2668: if ($start) { $link.='&start='.$start; }
1.554 albertel 2669: $title = &mt($title);
2670: $linktext = &mt($linktext);
1.448 albertel 2671: return qq{<a href="$link" title="$title" $target>$linktext</a>}.
2672: &help_open_topic('View_recent_activity');
1.208 matthew 2673: }
2674:
1.508 www 2675: # ===================================================== Display a student photo
2676:
2677:
1.509 albertel 2678: sub student_image_tag {
1.508 www 2679: my ($domain,$user)=@_;
2680: my $imgsrc=&Apache::lonnet::studentphoto($domain,$user,'jpg');
2681: if (($imgsrc) && ($imgsrc ne '/adm/lonKaputt/lonlogo_broken.gif')) {
2682: return '<img src="'.$imgsrc.'" align="right" />';
2683: } else {
2684: return '';
2685: }
2686: }
2687:
1.112 bowersj2 2688: =pod
2689:
2690: =back
2691:
2692: =head1 Access .tab File Data
2693:
2694: =over 4
2695:
2696: =item * languageids()
2697:
2698: returns list of all language ids
2699:
2700: =cut
2701:
1.14 harris41 2702: sub languageids {
1.16 harris41 2703: return sort(keys(%language));
1.14 harris41 2704: }
2705:
1.112 bowersj2 2706: =pod
2707:
2708: =item * languagedescription()
2709:
2710: returns description of a specified language id
2711:
2712: =cut
2713:
1.14 harris41 2714: sub languagedescription {
1.125 www 2715: my $code=shift;
2716: return ($supported_language{$code}?'* ':'').
2717: $language{$code}.
1.126 www 2718: ($supported_language{$code}?' ('.&mt('interface available').')':'');
1.145 www 2719: }
2720:
2721: sub plainlanguagedescription {
2722: my $code=shift;
2723: return $language{$code};
2724: }
2725:
2726: sub supportedlanguagecode {
2727: my $code=shift;
2728: return $supported_language{$code};
1.97 www 2729: }
2730:
1.112 bowersj2 2731: =pod
2732:
2733: =item * copyrightids()
2734:
2735: returns list of all copyrights
2736:
2737: =cut
2738:
2739: sub copyrightids {
2740: return sort(keys(%cprtag));
2741: }
2742:
2743: =pod
2744:
2745: =item * copyrightdescription()
2746:
2747: returns description of a specified copyright id
2748:
2749: =cut
2750:
2751: sub copyrightdescription {
1.166 www 2752: return &mt($cprtag{shift(@_)});
1.112 bowersj2 2753: }
1.197 matthew 2754:
2755: =pod
2756:
1.192 taceyjo1 2757: =item * source_copyrightids()
2758:
2759: returns list of all source copyrights
2760:
2761: =cut
2762:
2763: sub source_copyrightids {
2764: return sort(keys(%scprtag));
2765: }
2766:
2767: =pod
2768:
2769: =item * source_copyrightdescription()
2770:
2771: returns description of a specified source copyright id
2772:
2773: =cut
2774:
2775: sub source_copyrightdescription {
2776: return &mt($scprtag{shift(@_)});
2777: }
1.112 bowersj2 2778:
2779: =pod
2780:
2781: =item * filecategories()
2782:
2783: returns list of all file categories
2784:
2785: =cut
2786:
2787: sub filecategories {
2788: return sort(keys(%category_extensions));
2789: }
2790:
2791: =pod
2792:
2793: =item * filecategorytypes()
2794:
2795: returns list of file types belonging to a given file
2796: category
2797:
2798: =cut
2799:
2800: sub filecategorytypes {
1.356 albertel 2801: my ($cat) = @_;
2802: return @{$category_extensions{lc($cat)}};
1.112 bowersj2 2803: }
2804:
2805: =pod
2806:
2807: =item * fileembstyle()
2808:
2809: returns embedding style for a specified file type
2810:
2811: =cut
2812:
2813: sub fileembstyle {
2814: return $fe{lc(shift(@_))};
1.169 www 2815: }
2816:
1.351 www 2817: sub filemimetype {
2818: return $fm{lc(shift(@_))};
2819: }
2820:
1.169 www 2821:
2822: sub filecategoryselect {
2823: my ($name,$value)=@_;
1.189 matthew 2824: return &select_form($value,$name,
1.169 www 2825: '' => &mt('Any category'),
2826: map { $_,$_ } sort(keys(%category_extensions)));
1.112 bowersj2 2827: }
2828:
2829: =pod
2830:
2831: =item * filedescription()
2832:
2833: returns description for a specified file type
2834:
2835: =cut
2836:
2837: sub filedescription {
1.188 matthew 2838: my $file_description = $fd{lc(shift())};
2839: $file_description =~ s:([\[\]]):~$1:g;
2840: return &mt($file_description);
1.112 bowersj2 2841: }
2842:
2843: =pod
2844:
2845: =item * filedescriptionex()
2846:
2847: returns description for a specified file type with
2848: extra formatting
2849:
2850: =cut
2851:
2852: sub filedescriptionex {
2853: my $ex=shift;
1.188 matthew 2854: my $file_description = $fd{lc($ex)};
2855: $file_description =~ s:([\[\]]):~$1:g;
2856: return '.'.$ex.' '.&mt($file_description);
1.112 bowersj2 2857: }
2858:
2859: # End of .tab access
2860: =pod
2861:
2862: =back
2863:
2864: =cut
2865:
2866: # ------------------------------------------------------------------ File Types
2867: sub fileextensions {
2868: return sort(keys(%fe));
2869: }
2870:
1.97 www 2871: # ----------------------------------------------------------- Display Languages
2872: # returns a hash with all desired display languages
2873: #
2874:
2875: sub display_languages {
2876: my %languages=();
1.356 albertel 2877: foreach my $lang (&preferred_languages()) {
2878: $languages{$lang}=1;
1.97 www 2879: }
2880: &get_unprocessed_cgi($ENV{'QUERY_STRING'},['displaylanguage']);
1.258 albertel 2881: if ($env{'form.displaylanguage'}) {
1.356 albertel 2882: foreach my $lang (split(/\s*(\,|\;|\:)\s*/,$env{'form.displaylanguage'})) {
2883: $languages{$lang}=1;
1.97 www 2884: }
2885: }
2886: return %languages;
1.14 harris41 2887: }
2888:
1.117 www 2889: sub preferred_languages {
2890: my @languages=();
1.258 albertel 2891: if ($env{'course.'.$env{'request.course.id'}.'.languages'}) {
1.117 www 2892: @languages=(@languages,split(/\s*(\,|\;|\:)\s*/,
1.258 albertel 2893: $env{'course.'.$env{'request.course.id'}.'.languages'}));
1.177 www 2894: }
1.258 albertel 2895: if ($env{'environment.languages'}) {
1.459 albertel 2896: @languages=(@languages,
2897: split(/\s*(\,|\;|\:)\s*/,$env{'environment.languages'}));
1.118 www 2898: }
1.583 albertel 2899: my $browser=$ENV{'HTTP_ACCEPT_LANGUAGE'};
1.162 www 2900: if ($browser) {
1.583 albertel 2901: my @browser =
2902: map { (split(/\s*;\s*/,$_))[0] } (split(/\s*,\s*/,$browser));
2903: push(@languages,@browser);
1.162 www 2904: }
1.641 raeburn 2905:
2906: foreach my $domtype ($env{'user.domain'},$env{'request.role.domain'},
2907: $Apache::lonnet::perlvar{'lonDefDomain'}) {
2908: if ($domtype ne '') {
2909: my %domdefs = &Apache::lonnet::get_domain_defaults($domtype);
2910: if ($domdefs{'lang_def'} ne '') {
2911: push(@languages,$domdefs{'lang_def'});
2912: }
2913: }
1.118 www 2914: }
2915: # turn "en-ca" into "en-ca,en"
2916: my @genlanguages;
1.356 albertel 2917: foreach my $lang (@languages) {
2918: unless ($lang=~/\w/) { next; }
1.583 albertel 2919: push(@genlanguages,$lang);
1.356 albertel 2920: if ($lang=~/(\-|\_)/) {
2921: push(@genlanguages,(split(/(\-|\_)/,$lang))[0]);
1.118 www 2922: }
2923: }
1.583 albertel 2924: #uniqueify the languages list
2925: my %count;
2926: @genlanguages = map { $count{$_}++ == 0 ? $_ : () } @genlanguages;
1.118 www 2927: return @genlanguages;
1.117 www 2928: }
2929:
1.582 albertel 2930: sub languages {
2931: my ($possible_langs) = @_;
2932: my @preferred_langs = &preferred_languages();
2933: if (!ref($possible_langs)) {
2934: if( wantarray ) {
2935: return @preferred_langs;
2936: } else {
2937: return $preferred_langs[0];
2938: }
2939: }
2940: my %possibilities = map { $_ => 1 } (@$possible_langs);
2941: my @preferred_possibilities;
2942: foreach my $preferred_lang (@preferred_langs) {
2943: if (exists($possibilities{$preferred_lang})) {
2944: push(@preferred_possibilities, $preferred_lang);
2945: }
2946: }
2947: if( wantarray ) {
2948: return @preferred_possibilities;
2949: }
2950: return $preferred_possibilities[0];
2951: }
2952:
1.112 bowersj2 2953: ###############################################################
2954: ## Student Answer Attempts ##
2955: ###############################################################
2956:
2957: =pod
2958:
2959: =head1 Alternate Problem Views
2960:
2961: =over 4
2962:
2963: =item * get_previous_attempt($symb, $username, $domain, $course,
2964: $getattempt, $regexp, $gradesub)
2965:
2966: Return string with previous attempt on problem. Arguments:
2967:
2968: =over 4
2969:
2970: =item * $symb: Problem, including path
2971:
2972: =item * $username: username of the desired student
2973:
2974: =item * $domain: domain of the desired student
1.14 harris41 2975:
1.112 bowersj2 2976: =item * $course: Course ID
1.14 harris41 2977:
1.112 bowersj2 2978: =item * $getattempt: Leave blank for all attempts, otherwise put
2979: something
1.14 harris41 2980:
1.112 bowersj2 2981: =item * $regexp: if string matches this regexp, the string will be
2982: sent to $gradesub
1.14 harris41 2983:
1.112 bowersj2 2984: =item * $gradesub: routine that processes the string if it matches $regexp
1.14 harris41 2985:
1.112 bowersj2 2986: =back
1.14 harris41 2987:
1.112 bowersj2 2988: The output string is a table containing all desired attempts, if any.
1.16 harris41 2989:
1.112 bowersj2 2990: =cut
1.1 albertel 2991:
2992: sub get_previous_attempt {
1.43 ng 2993: my ($symb,$username,$domain,$course,$getattempt,$regexp,$gradesub)=@_;
1.1 albertel 2994: my $prevattempts='';
1.43 ng 2995: no strict 'refs';
1.1 albertel 2996: if ($symb) {
1.3 albertel 2997: my (%returnhash)=
2998: &Apache::lonnet::restore($symb,$course,$domain,$username);
1.1 albertel 2999: if ($returnhash{'version'}) {
3000: my %lasthash=();
3001: my $version;
3002: for ($version=1;$version<=$returnhash{'version'};$version++) {
1.356 albertel 3003: foreach my $key (sort(split(/\:/,$returnhash{$version.':keys'}))) {
3004: $lasthash{$key}=$returnhash{$version.':'.$key};
1.19 harris41 3005: }
1.1 albertel 3006: }
1.596 albertel 3007: $prevattempts=&start_data_table().&start_data_table_header_row();
3008: $prevattempts.='<th>'.&mt('History').'</th>';
1.356 albertel 3009: foreach my $key (sort(keys(%lasthash))) {
3010: my ($ign,@parts) = split(/\./,$key);
1.41 ng 3011: if ($#parts > 0) {
1.31 albertel 3012: my $data=$parts[-1];
3013: pop(@parts);
1.596 albertel 3014: $prevattempts.='<th>'.&mt('Part ').join('.',@parts).'<br />'.$data.' </th>';
1.31 albertel 3015: } else {
1.41 ng 3016: if ($#parts == 0) {
3017: $prevattempts.='<th>'.$parts[0].'</th>';
3018: } else {
3019: $prevattempts.='<th>'.$ign.'</th>';
3020: }
1.31 albertel 3021: }
1.16 harris41 3022: }
1.596 albertel 3023: $prevattempts.=&end_data_table_header_row();
1.40 ng 3024: if ($getattempt eq '') {
3025: for ($version=1;$version<=$returnhash{'version'};$version++) {
1.596 albertel 3026: $prevattempts.=&start_data_table_row().
3027: '<td>'.&mt('Transaction [_1]',$version).'</td>';
1.356 albertel 3028: foreach my $key (sort(keys(%lasthash))) {
1.581 albertel 3029: my $value = &format_previous_attempt_value($key,
3030: $returnhash{$version.':'.$key});
3031: $prevattempts.='<td>'.$value.' </td>';
1.40 ng 3032: }
1.596 albertel 3033: $prevattempts.=&end_data_table_row();
1.40 ng 3034: }
1.1 albertel 3035: }
1.596 albertel 3036: $prevattempts.=&start_data_table_row().'<td>'.&mt('Current').'</td>';
1.356 albertel 3037: foreach my $key (sort(keys(%lasthash))) {
1.581 albertel 3038: my $value = &format_previous_attempt_value($key,$lasthash{$key});
1.356 albertel 3039: if ($key =~/$regexp$/ && (defined &$gradesub)) {$value = &$gradesub($value)}
1.40 ng 3040: $prevattempts.='<td>'.$value.' </td>';
1.16 harris41 3041: }
1.596 albertel 3042: $prevattempts.= &end_data_table_row().&end_data_table();
1.1 albertel 3043: } else {
1.596 albertel 3044: $prevattempts=
3045: &start_data_table().&start_data_table_row().
3046: '<td>'.&mt('Nothing submitted - no attempts.').'</td>'.
3047: &end_data_table_row().&end_data_table();
1.1 albertel 3048: }
3049: } else {
1.596 albertel 3050: $prevattempts=
3051: &start_data_table().&start_data_table_row().
3052: '<td>'.&mt('No data.').'</td>'.
3053: &end_data_table_row().&end_data_table();
1.1 albertel 3054: }
1.10 albertel 3055: }
3056:
1.581 albertel 3057: sub format_previous_attempt_value {
3058: my ($key,$value) = @_;
3059: if ($key =~ /timestamp/) {
3060: $value = &Apache::lonlocal::locallocaltime($value);
3061: } elsif (ref($value) eq 'ARRAY') {
3062: $value = '('.join(', ', @{ $value }).')';
3063: } else {
3064: $value = &unescape($value);
3065: }
3066: return $value;
3067: }
3068:
3069:
1.107 albertel 3070: sub relative_to_absolute {
3071: my ($url,$output)=@_;
3072: my $parser=HTML::TokeParser->new(\$output);
3073: my $token;
3074: my $thisdir=$url;
3075: my @rlinks=();
3076: while ($token=$parser->get_token) {
3077: if ($token->[0] eq 'S') {
3078: if ($token->[1] eq 'a') {
3079: if ($token->[2]->{'href'}) {
3080: $rlinks[$#rlinks+1]=$token->[2]->{'href'};
3081: }
3082: } elsif ($token->[1] eq 'img' || $token->[1] eq 'embed' ) {
3083: $rlinks[$#rlinks+1]=$token->[2]->{'src'};
3084: } elsif ($token->[1] eq 'base') {
3085: $thisdir=$token->[2]->{'href'};
3086: }
3087: }
3088: }
3089: $thisdir=~s-/[^/]*$--;
1.356 albertel 3090: foreach my $link (@rlinks) {
3091: unless (($link=~/^http:\/\//i) ||
3092: ($link=~/^\//) ||
3093: ($link=~/^javascript:/i) ||
3094: ($link=~/^mailto:/i) ||
3095: ($link=~/^\#/)) {
3096: my $newlocation=&Apache::lonnet::hreflocation($thisdir,$link);
3097: $output=~s/(\"|\'|\=\s*)\Q$link\E(\"|\'|\s|\>)/$1$newlocation$2/;
1.107 albertel 3098: }
3099: }
3100: # -------------------------------------------------- Deal with Applet codebases
3101: $output=~s/(\<applet[^\>]+)(codebase\=[^\S\>]+)*([^\>]*)\>/$1.($2?$2:' codebase="'.$thisdir.'"').$3.'>'/gei;
3102: return $output;
3103: }
3104:
1.112 bowersj2 3105: =pod
3106:
3107: =item * get_student_view
3108:
3109: show a snapshot of what student was looking at
3110:
3111: =cut
3112:
1.10 albertel 3113: sub get_student_view {
1.186 albertel 3114: my ($symb,$username,$domain,$courseid,$target,$moreenv) = @_;
1.114 www 3115: my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb);
1.186 albertel 3116: my (%form);
1.10 albertel 3117: my @elements=('symb','courseid','domain','username');
3118: foreach my $element (@elements) {
1.186 albertel 3119: $form{'grade_'.$element}=eval '$'.$element #'
1.10 albertel 3120: }
1.186 albertel 3121: if (defined($moreenv)) {
3122: %form=(%form,%{$moreenv});
3123: }
1.236 albertel 3124: if (defined($target)) { $form{'grade_target'} = $target; }
1.107 albertel 3125: $feedurl=&Apache::lonnet::clutter($feedurl);
1.186 albertel 3126: my $userview=&Apache::lonnet::ssi_body($feedurl,%form);
1.11 albertel 3127: $userview=~s/\<body[^\>]*\>//gi;
3128: $userview=~s/\<\/body\>//gi;
3129: $userview=~s/\<html\>//gi;
3130: $userview=~s/\<\/html\>//gi;
3131: $userview=~s/\<head\>//gi;
3132: $userview=~s/\<\/head\>//gi;
3133: $userview=~s/action\s*\=/would_be_action\=/gi;
1.107 albertel 3134: $userview=&relative_to_absolute($feedurl,$userview);
1.11 albertel 3135: return $userview;
3136: }
3137:
1.112 bowersj2 3138: =pod
3139:
3140: =item * get_student_answers()
3141:
3142: show a snapshot of how student was answering problem
3143:
3144: =cut
3145:
1.11 albertel 3146: sub get_student_answers {
1.100 sakharuk 3147: my ($symb,$username,$domain,$courseid,%form) = @_;
1.114 www 3148: my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb);
1.186 albertel 3149: my (%moreenv);
1.11 albertel 3150: my @elements=('symb','courseid','domain','username');
3151: foreach my $element (@elements) {
1.186 albertel 3152: $moreenv{'grade_'.$element}=eval '$'.$element #'
1.10 albertel 3153: }
1.186 albertel 3154: $moreenv{'grade_target'}='answer';
3155: %moreenv=(%form,%moreenv);
1.497 raeburn 3156: $feedurl = &Apache::lonnet::clutter($feedurl);
3157: my $userview=&Apache::lonnet::ssi($feedurl,%moreenv);
1.10 albertel 3158: return $userview;
1.1 albertel 3159: }
1.116 albertel 3160:
3161: =pod
3162:
3163: =item * &submlink()
3164:
1.242 albertel 3165: Inputs: $text $uname $udom $symb $target
1.116 albertel 3166:
3167: Returns: A link to grades.pm such as to see the SUBM view of a student
3168:
3169: =cut
3170:
3171: ###############################################
3172: sub submlink {
1.242 albertel 3173: my ($text,$uname,$udom,$symb,$target)=@_;
1.116 albertel 3174: if (!($uname && $udom)) {
3175: (my $cursymb, my $courseid,$udom,$uname)=
1.463 albertel 3176: &Apache::lonnet::whichuser($symb);
1.116 albertel 3177: if (!$symb) { $symb=$cursymb; }
3178: }
1.254 matthew 3179: if (!$symb) { $symb=&Apache::lonnet::symbread(); }
1.369 www 3180: $symb=&escape($symb);
1.242 albertel 3181: if ($target) { $target="target=\"$target\""; }
3182: return '<a href="/adm/grades?&command=submission&'.
3183: 'symb='.$symb.'&student='.$uname.
3184: '&userdom='.$udom.'" '.$target.'>'.$text.'</a>';
3185: }
3186: ##############################################
3187:
3188: =pod
3189:
3190: =item * &pgrdlink()
3191:
3192: Inputs: $text $uname $udom $symb $target
3193:
3194: Returns: A link to grades.pm such as to see the PGRD view of a student
3195:
3196: =cut
3197:
3198: ###############################################
3199: sub pgrdlink {
3200: my $link=&submlink(@_);
3201: $link=~s/(&command=submission)/$1&showgrading=yes/;
3202: return $link;
3203: }
3204: ##############################################
3205:
3206: =pod
3207:
3208: =item * &pprmlink()
3209:
3210: Inputs: $text $uname $udom $symb $target
3211:
3212: Returns: A link to parmset.pm such as to see the PPRM view of a
1.283 albertel 3213: student and a specific resource
1.242 albertel 3214:
3215: =cut
3216:
3217: ###############################################
3218: sub pprmlink {
3219: my ($text,$uname,$udom,$symb,$target)=@_;
3220: if (!($uname && $udom)) {
3221: (my $cursymb, my $courseid,$udom,$uname)=
1.463 albertel 3222: &Apache::lonnet::whichuser($symb);
1.242 albertel 3223: if (!$symb) { $symb=$cursymb; }
3224: }
1.254 matthew 3225: if (!$symb) { $symb=&Apache::lonnet::symbread(); }
1.369 www 3226: $symb=&escape($symb);
1.242 albertel 3227: if ($target) { $target="target=\"$target\""; }
1.595 albertel 3228: return '<a href="/adm/parmset?command=set&'.
3229: 'symb='.$symb.'&uname='.$uname.
3230: '&udom='.$udom.'" '.$target.'>'.$text.'</a>';
1.116 albertel 3231: }
3232: ##############################################
1.37 matthew 3233:
1.112 bowersj2 3234: =pod
3235:
3236: =back
3237:
3238: =cut
3239:
1.37 matthew 3240: ###############################################
1.51 www 3241:
3242:
3243: sub timehash {
3244: my @ltime=localtime(shift);
3245: return ( 'seconds' => $ltime[0],
3246: 'minutes' => $ltime[1],
3247: 'hours' => $ltime[2],
3248: 'day' => $ltime[3],
3249: 'month' => $ltime[4]+1,
3250: 'year' => $ltime[5]+1900,
3251: 'weekday' => $ltime[6],
3252: 'dayyear' => $ltime[7]+1,
3253: 'dlsav' => $ltime[8] );
3254: }
3255:
1.370 www 3256: sub utc_string {
3257: my ($date)=@_;
1.371 www 3258: return strftime("%Y%m%dT%H%M%SZ",gmtime($date));
1.370 www 3259: }
3260:
1.51 www 3261: sub maketime {
3262: my %th=@_;
3263: return POSIX::mktime(
3264: ($th{'seconds'},$th{'minutes'},$th{'hours'},
1.210 www 3265: $th{'day'},$th{'month'}-1,$th{'year'}-1900,0,0,-1));
1.70 www 3266: }
3267:
3268: #########################################
1.51 www 3269:
3270: sub findallcourses {
1.482 raeburn 3271: my ($roles,$uname,$udom) = @_;
1.355 albertel 3272: my %roles;
3273: if (ref($roles)) { %roles = map { $_ => 1 } @{$roles}; }
1.348 albertel 3274: my %courses;
1.51 www 3275: my $now=time;
1.482 raeburn 3276: if (!defined($uname)) {
3277: $uname = $env{'user.name'};
3278: }
3279: if (!defined($udom)) {
3280: $udom = $env{'user.domain'};
3281: }
3282: if (($uname ne $env{'user.name'}) || ($udom ne $env{'user.domain'})) {
3283: my %roleshash = &Apache::lonnet::dump('roles',$udom,$uname);
3284: if (!%roles) {
3285: %roles = (
3286: cc => 1,
3287: in => 1,
3288: ep => 1,
3289: ta => 1,
3290: cr => 1,
3291: st => 1,
3292: );
3293: }
3294: foreach my $entry (keys(%roleshash)) {
3295: my ($trole,$tend,$tstart) = split(/_/,$roleshash{$entry});
3296: if ($trole =~ /^cr/) {
3297: next if (!exists($roles{$trole}) && !exists($roles{'cr'}));
3298: } else {
3299: next if (!exists($roles{$trole}));
3300: }
3301: if ($tend) {
3302: next if ($tend < $now);
3303: }
3304: if ($tstart) {
3305: next if ($tstart > $now);
3306: }
3307: my ($cdom,$cnum,$sec,$cnumpart,$secpart,$role,$realsec);
3308: (undef,$cdom,$cnumpart,$secpart) = split(/\//,$entry);
3309: if ($secpart eq '') {
3310: ($cnum,$role) = split(/_/,$cnumpart);
3311: $sec = 'none';
3312: $realsec = '';
3313: } else {
3314: $cnum = $cnumpart;
3315: ($sec,$role) = split(/_/,$secpart);
3316: $realsec = $sec;
1.490 raeburn 3317: }
1.482 raeburn 3318: $courses{$cdom.'_'.$cnum}{$sec} = $trole.'/'.$cdom.'/'.$cnum.'/'.$realsec;
3319: }
3320: } else {
3321: foreach my $key (keys(%env)) {
1.483 albertel 3322: if ( $key=~m{^user\.role\.(\w+)\./($match_domain)/($match_courseid)/?(\w*)$} ||
3323: $key=~m{^user\.role\.(cr/$match_domain/$match_username/\w+)\./($match_domain)/($match_courseid)/?(\w*)$}) {
1.482 raeburn 3324: my ($role,$cdom,$cnum,$sec) = ($1,$2,$3,$4);
3325: next if ($role eq 'ca' || $role eq 'aa');
3326: next if (%roles && !exists($roles{$role}));
3327: my ($starttime,$endtime)=split(/\./,$env{$key});
3328: my $active=1;
3329: if ($starttime) {
3330: if ($now<$starttime) { $active=0; }
3331: }
3332: if ($endtime) {
3333: if ($now>$endtime) { $active=0; }
3334: }
3335: if ($active) {
3336: if ($sec eq '') {
3337: $sec = 'none';
3338: }
3339: $courses{$cdom.'_'.$cnum}{$sec} =
3340: $role.'/'.$cdom.'/'.$cnum.'/'.$sec;
1.474 raeburn 3341: }
3342: }
1.51 www 3343: }
3344: }
1.474 raeburn 3345: return %courses;
1.51 www 3346: }
1.37 matthew 3347:
1.54 www 3348: ###############################################
1.474 raeburn 3349:
3350: sub blockcheck {
1.482 raeburn 3351: my ($setters,$activity,$uname,$udom) = @_;
1.490 raeburn 3352:
3353: if (!defined($udom)) {
3354: $udom = $env{'user.domain'};
3355: }
3356: if (!defined($uname)) {
3357: $uname = $env{'user.name'};
3358: }
3359:
3360: # If uname and udom are for a course, check for blocks in the course.
3361:
3362: if (&Apache::lonnet::is_course($udom,$uname)) {
3363: my %records = &Apache::lonnet::dump('comm_block',$udom,$uname);
1.502 raeburn 3364: my ($startblock,$endblock)=&get_blocks($setters,$activity,$udom,$uname);
1.490 raeburn 3365: return ($startblock,$endblock);
3366: }
1.474 raeburn 3367:
1.502 raeburn 3368: my $startblock = 0;
3369: my $endblock = 0;
1.482 raeburn 3370: my %live_courses = &findallcourses(undef,$uname,$udom);
1.474 raeburn 3371:
1.490 raeburn 3372: # If uname is for a user, and activity is course-specific, i.e.,
3373: # boards, chat or groups, check for blocking in current course only.
1.474 raeburn 3374:
1.490 raeburn 3375: if (($activity eq 'boards' || $activity eq 'chat' ||
3376: $activity eq 'groups') && ($env{'request.course.id'})) {
3377: foreach my $key (keys(%live_courses)) {
3378: if ($key ne $env{'request.course.id'}) {
3379: delete($live_courses{$key});
3380: }
3381: }
3382: }
3383:
3384: my $otheruser = 0;
3385: my %own_courses;
3386: if ((($uname ne $env{'user.name'})) || ($udom ne $env{'user.domain'})) {
3387: # Resource belongs to user other than current user.
3388: $otheruser = 1;
3389: # Gather courses for current user
3390: %own_courses =
3391: &findallcourses(undef,$env{'user.name'},$env{'user.domain'});
3392: }
3393:
3394: # Gather active course roles - course coordinator, instructor,
3395: # exam proctor, ta, student, or custom role.
1.474 raeburn 3396:
3397: foreach my $course (keys(%live_courses)) {
1.482 raeburn 3398: my ($cdom,$cnum);
3399: if ((defined($env{'course.'.$course.'.domain'})) && (defined($env{'course.'.$course.'.num'}))) {
3400: $cdom = $env{'course.'.$course.'.domain'};
3401: $cnum = $env{'course.'.$course.'.num'};
3402: } else {
1.490 raeburn 3403: ($cdom,$cnum) = split(/_/,$course);
1.482 raeburn 3404: }
3405: my $no_ownblock = 0;
3406: my $no_userblock = 0;
1.533 raeburn 3407: if ($otheruser && $activity ne 'com') {
1.490 raeburn 3408: # Check if current user has 'evb' priv for this
3409: if (defined($own_courses{$course})) {
3410: foreach my $sec (keys(%{$own_courses{$course}})) {
3411: my $checkrole = 'cm./'.$cdom.'/'.$cnum;
3412: if ($sec ne 'none') {
3413: $checkrole .= '/'.$sec;
3414: }
3415: if (&Apache::lonnet::allowed('evb',undef,undef,$checkrole)) {
3416: $no_ownblock = 1;
3417: last;
3418: }
3419: }
3420: }
3421: # if they have 'evb' priv and are currently not playing student
3422: next if (($no_ownblock) &&
3423: ($env{'request.role'} !~ m{^st\./$cdom/$cnum}));
3424: }
1.474 raeburn 3425: foreach my $sec (keys(%{$live_courses{$course}})) {
1.482 raeburn 3426: my $checkrole = 'cm./'.$cdom.'/'.$cnum;
1.474 raeburn 3427: if ($sec ne 'none') {
1.482 raeburn 3428: $checkrole .= '/'.$sec;
1.474 raeburn 3429: }
1.490 raeburn 3430: if ($otheruser) {
3431: # Resource belongs to user other than current user.
3432: # Assemble privs for that user, and check for 'evb' priv.
1.482 raeburn 3433: my ($trole,$tdom,$tnum,$tsec);
3434: my $entry = $live_courses{$course}{$sec};
3435: if ($entry =~ /^cr/) {
3436: ($trole,$tdom,$tnum,$tsec) =
3437: ($entry =~ m|^(cr/$match_domain/$match_username/\w+)\./($match_domain)/($match_username)/?(\w*)$|);
3438: } else {
3439: ($trole,$tdom,$tnum,$tsec) = split(/\//,$entry);
3440: }
3441: my ($spec,$area,$trest,%allroles,%userroles);
3442: $area = '/'.$tdom.'/'.$tnum;
3443: $trest = $tnum;
3444: if ($tsec ne '') {
3445: $area .= '/'.$tsec;
3446: $trest .= '/'.$tsec;
3447: }
3448: $spec = $trole.'.'.$area;
3449: if ($trole =~ /^cr/) {
3450: &Apache::lonnet::custom_roleprivs(\%allroles,$trole,
3451: $tdom,$spec,$trest,$area);
3452: } else {
3453: &Apache::lonnet::standard_roleprivs(\%allroles,$trole,
3454: $tdom,$spec,$trest,$area);
3455: }
3456: my ($author,$adv) = &Apache::lonnet::set_userprivs(\%userroles,\%allroles);
1.486 raeburn 3457: if ($userroles{'user.priv.'.$checkrole} =~ /evb\&([^\:]*)/) {
3458: if ($1) {
3459: $no_userblock = 1;
3460: last;
3461: }
3462: }
1.490 raeburn 3463: } else {
3464: # Resource belongs to current user
3465: # Check for 'evb' priv via lonnet::allowed().
1.482 raeburn 3466: if (&Apache::lonnet::allowed('evb',undef,undef,$checkrole)) {
3467: $no_ownblock = 1;
3468: last;
3469: }
1.474 raeburn 3470: }
3471: }
3472: # if they have the evb priv and are currently not playing student
1.482 raeburn 3473: next if (($no_ownblock) &&
1.491 albertel 3474: ($env{'request.role'} !~ m{^st\./\Q$cdom\E/\Q$cnum\E}));
1.482 raeburn 3475: next if ($no_userblock);
1.474 raeburn 3476:
1.490 raeburn 3477: # Retrieve blocking times and identity of blocker for course
3478: # of specified user, unless user has 'evb' privilege.
1.502 raeburn 3479:
3480: my ($start,$end)=&get_blocks($setters,$activity,$cdom,$cnum);
3481: if (($start != 0) &&
3482: (($startblock == 0) || ($startblock > $start))) {
3483: $startblock = $start;
3484: }
3485: if (($end != 0) &&
3486: (($endblock == 0) || ($endblock < $end))) {
3487: $endblock = $end;
3488: }
1.490 raeburn 3489: }
3490: return ($startblock,$endblock);
3491: }
3492:
3493: sub get_blocks {
3494: my ($setters,$activity,$cdom,$cnum) = @_;
3495: my $startblock = 0;
3496: my $endblock = 0;
3497: my $course = $cdom.'_'.$cnum;
3498: $setters->{$course} = {};
3499: $setters->{$course}{'staff'} = [];
3500: $setters->{$course}{'times'} = [];
3501: my %records = &Apache::lonnet::dump('comm_block',$cdom,$cnum);
3502: foreach my $record (keys(%records)) {
3503: my ($start,$end) = ($record =~ m/^(\d+)____(\d+)$/);
3504: if ($start <= time && $end >= time) {
3505: my ($staff_name,$staff_dom,$title,$blocks) =
3506: &parse_block_record($records{$record});
3507: if ($blocks->{$activity} eq 'on') {
3508: push(@{$$setters{$course}{'staff'}},[$staff_name,$staff_dom]);
3509: push(@{$$setters{$course}{'times'}}, [$start,$end]);
1.491 albertel 3510: if ( ($startblock == 0) || ($startblock > $start) ) {
3511: $startblock = $start;
1.490 raeburn 3512: }
1.491 albertel 3513: if ( ($endblock == 0) || ($endblock < $end) ) {
3514: $endblock = $end;
1.474 raeburn 3515: }
3516: }
3517: }
3518: }
3519: return ($startblock,$endblock);
3520: }
3521:
3522: sub parse_block_record {
3523: my ($record) = @_;
3524: my ($setuname,$setudom,$title,$blocks);
3525: if (ref($record) eq 'HASH') {
3526: ($setuname,$setudom) = split(/:/,$record->{'setter'});
3527: $title = &unescape($record->{'event'});
3528: $blocks = $record->{'blocks'};
3529: } else {
3530: my @data = split(/:/,$record,3);
3531: if (scalar(@data) eq 2) {
3532: $title = $data[1];
3533: ($setuname,$setudom) = split(/@/,$data[0]);
3534: } else {
3535: ($setuname,$setudom,$title) = @data;
3536: }
3537: $blocks = { 'com' => 'on' };
3538: }
3539: return ($setuname,$setudom,$title,$blocks);
3540: }
3541:
3542: sub build_block_table {
3543: my ($startblock,$endblock,$setters) = @_;
3544: my %lt = &Apache::lonlocal::texthash(
3545: 'cacb' => 'Currently active communication blocks',
3546: 'cour' => 'Course',
3547: 'dura' => 'Duration',
3548: 'blse' => 'Block set by'
3549: );
3550: my $output;
1.476 raeburn 3551: $output = '<br />'.$lt{'cacb'}.':<br />';
1.474 raeburn 3552: $output .= &start_data_table();
3553: $output .= '
3554: <tr>
3555: <th>'.$lt{'cour'}.'</th>
3556: <th>'.$lt{'dura'}.'</th>
3557: <th>'.$lt{'blse'}.'</th>
3558: </tr>
3559: ';
3560: foreach my $course (keys(%{$setters})) {
3561: my %courseinfo=&Apache::lonnet::coursedescription($course);
3562: for (my $i=0; $i<@{$$setters{$course}{staff}}; $i++) {
3563: my ($uname,$udom) = @{$$setters{$course}{staff}[$i]};
1.490 raeburn 3564: my $fullname = &plainname($uname,$udom);
3565: if (defined($env{'user.name'}) && defined($env{'user.domain'})
3566: && $env{'user.name'} ne 'public'
3567: && $env{'user.domain'} ne 'public') {
3568: $fullname = &aboutmewrapper($fullname,$uname,$udom);
3569: }
1.474 raeburn 3570: my ($openblock,$closeblock) = @{$$setters{$course}{times}[$i]};
3571: $openblock = &Apache::lonlocal::locallocaltime($openblock);
3572: $closeblock= &Apache::lonlocal::locallocaltime($closeblock);
3573: $output .= &Apache::loncommon::start_data_table_row().
3574: '<td>'.$courseinfo{'description'}.'</td>'.
3575: '<td>'.$openblock.' to '.$closeblock.'</td>'.
1.490 raeburn 3576: '<td>'.$fullname.'</td>'.
1.474 raeburn 3577: &Apache::loncommon::end_data_table_row();
3578: }
3579: }
3580: $output .= &end_data_table();
3581: }
3582:
1.490 raeburn 3583: sub blocking_status {
3584: my ($activity,$uname,$udom) = @_;
3585: my %setters;
3586: my ($blocked,$output,$ownitem,$is_course);
3587: my ($startblock,$endblock)=&blockcheck(\%setters,$activity,$uname,$udom);
3588: if ($startblock && $endblock) {
3589: $blocked = 1;
3590: if (wantarray) {
3591: my $category;
3592: if ($activity eq 'boards') {
3593: $category = 'Discussion posts in this course';
3594: } elsif ($activity eq 'blogs') {
3595: $category = 'Blogs';
3596: } elsif ($activity eq 'port') {
3597: if (defined($uname) && defined($udom)) {
3598: if ($uname eq $env{'user.name'} &&
3599: $udom eq $env{'user.domain'}) {
3600: $ownitem = 1;
3601: }
3602: }
3603: $is_course = &Apache::lonnet::is_course($udom,$uname);
3604: if ($ownitem) {
3605: $category = 'Your portfolio files';
3606: } elsif ($is_course) {
3607: my $coursedesc;
3608: foreach my $course (keys(%setters)) {
3609: my %courseinfo =
3610: &Apache::lonnet::coursedescription($course);
3611: $coursedesc = $courseinfo{'description'};
3612: }
3613: $category = "Group files in the course '$coursedesc'";
3614: } else {
3615: $category = 'Portfolio files belonging to ';
3616: if ($env{'user.name'} eq 'public' &&
3617: $env{'user.domain'} eq 'public') {
3618: $category .= &plainname($uname,$udom);
3619: } else {
3620: $category .= &aboutmewrapper(&plainname($uname,$udom),$uname,$udom);
3621: }
3622: }
3623: } elsif ($activity eq 'groups') {
3624: $category = 'Groups in this course';
3625: }
3626: my $showstart = &Apache::lonlocal::locallocaltime($startblock);
3627: my $showend = &Apache::lonlocal::locallocaltime($endblock);
3628: $output = '<br />'.&mt('[_1] will be inaccessible between [_2] and [_3] because communication is being blocked.',$category,$showstart,$showend).'<br />';
3629: if (!($activity eq 'port' && !($ownitem) && !($is_course))) {
3630: $output .= &build_block_table($startblock,$endblock,\%setters);
3631: }
3632: }
3633: }
3634: if (wantarray) {
3635: return ($blocked,$output);
3636: } else {
3637: return $blocked;
3638: }
3639: }
3640:
1.60 matthew 3641: ###############################################
3642:
3643: =pod
3644:
1.112 bowersj2 3645: =head1 Domain Template Functions
3646:
3647: =over 4
3648:
3649: =item * &determinedomain()
1.60 matthew 3650:
3651: Inputs: $domain (usually will be undef)
3652:
1.63 www 3653: Returns: Determines which domain should be used for designs
1.60 matthew 3654:
3655: =cut
1.54 www 3656:
1.60 matthew 3657: ###############################################
1.63 www 3658: sub determinedomain {
3659: my $domain=shift;
1.531 albertel 3660: if (! $domain) {
1.60 matthew 3661: # Determine domain if we have not been given one
3662: $domain = $Apache::lonnet::perlvar{'lonDefDomain'};
1.258 albertel 3663: if ($env{'user.domain'}) { $domain=$env{'user.domain'}; }
3664: if ($env{'request.role.domain'}) {
3665: $domain=$env{'request.role.domain'};
1.60 matthew 3666: }
3667: }
1.63 www 3668: return $domain;
3669: }
3670: ###############################################
1.517 raeburn 3671:
1.518 albertel 3672: sub devalidate_domconfig_cache {
3673: my ($udom)=@_;
3674: &Apache::lonnet::devalidate_cache_new('domainconfig',$udom);
3675: }
3676:
3677: # ---------------------- Get domain configuration for a domain
3678: sub get_domainconf {
3679: my ($udom) = @_;
3680: my $cachetime=1800;
3681: my ($result,$cached)=&Apache::lonnet::is_cached_new('domainconfig',$udom);
3682: if (defined($cached)) { return %{$result}; }
3683:
3684: my %domconfig = &Apache::lonnet::get_dom('configuration',
3685: ['login','rolecolors'],$udom);
1.632 raeburn 3686: my (%designhash,%legacy);
1.518 albertel 3687: if (keys(%domconfig) > 0) {
3688: if (ref($domconfig{'login'}) eq 'HASH') {
1.632 raeburn 3689: if (keys(%{$domconfig{'login'}})) {
3690: foreach my $key (keys(%{$domconfig{'login'}})) {
3691: $designhash{$udom.'.login.'.$key}=$domconfig{'login'}{$key};
3692: }
3693: } else {
3694: $legacy{'login'} = 1;
1.518 albertel 3695: }
1.632 raeburn 3696: } else {
3697: $legacy{'login'} = 1;
1.518 albertel 3698: }
3699: if (ref($domconfig{'rolecolors'}) eq 'HASH') {
1.632 raeburn 3700: if (keys(%{$domconfig{'rolecolors'}})) {
3701: foreach my $role (keys(%{$domconfig{'rolecolors'}})) {
3702: if (ref($domconfig{'rolecolors'}{$role}) eq 'HASH') {
3703: foreach my $item (keys(%{$domconfig{'rolecolors'}{$role}})) {
3704: $designhash{$udom.'.'.$role.'.'.$item}=$domconfig{'rolecolors'}{$role}{$item};
3705: }
1.518 albertel 3706: }
3707: }
1.632 raeburn 3708: } else {
3709: $legacy{'rolecolors'} = 1;
1.518 albertel 3710: }
1.632 raeburn 3711: } else {
3712: $legacy{'rolecolors'} = 1;
1.518 albertel 3713: }
1.632 raeburn 3714: if (keys(%legacy) > 0) {
3715: my %legacyhash = &get_legacy_domconf($udom);
3716: foreach my $item (keys(%legacyhash)) {
3717: if ($item =~ /^\Q$udom\E\.login/) {
3718: if ($legacy{'login'}) {
3719: $designhash{$item} = $legacyhash{$item};
3720: }
3721: } else {
3722: if ($legacy{'rolecolors'}) {
3723: $designhash{$item} = $legacyhash{$item};
3724: }
1.518 albertel 3725: }
3726: }
3727: }
1.632 raeburn 3728: } else {
3729: %designhash = &get_legacy_domconf($udom);
1.518 albertel 3730: }
3731: &Apache::lonnet::do_cache_new('domainconfig',$udom,\%designhash,
3732: $cachetime);
3733: return %designhash;
3734: }
3735:
1.632 raeburn 3736: sub get_legacy_domconf {
3737: my ($udom) = @_;
3738: my %legacyhash;
3739: my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors';
3740: my $designfile = $designdir.'/'.$udom.'.tab';
3741: if (-e $designfile) {
3742: if ( open (my $fh,"<$designfile") ) {
3743: while (my $line = <$fh>) {
3744: next if ($line =~ /^\#/);
3745: chomp($line);
3746: my ($key,$val)=(split(/\=/,$line));
3747: if ($val) { $legacyhash{$udom.'.'.$key}=$val; }
3748: }
3749: close($fh);
3750: }
3751: }
3752: if (-e '/home/httpd/html/adm/lonDomLogos/'.$udom.'.gif') {
3753: $legacyhash{$udom.'.login.domlogo'} = "/adm/lonDomLogos/$udom.gif";
3754: }
3755: return %legacyhash;
3756: }
3757:
1.63 www 3758: =pod
3759:
1.112 bowersj2 3760: =item * &domainlogo()
1.63 www 3761:
3762: Inputs: $domain (usually will be undef)
3763:
3764: Returns: A link to a domain logo, if the domain logo exists.
3765: If the domain logo does not exist, a description of the domain.
3766:
3767: =cut
1.112 bowersj2 3768:
1.63 www 3769: ###############################################
3770: sub domainlogo {
1.517 raeburn 3771: my $domain = &determinedomain(shift);
1.518 albertel 3772: my %designhash = &get_domainconf($domain);
1.517 raeburn 3773: # See if there is a logo
3774: if ($designhash{$domain.'.login.domlogo'} ne '') {
1.519 raeburn 3775: my $imgsrc = $designhash{$domain.'.login.domlogo'};
1.538 albertel 3776: if ($imgsrc =~ m{^/(adm|res)/}) {
3777: if ($imgsrc =~ m{^/res/}) {
3778: my $local_name = &Apache::lonnet::filelocation('',$imgsrc);
3779: &Apache::lonnet::repcopy($local_name);
3780: }
3781: $imgsrc = &lonhttpdurl($imgsrc);
1.519 raeburn 3782: }
3783: return '<img src="'.$imgsrc.'" alt="'.$domain.'" />';
1.514 albertel 3784: } elsif (defined(&Apache::lonnet::domain($domain,'description'))) {
3785: return &Apache::lonnet::domain($domain,'description');
1.59 www 3786: } else {
1.60 matthew 3787: return '';
1.59 www 3788: }
3789: }
1.63 www 3790: ##############################################
3791:
3792: =pod
3793:
1.112 bowersj2 3794: =item * &designparm()
1.63 www 3795:
3796: Inputs: $which parameter; $domain (usually will be undef)
3797:
3798: Returns: value of designparamter $which
3799:
3800: =cut
1.112 bowersj2 3801:
1.397 albertel 3802:
1.400 albertel 3803: ##############################################
1.397 albertel 3804: sub designparm {
3805: my ($which,$domain)=@_;
1.258 albertel 3806: if ($env{'browser.blackwhite'} eq 'on') {
1.635 raeburn 3807: if ($which=~/\.(font|alink|vlink|link|textcol)$/) {
1.110 www 3808: return '#000000';
3809: }
1.635 raeburn 3810: if ($which=~/\.(pgbg|sidebg|bgcol)$/) {
1.110 www 3811: return '#FFFFFF';
3812: }
3813: if ($which=~/\.tabbg$/) {
3814: return '#CCCCCC';
3815: }
3816: }
1.397 albertel 3817: if (exists($env{'environment.color.'.$which})) {
1.258 albertel 3818: return $env{'environment.color.'.$which};
1.96 www 3819: }
1.63 www 3820: $domain=&determinedomain($domain);
1.518 albertel 3821: my %domdesign = &get_domainconf($domain);
1.520 raeburn 3822: my $output;
1.517 raeburn 3823: if ($domdesign{$domain.'.'.$which} ne '') {
1.520 raeburn 3824: $output = $domdesign{$domain.'.'.$which};
1.63 www 3825: } else {
1.520 raeburn 3826: $output = $defaultdesign{$which};
3827: }
3828: if (($which =~ /^(student|coordinator|author|admin)\.img$/) ||
1.635 raeburn 3829: ($which =~ /login\.(img|logo|domlogo|login)/)) {
1.538 albertel 3830: if ($output =~ m{^/(adm|res)/}) {
3831: if ($output =~ m{^/res/}) {
3832: my $local_name = &Apache::lonnet::filelocation('',$output);
3833: &Apache::lonnet::repcopy($local_name);
3834: }
1.520 raeburn 3835: $output = &lonhttpdurl($output);
3836: }
1.63 www 3837: }
1.520 raeburn 3838: return $output;
1.63 www 3839: }
1.59 www 3840:
1.60 matthew 3841: ###############################################
3842: ###############################################
3843:
3844: =pod
3845:
1.112 bowersj2 3846: =back
3847:
1.549 albertel 3848: =head1 HTML Helpers
1.112 bowersj2 3849:
3850: =over 4
3851:
3852: =item * &bodytag()
1.60 matthew 3853:
3854: Returns a uniform header for LON-CAPA web pages.
3855:
3856: Inputs:
3857:
1.112 bowersj2 3858: =over 4
3859:
3860: =item * $title, A title to be displayed on the page.
3861:
3862: =item * $function, the current role (can be undef).
3863:
3864: =item * $addentries, extra parameters for the <body> tag.
3865:
3866: =item * $bodyonly, if defined, only return the <body> tag.
3867:
3868: =item * $domain, if defined, force a given domain.
3869:
3870: =item * $forcereg, if page should register as content page (relevant for
1.86 www 3871: text interface only)
1.60 matthew 3872:
1.326 albertel 3873: =item * $customtitle, alternate text to use instead of $title
3874: in the title box that appears, this text
3875: is not auto translated like the $title is
1.309 albertel 3876:
3877: =item * $notopbar, if true, keep the 'what is this' info but remove the
3878: navigational links
1.317 albertel 3879:
1.338 albertel 3880: =item * $bgcolor, used to override the bgcolor on a webpage to a specific value
3881:
3882: =item * $notitle, if true keep the nav controls, but remove the title bar
3883:
1.361 albertel 3884: =item * $no_inline_link, if true and in remote mode, don't show the
3885: 'Switch To Inline Menu' link
3886:
1.460 albertel 3887: =item * $args, optional argument valid values are
3888: no_auto_mt_title -> prevents &mt()ing the title arg
1.562 albertel 3889: inherit_jsmath -> when creating popup window in a page,
3890: should it have jsmath forced on by the
3891: current page
1.460 albertel 3892:
1.112 bowersj2 3893: =back
3894:
1.60 matthew 3895: Returns: A uniform header for LON-CAPA web pages.
3896: If $bodyonly is nonzero, a string containing a <body> tag will be returned.
3897: If $bodyonly is undef or zero, an html string containing a <body> tag and
3898: other decorations will be returned.
3899:
3900: =cut
3901:
1.54 www 3902: sub bodytag {
1.309 albertel 3903: my ($title,$function,$addentries,$bodyonly,$domain,$forcereg,$customtitle,
1.460 albertel 3904: $notopbar,$bgcolor,$notitle,$no_inline_link,$args)=@_;
1.339 albertel 3905:
1.460 albertel 3906: if (!$args->{'no_auto_mt_title'}) { $title = &mt($title); }
1.339 albertel 3907:
1.183 matthew 3908: $function = &get_users_function() if (!$function);
1.339 albertel 3909: my $img = &designparm($function.'.img',$domain);
3910: my $font = &designparm($function.'.font',$domain);
3911: my $pgbg = $bgcolor || &designparm($function.'.pgbg',$domain);
3912:
3913: my %design = ( 'style' => 'margin-top: 0px',
1.535 albertel 3914: 'bgcolor' => $pgbg,
1.339 albertel 3915: 'text' => $font,
3916: 'alink' => &designparm($function.'.alink',$domain),
3917: 'vlink' => &designparm($function.'.vlink',$domain),
3918: 'link' => &designparm($function.'.link',$domain),);
1.438 albertel 3919: @design{keys(%$addentries)} = @$addentries{keys(%$addentries)};
1.339 albertel 3920:
1.63 www 3921: # role and realm
1.378 raeburn 3922: my ($role,$realm) = split(/\./,$env{'request.role'},2);
3923: if ($role eq 'ca') {
1.479 albertel 3924: my ($rdom,$rname) = ($realm =~ m{^/($match_domain)/($match_username)$});
1.500 albertel 3925: $realm = &plainname($rname,$rdom);
1.378 raeburn 3926: }
1.55 www 3927: # realm
1.258 albertel 3928: if ($env{'request.course.id'}) {
1.378 raeburn 3929: if ($env{'request.role'} !~ /^cr/) {
3930: $role = &Apache::lonnet::plaintext($role,&course_type());
3931: }
1.359 albertel 3932: $realm = $env{'course.'.$env{'request.course.id'}.'.description'};
1.378 raeburn 3933: } else {
3934: $role = &Apache::lonnet::plaintext($role);
1.54 www 3935: }
1.433 albertel 3936:
1.359 albertel 3937: if (!$realm) { $realm=' '; }
1.55 www 3938: # Set messages
1.60 matthew 3939: my $messages=&domainlogo($domain);
1.330 albertel 3940:
1.438 albertel 3941: my $extra_body_attr = &make_attr_string($forcereg,\%design);
1.329 albertel 3942:
1.101 www 3943: # construct main body tag
1.359 albertel 3944: my $bodytag = "<body $extra_body_attr>".
1.562 albertel 3945: &Apache::lontexconvert::init_math_support($args->{'inherit_jsmath'});
1.252 albertel 3946:
1.530 albertel 3947: if ($bodyonly) {
1.60 matthew 3948: return $bodytag;
1.258 albertel 3949: } elsif ($env{'browser.interface'} eq 'textual') {
1.95 www 3950: # Accessibility
1.224 raeburn 3951:
1.337 albertel 3952: $bodytag.=&Apache::lonmenu::menubuttons($forcereg,$forcereg);
1.338 albertel 3953: if (!$notitle) {
1.337 albertel 3954: $bodytag.='<h1>LON-CAPA: '.$title.'</h1>';
3955: }
3956: return $bodytag;
1.359 albertel 3957: }
3958:
1.410 albertel 3959: my $name = &plainname($env{'user.name'},$env{'user.domain'});
1.433 albertel 3960: if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
3961: undef($role);
1.434 albertel 3962: } else {
3963: $name = &aboutmewrapper($name,$env{'user.name'},$env{'user.domain'});
1.433 albertel 3964: }
1.359 albertel 3965:
3966: my $roleinfo=(<<ENDROLE);
3967: <td class="LC_title_bar_who">
3968: <div class="LC_title_bar_name">
1.410 albertel 3969: $name
1.361 albertel 3970:
1.359 albertel 3971: </div>
3972: <div class="LC_title_bar_role">
1.361 albertel 3973: $role
1.359 albertel 3974: </div>
3975: <div class="LC_title_bar_realm">
1.361 albertel 3976: $realm
1.359 albertel 3977: </div>
1.206 albertel 3978: </td>
3979: ENDROLE
1.235 raeburn 3980:
1.359 albertel 3981: my $titleinfo = '<span class="LC_title_bar_title">'.$title.'</span>';
3982: if ($customtitle) {
3983: $titleinfo = $customtitle;
3984: }
3985: #
3986: # Extra info if you are the DC
3987: my $dc_info = '';
3988: if ($env{'user.adv'} && exists($env{'user.role.dc./'.
3989: $env{'course.'.$env{'request.course.id'}.
3990: '.domain'}.'/'})) {
3991: my $cid = $env{'request.course.id'};
3992: $dc_info.= $cid.' '.$env{'course.'.$cid.'.internal.coursecode'};
1.380 www 3993: $dc_info =~ s/\s+$//;
1.359 albertel 3994: $dc_info = '('.$dc_info.')';
3995: }
3996:
1.644 www 3997: if (($env{'environment.remote'} eq 'off') || ($args->{'suppress_header_logos'})) {
1.359 albertel 3998: # No Remote
1.258 albertel 3999: if ($env{'request.state'} eq 'construct') {
1.359 albertel 4000: $forcereg=1;
4001: }
4002:
4003: if (!$customtitle && $env{'request.state'} eq 'construct') {
4004: # this is for resources; directories have customtitle, and crumbs
4005: # and select recent are created in lonpubdir.pm
1.229 albertel 4006: my ($uname,$thisdisfn)=
1.258 albertel 4007: ($env{'request.filename'} =~ m|^/home/([^/]+)/public_html/(.*)|);
1.229 albertel 4008: my $formaction='/priv/'.$uname.'/'.$thisdisfn;
4009: $formaction=~s/\/+/\//g;
4010:
1.359 albertel 4011: my $parentpath = '';
4012: my $lastitem = '';
4013: if ($thisdisfn =~ m-(.+/)([^/]*)$-) {
4014: $parentpath = $1;
4015: $lastitem = $2;
4016: } else {
4017: $lastitem = $thisdisfn;
4018: }
4019: $titleinfo =
1.640 bisitz 4020: &Apache::loncommon::help_open_menu('','',3,'Authoring')
4021: .'<b>'.&mt('Construction Space').'</b>: '
4022: .'<form name="dirs" method="post" action="'.$formaction
1.359 albertel 4023: .'" target="_top"><tt><b>'
4024: .&Apache::lonhtmlcommon::crumbs($uname.'/'.$parentpath,'_top','/priv','','+1',1)."<font size=\"+1\">$lastitem</font></b></tt><br />"
4025: .&Apache::lonhtmlcommon::select_recent('construct','recent','this.form.action=this.form.recent.value;this.form.submit()')
4026: .'</form>'
4027: .&Apache::lonmenu::constspaceform();
1.235 raeburn 4028: }
1.359 albertel 4029:
1.337 albertel 4030: my $titletable;
1.338 albertel 4031: if (!$notitle) {
1.337 albertel 4032: $titletable =
1.359 albertel 4033: '<table id="LC_title_bar">'.
4034: "<tr><td> $titleinfo $dc_info</td>".$roleinfo.
4035: '</tr></table>';
1.337 albertel 4036: }
1.359 albertel 4037: if ($notopbar) {
4038: $bodytag .= $titletable;
4039: } else {
4040: if ($env{'request.state'} eq 'construct') {
1.337 albertel 4041: $bodytag .= &Apache::lonmenu::menubuttons($forcereg,$forcereg,
4042: $titletable);
1.272 raeburn 4043: } else {
1.336 albertel 4044: $bodytag .= &Apache::lonmenu::menubuttons($forcereg,$forcereg).
1.359 albertel 4045: $titletable;
1.272 raeburn 4046: }
1.235 raeburn 4047: }
4048: return $bodytag;
1.94 www 4049: }
1.95 www 4050:
1.93 www 4051: #
1.95 www 4052: # Top frame rendering, Remote is up
1.93 www 4053: #
1.359 albertel 4054:
1.517 raeburn 4055: my $imgsrc = $img;
4056: if ($img =~ /^\/adm/) {
1.575 albertel 4057: $imgsrc = &lonhttpdurl($img);
1.517 raeburn 4058: }
4059: my $upperleft='<img src="'.$imgsrc.'" alt="'.$function.'" />';
1.359 albertel 4060:
1.305 www 4061: # Explicit link to get inline menu
1.361 albertel 4062: my $menu= ($no_inline_link?''
4063: :'<br /><a href="/adm/remote?action=collapse">'.&mt('Switch to Inline Menu Mode').'</a>');
1.245 matthew 4064: #
1.338 albertel 4065: if ($notitle) {
1.337 albertel 4066: return $bodytag;
4067: }
1.94 www 4068: return(<<ENDBODY);
1.60 matthew 4069: $bodytag
1.359 albertel 4070: <table id="LC_title_bar" class="LC_with_remote">
1.368 albertel 4071: <tr><td class="LC_title_bar_role_logo">$upperleft</td>
1.359 albertel 4072: <td class="LC_title_bar_domain_logo">$messages </td>
1.54 www 4073: </tr>
1.359 albertel 4074: <tr><td>$titleinfo $dc_info $menu</td>
4075: $roleinfo
1.368 albertel 4076: </tr>
1.356 albertel 4077: </table>
1.54 www 4078: ENDBODY
1.182 matthew 4079: }
4080:
1.330 albertel 4081: sub make_attr_string {
4082: my ($register,$attr_ref) = @_;
4083:
4084: if ($attr_ref && !ref($attr_ref)) {
4085: die("addentries Must be a hash ref ".
4086: join(':',caller(1))." ".
4087: join(':',caller(0))." ");
4088: }
4089:
4090: if ($register) {
1.339 albertel 4091: my ($on_load,$on_unload);
4092: foreach my $key (keys(%{$attr_ref})) {
4093: if (lc($key) eq 'onload') {
4094: $on_load.=$attr_ref->{$key}.';';
4095: delete($attr_ref->{$key});
4096:
4097: } elsif (lc($key) eq 'onunload') {
4098: $on_unload.=$attr_ref->{$key}.';';
4099: delete($attr_ref->{$key});
4100: }
4101: }
4102: $attr_ref->{'onload'} =
4103: &Apache::lonmenu::loadevents(). $on_load;
4104: $attr_ref->{'onunload'}=
4105: &Apache::lonmenu::unloadevents().$on_unload;
4106: }
4107:
4108: # Accessibility font enhance
4109: if ($env{'browser.fontenhance'} eq 'on') {
4110: my $style;
4111: foreach my $key (keys(%{$attr_ref})) {
4112: if (lc($key) eq 'style') {
4113: $style.=$attr_ref->{$key}.';';
4114: delete($attr_ref->{$key});
4115: }
4116: }
4117: $attr_ref->{'style'}=$style.'; font-size: x-large;';
1.330 albertel 4118: }
1.339 albertel 4119:
4120: if ($env{'browser.blackwhite'} eq 'on') {
4121: delete($attr_ref->{'font'});
4122: delete($attr_ref->{'link'});
4123: delete($attr_ref->{'alink'});
4124: delete($attr_ref->{'vlink'});
4125: delete($attr_ref->{'bgcolor'});
4126: delete($attr_ref->{'background'});
4127: }
4128:
1.330 albertel 4129: my $attr_string;
4130: foreach my $attr (keys(%$attr_ref)) {
4131: $attr_string .= " $attr=\"".$attr_ref->{$attr}.'" ';
4132: }
4133: return $attr_string;
4134: }
4135:
4136:
1.182 matthew 4137: ###############################################
1.251 albertel 4138: ###############################################
4139:
4140: =pod
4141:
4142: =item * &endbodytag()
4143:
4144: Returns a uniform footer for LON-CAPA web pages.
4145:
1.635 raeburn 4146: Inputs: 1 - optional reference to an args hash
4147: If in the hash, key for noredirectlink has a value which evaluates to true,
4148: a 'Continue' link is not displayed if the page contains an
4149: internal redirect in the <head></head> section,
4150: i.e., $env{'internal.head.redirect'} exists
1.251 albertel 4151:
4152: =cut
4153:
4154: sub endbodytag {
1.635 raeburn 4155: my ($args) = @_;
1.251 albertel 4156: my $endbodytag='</body>';
1.269 albertel 4157: $endbodytag=&Apache::lontexconvert::jsMath_process()."\n".$endbodytag;
1.315 albertel 4158: if ( exists( $env{'internal.head.redirect'} ) ) {
1.635 raeburn 4159: if (!(ref($args) eq 'HASH' && $args->{'noredirectlink'})) {
4160: $endbodytag=
4161: "<br /><a href=\"$env{'internal.head.redirect'}\">".
4162: &mt('Continue').'</a>'.
4163: $endbodytag;
4164: }
1.315 albertel 4165: }
1.251 albertel 4166: return $endbodytag;
4167: }
4168:
1.352 albertel 4169: =pod
4170:
4171: =item * &standard_css()
4172:
4173: Returns a style sheet
4174:
4175: Inputs: (all optional)
4176: domain -> force to color decorate a page for a specific
4177: domain
4178: function -> force usage of a specific rolish color scheme
4179: bgcolor -> override the default page bgcolor
4180:
4181: =cut
4182:
1.343 albertel 4183: sub standard_css {
1.345 albertel 4184: my ($function,$domain,$bgcolor) = @_;
1.352 albertel 4185: $function = &get_users_function() if (!$function);
4186: my $img = &designparm($function.'.img', $domain);
4187: my $tabbg = &designparm($function.'.tabbg', $domain);
4188: my $font = &designparm($function.'.font', $domain);
1.345 albertel 4189: my $sidebg = &designparm($function.'.sidebg',$domain);
1.382 albertel 4190: my $pgbg_or_bgcolor =
4191: $bgcolor ||
1.352 albertel 4192: &designparm($function.'.pgbg', $domain);
1.382 albertel 4193: my $pgbg = &designparm($function.'.pgbg', $domain);
1.352 albertel 4194: my $alink = &designparm($function.'.alink', $domain);
4195: my $vlink = &designparm($function.'.vlink', $domain);
4196: my $link = &designparm($function.'.link', $domain);
4197:
1.602 albertel 4198: my $sans = 'Verdana,Arial,Helvetica,sans-serif';
1.395 albertel 4199: my $mono = 'monospace';
1.352 albertel 4200: my $data_table_head = $tabbg;
4201: my $data_table_light = '#EEEEEE';
1.470 banghart 4202: my $data_table_dark = '#DDDDDD';
4203: my $data_table_darker = '#CCCCCC';
1.349 albertel 4204: my $data_table_highlight = '#FFFF00';
1.352 albertel 4205: my $mail_new = '#FFBB77';
4206: my $mail_new_hover = '#DD9955';
4207: my $mail_read = '#BBBB77';
4208: my $mail_read_hover = '#999944';
4209: my $mail_replied = '#AAAA88';
4210: my $mail_replied_hover = '#888855';
4211: my $mail_other = '#99BBBB';
4212: my $mail_other_hover = '#669999';
1.391 albertel 4213: my $table_header = '#DDDDDD';
1.489 raeburn 4214: my $feedback_link_bg = '#BBBBBB';
1.392 albertel 4215:
1.608 albertel 4216: my $border = ($env{'browser.type'} eq 'explorer' ||
4217: $env{'browser.type'} eq 'safari' ) ? '0px 2px 0px 2px'
4218: : '0px 3px 0px 4px';
1.448 albertel 4219:
1.523 albertel 4220:
1.343 albertel 4221: return <<END;
1.345 albertel 4222: h1, h2, h3, th { font-family: $sans }
1.343 albertel 4223: a:focus { color: red; background: yellow }
1.510 albertel 4224: table.thinborder,
1.523 albertel 4225:
1.510 albertel 4226: table.thinborder tr th {
4227: border-style: solid;
4228: border-width: 1px;
4229: background: $tabbg;
4230: }
1.523 albertel 4231: table.thinborder tr td {
1.510 albertel 4232: border-style: solid;
4233: border-width: 1px
4234: }
1.426 albertel 4235:
1.343 albertel 4236: form, .inline { display: inline; }
4237: .center { text-align: center; }
1.593 albertel 4238: .LC_filename {font-family: $mono; white-space:pre;}
1.350 albertel 4239: .LC_error {
4240: color: red;
4241: font-size: larger;
4242: }
1.457 albertel 4243: .LC_warning,
4244: .LC_diff_removed {
1.394 albertel 4245: color: red;
4246: }
1.532 albertel 4247:
4248: .LC_info,
1.457 albertel 4249: .LC_success,
4250: .LC_diff_added {
1.350 albertel 4251: color: green;
4252: }
1.543 albertel 4253: .LC_unknown {
4254: color: yellow;
4255: }
4256:
1.440 albertel 4257: .LC_icon {
4258: border: 0px;
4259: }
1.539 albertel 4260: .LC_indexer_icon {
4261: border: 0px;
4262: height: 22px;
4263: }
1.543 albertel 4264: .LC_docs_spacer {
4265: width: 25px;
4266: height: 1px;
4267: border: 0px;
4268: }
1.346 albertel 4269:
1.532 albertel 4270: .LC_internal_info {
4271: color: #999;
4272: }
4273:
1.458 albertel 4274: table.LC_pastsubmission {
4275: border: 1px solid black;
4276: margin: 2px;
4277: }
4278:
1.606 albertel 4279: table#LC_top_nav, table#LC_menubuttons,table#LC_nav_location {
1.345 albertel 4280: width: 100%;
4281: background: $pgbg;
1.392 albertel 4282: border: 2px;
1.402 albertel 4283: border-collapse: separate;
1.403 albertel 4284: padding: 0px;
1.345 albertel 4285: }
1.392 albertel 4286:
1.606 albertel 4287: table#LC_title_bar, table.LC_breadcrumbs,
1.393 albertel 4288: table#LC_title_bar.LC_with_remote {
1.359 albertel 4289: width: 100%;
1.392 albertel 4290: border-color: $pgbg;
4291: border-style: solid;
4292: border-width: $border;
4293:
1.379 albertel 4294: background: $pgbg;
4295: font-family: $sans;
1.392 albertel 4296: border-collapse: collapse;
1.403 albertel 4297: padding: 0px;
1.359 albertel 4298: }
1.392 albertel 4299:
1.409 albertel 4300: table.LC_docs_path {
4301: width: 100%;
4302: border: 0;
4303: background: $pgbg;
4304: font-family: $sans;
4305: border-collapse: collapse;
4306: padding: 0px;
4307: }
4308:
1.359 albertel 4309: table#LC_title_bar td {
4310: background: $tabbg;
4311: }
4312: table#LC_title_bar td.LC_title_bar_who {
4313: background: $tabbg;
4314: color: $font;
1.427 albertel 4315: font: small $sans;
1.359 albertel 4316: text-align: right;
4317: }
1.469 banghart 4318: span.LC_metadata {
4319: font-family: $sans;
4320: }
1.359 albertel 4321: span.LC_title_bar_title {
1.416 albertel 4322: font: bold x-large $sans;
1.359 albertel 4323: }
4324: table#LC_title_bar td.LC_title_bar_domain_logo {
4325: background: $sidebg;
4326: text-align: right;
1.368 albertel 4327: padding: 0px;
4328: }
4329: table#LC_title_bar td.LC_title_bar_role_logo {
4330: background: $sidebg;
4331: padding: 0px;
1.359 albertel 4332: }
4333:
1.346 albertel 4334: table#LC_menubuttons_mainmenu {
1.526 www 4335: width: 100%;
1.346 albertel 4336: border: 0px;
4337: border-spacing: 1px;
1.372 albertel 4338: padding: 0px 1px;
1.346 albertel 4339: margin: 0px;
4340: border-collapse: separate;
4341: }
4342: table#LC_menubuttons img, table#LC_menubuttons_mainmenu img {
4343: border: 0px;
4344: }
1.345 albertel 4345: table#LC_top_nav td {
4346: background: $tabbg;
1.392 albertel 4347: border: 0px;
1.407 albertel 4348: font-size: small;
1.345 albertel 4349: }
4350: table#LC_top_nav td a, div#LC_top_nav a {
4351: color: $font;
4352: font-family: $sans;
4353: }
1.364 albertel 4354: table#LC_top_nav td.LC_top_nav_logo {
4355: background: $tabbg;
1.432 albertel 4356: text-align: left;
1.408 albertel 4357: white-space: nowrap;
1.432 albertel 4358: width: 31px;
1.408 albertel 4359: }
4360: table#LC_top_nav td.LC_top_nav_logo img {
1.432 albertel 4361: border: 0px;
1.408 albertel 4362: vertical-align: bottom;
1.364 albertel 4363: }
1.432 albertel 4364: table#LC_top_nav td.LC_top_nav_exit,
4365: table#LC_top_nav td.LC_top_nav_help {
4366: width: 2.0em;
4367: }
1.442 albertel 4368: table#LC_top_nav td.LC_top_nav_login {
4369: width: 4.0em;
4370: text-align: center;
4371: }
1.409 albertel 4372: table.LC_breadcrumbs td, table.LC_docs_path td {
1.357 albertel 4373: background: $tabbg;
4374: color: $font;
4375: font-family: $sans;
1.358 albertel 4376: font-size: smaller;
1.357 albertel 4377: }
1.411 albertel 4378: table.LC_breadcrumbs td.LC_breadcrumbs_component,
1.409 albertel 4379: table.LC_docs_path td.LC_docs_path_component {
1.357 albertel 4380: background: $tabbg;
4381: color: $font;
4382: font-family: $sans;
4383: font-size: larger;
4384: text-align: right;
4385: }
1.383 albertel 4386: td.LC_table_cell_checkbox {
4387: text-align: center;
4388: }
4389:
1.522 albertel 4390: table#LC_mainmenu td.LC_mainmenu_column {
4391: vertical-align: top;
4392: }
4393:
1.346 albertel 4394: .LC_menubuttons_inline_text {
4395: color: $font;
4396: font-family: $sans;
4397: font-size: smaller;
4398: }
4399:
1.526 www 4400: .LC_menubuttons_link {
4401: text-decoration: none;
4402: }
4403:
1.522 albertel 4404: .LC_menubuttons_category {
1.521 www 4405: color: $font;
1.526 www 4406: background: $pgbg;
1.521 www 4407: font-family: $sans;
4408: font-size: larger;
4409: font-weight: bold;
4410: }
4411:
1.346 albertel 4412: td.LC_menubuttons_text {
1.526 www 4413: width: 90%;
1.346 albertel 4414: color: $font;
4415: font-family: $sans;
4416: }
1.526 www 4417:
1.346 albertel 4418: td.LC_menubuttons_img {
4419: }
1.526 www 4420:
1.346 albertel 4421: .LC_current_location {
4422: font-family: $sans;
4423: background: $tabbg;
4424: }
4425: .LC_new_mail {
4426: font-family: $sans;
1.634 www 4427: background: $tabbg;
1.346 albertel 4428: font-weight: bold;
4429: }
1.347 albertel 4430:
1.526 www 4431: .LC_rolesmenu_is {
4432: font-family: $sans;
4433: }
4434:
4435: .LC_rolesmenu_selected {
4436: font-family: $sans;
4437: }
4438:
4439: .LC_rolesmenu_future {
4440: font-family: $sans;
4441: }
4442:
4443:
4444: .LC_rolesmenu_will {
4445: font-family: $sans;
4446: }
4447:
4448: .LC_rolesmenu_will_not {
4449: font-family: $sans;
4450: }
4451:
4452: .LC_rolesmenu_expired {
4453: font-family: $sans;
4454: }
4455:
4456: .LC_rolesinfo {
4457: font-family: $sans;
4458: }
4459:
1.527 www 4460: .LC_dropadd_labeltext {
4461: font-family: $sans;
4462: text-align: right;
4463: }
4464:
4465: .LC_preferences_labeltext {
4466: font-family: $sans;
4467: text-align: right;
4468: }
4469:
1.440 albertel 4470: table.LC_aboutme_port {
4471: border: 0px;
4472: border-collapse: collapse;
4473: border-spacing: 0px;
4474: }
1.349 albertel 4475: table.LC_data_table, table.LC_mail_list {
1.347 albertel 4476: border: 1px solid #000000;
1.402 albertel 4477: border-collapse: separate;
1.426 albertel 4478: border-spacing: 1px;
1.610 albertel 4479: background: $pgbg;
1.347 albertel 4480: }
1.422 albertel 4481: .LC_data_table_dense {
4482: font-size: small;
4483: }
1.507 raeburn 4484: table.LC_nested_outer {
4485: border: 1px solid #000000;
1.589 raeburn 4486: border-collapse: collapse;
1.507 raeburn 4487: border-spacing: 0px;
4488: width: 100%;
4489: }
4490: table.LC_nested {
4491: border: 0px;
1.589 raeburn 4492: border-collapse: collapse;
1.507 raeburn 4493: border-spacing: 0px;
4494: width: 100%;
4495: }
1.523 albertel 4496: table.LC_data_table tr th, table.LC_calendar tr th, table.LC_mail_list tr th,
4497: table.LC_prior_tries tr th {
1.349 albertel 4498: font-weight: bold;
4499: background-color: $data_table_head;
1.421 albertel 4500: font-size: smaller;
1.347 albertel 4501: }
1.610 albertel 4502: table.LC_data_table tr.LC_odd_row > td,
1.440 albertel 4503: table.LC_aboutme_port tr td {
1.349 albertel 4504: background-color: $data_table_light;
1.425 albertel 4505: padding: 2px;
1.347 albertel 4506: }
1.610 albertel 4507: table.LC_data_table tr.LC_even_row > td,
1.440 albertel 4508: table.LC_aboutme_port tr.LC_even_row td {
1.349 albertel 4509: background-color: $data_table_dark;
1.347 albertel 4510: }
1.425 albertel 4511: table.LC_data_table tr.LC_data_table_highlight td {
4512: background-color: $data_table_darker;
4513: }
1.639 raeburn 4514: table.LC_data_table tr td.LC_leftcol_header {
4515: background-color: $data_table_head;
4516: font-weight: bold;
4517: }
1.451 albertel 4518: table.LC_data_table tr.LC_empty_row td,
1.507 raeburn 4519: table.LC_nested tr.LC_empty_row td {
1.347 albertel 4520: background-color: #FFFFFF;
1.421 albertel 4521: font-weight: bold;
4522: font-style: italic;
4523: text-align: center;
4524: padding: 8px;
1.347 albertel 4525: }
1.507 raeburn 4526: table.LC_nested tr.LC_empty_row td {
1.465 albertel 4527: padding: 4ex
4528: }
1.507 raeburn 4529: table.LC_nested_outer tr th {
4530: font-weight: bold;
4531: background-color: $data_table_head;
4532: font-size: smaller;
4533: border-bottom: 1px solid #000000;
4534: }
4535: table.LC_nested_outer tr td.LC_subheader {
4536: background-color: $data_table_head;
4537: font-weight: bold;
4538: font-size: small;
4539: border-bottom: 1px solid #000000;
4540: text-align: right;
1.451 albertel 4541: }
1.507 raeburn 4542: table.LC_nested tr.LC_info_row td {
1.451 albertel 4543: background-color: #CCC;
4544: font-weight: bold;
4545: font-size: small;
1.507 raeburn 4546: text-align: center;
4547: }
1.589 raeburn 4548: table.LC_nested tr.LC_info_row td.LC_left_item,
4549: table.LC_nested_outer tr th.LC_left_item {
1.507 raeburn 4550: text-align: left;
1.451 albertel 4551: }
1.507 raeburn 4552: table.LC_nested td {
1.451 albertel 4553: background-color: #FFF;
4554: font-size: small;
1.507 raeburn 4555: }
4556: table.LC_nested_outer tr th.LC_right_item,
4557: table.LC_nested tr.LC_info_row td.LC_right_item,
4558: table.LC_nested tr.LC_odd_row td.LC_right_item,
4559: table.LC_nested tr td.LC_right_item {
1.451 albertel 4560: text-align: right;
4561: }
4562:
1.507 raeburn 4563: table.LC_nested tr.LC_odd_row td {
1.451 albertel 4564: background-color: #EEE;
4565: }
4566:
1.473 raeburn 4567: table.LC_createuser {
4568: }
4569:
4570: table.LC_createuser tr.LC_section_row td {
4571: font-size: smaller;
4572: }
4573:
4574: table.LC_createuser tr.LC_info_row td {
4575: background-color: #CCC;
4576: font-weight: bold;
4577: text-align: center;
4578: }
4579:
1.349 albertel 4580: table.LC_calendar {
4581: border: 1px solid #000000;
4582: border-collapse: collapse;
4583: }
4584: table.LC_calendar_pickdate {
4585: font-size: xx-small;
4586: }
4587: table.LC_calendar tr td {
4588: border: 1px solid #000000;
4589: vertical-align: top;
4590: }
4591: table.LC_calendar tr td.LC_calendar_day_empty {
4592: background-color: $data_table_dark;
4593: }
4594: table.LC_calendar tr td.LC_calendar_day_current {
4595: background-color: $data_table_highlight;
4596: }
4597:
4598: table.LC_mail_list tr.LC_mail_new {
4599: background-color: $mail_new;
4600: }
4601: table.LC_mail_list tr.LC_mail_new:hover {
4602: background-color: $mail_new_hover;
4603: }
4604: table.LC_mail_list tr.LC_mail_read {
4605: background-color: $mail_read;
4606: }
4607: table.LC_mail_list tr.LC_mail_read:hover {
4608: background-color: $mail_read_hover;
4609: }
4610: table.LC_mail_list tr.LC_mail_replied {
4611: background-color: $mail_replied;
4612: }
4613: table.LC_mail_list tr.LC_mail_replied:hover {
4614: background-color: $mail_replied_hover;
4615: }
4616: table.LC_mail_list tr.LC_mail_other {
4617: background-color: $mail_other;
4618: }
4619: table.LC_mail_list tr.LC_mail_other:hover {
4620: background-color: $mail_other_hover;
4621: }
1.494 raeburn 4622: table.LC_mail_list tr.LC_mail_even {
4623: }
4624: table.LC_mail_list tr.LC_mail_odd {
4625: }
4626:
1.385 albertel 4627:
1.386 albertel 4628: table#LC_portfolio_actions {
4629: width: auto;
4630: background: $pgbg;
4631: border: 0px;
4632: border-spacing: 2px 2px;
4633: padding: 0px;
4634: margin: 0px;
4635: border-collapse: separate;
4636: }
4637: table#LC_portfolio_actions td.LC_label {
4638: background: $tabbg;
4639: text-align: right;
4640: }
4641: table#LC_portfolio_actions td.LC_value {
4642: background: $tabbg;
4643: }
1.385 albertel 4644:
1.391 albertel 4645: table#LC_cstr_controls {
4646: width: 100%;
4647: border-collapse: collapse;
4648: }
4649: table#LC_cstr_controls tr td {
4650: border: 4px solid $pgbg;
4651: padding: 4px;
4652: text-align: center;
4653: background: $tabbg;
4654: }
4655: table#LC_cstr_controls tr th {
4656: border: 4px solid $pgbg;
4657: background: $table_header;
4658: text-align: center;
4659: font-family: $sans;
4660: font-size: smaller;
4661: }
4662:
1.389 albertel 4663: table#LC_browser {
4664:
4665: }
4666: table#LC_browser tr th {
1.391 albertel 4667: background: $table_header;
1.389 albertel 4668: }
1.390 albertel 4669: table#LC_browser tr td {
4670: padding: 2px;
4671: }
1.389 albertel 4672: table#LC_browser tr.LC_browser_file,
4673: table#LC_browser tr.LC_browser_file_published {
4674: background: #CCFF88;
4675: }
4676: table#LC_browser tr.LC_browser_file_locked,
4677: table#LC_browser tr.LC_browser_file_unpublished {
4678: background: #FFAA99;
1.387 albertel 4679: }
1.389 albertel 4680: table#LC_browser tr.LC_browser_file_obsolete {
4681: background: #AAAAAA;
1.387 albertel 4682: }
1.455 albertel 4683: table#LC_browser tr.LC_browser_file_modified,
4684: table#LC_browser tr.LC_browser_file_metamodified {
1.389 albertel 4685: background: #FFFF77;
1.387 albertel 4686: }
1.389 albertel 4687: table#LC_browser tr.LC_browser_folder {
4688: background: #CCCCFF;
1.387 albertel 4689: }
1.388 albertel 4690: span.LC_current_location {
4691: font-size: x-large;
4692: background: $pgbg;
4693: }
1.387 albertel 4694:
1.395 albertel 4695: span.LC_parm_menu_item {
4696: font-size: larger;
4697: font-family: $sans;
4698: }
4699: span.LC_parm_scope_all {
4700: color: red;
4701: }
4702: span.LC_parm_scope_folder {
4703: color: green;
4704: }
4705: span.LC_parm_scope_resource {
4706: color: orange;
4707: }
4708: span.LC_parm_part {
4709: color: blue;
4710: }
4711: span.LC_parm_folder, span.LC_parm_symb {
4712: font-size: x-small;
4713: font-family: $mono;
4714: color: #AAAAAA;
4715: }
4716:
1.396 albertel 4717: td.LC_parm_overview_level_menu, td.LC_parm_overview_map_menu,
4718: td.LC_parm_overview_parm_selectors, td.LC_parm_overview_parm_restrictions {
4719: border: 1px solid black;
4720: border-collapse: collapse;
4721: }
4722: table.LC_parm_overview_restrictions td {
4723: border-width: 1px 4px 1px 4px;
4724: border-style: solid;
4725: border-color: $pgbg;
4726: text-align: center;
4727: }
4728: table.LC_parm_overview_restrictions th {
4729: background: $tabbg;
4730: border-width: 1px 4px 1px 4px;
4731: border-style: solid;
4732: border-color: $pgbg;
4733: }
1.398 albertel 4734: table#LC_helpmenu {
4735: border: 0px;
4736: height: 55px;
4737: border-spacing: 0px;
4738: }
4739:
4740: table#LC_helpmenu fieldset legend {
4741: font-size: larger;
4742: font-weight: bold;
4743: }
1.397 albertel 4744: table#LC_helpmenu_links {
4745: width: 100%;
4746: border: 1px solid black;
4747: background: $pgbg;
4748: padding: 0px;
4749: border-spacing: 1px;
4750: }
4751: table#LC_helpmenu_links tr td {
4752: padding: 1px;
4753: background: $tabbg;
1.399 albertel 4754: text-align: center;
4755: font-weight: bold;
1.397 albertel 4756: }
1.396 albertel 4757:
1.397 albertel 4758: table#LC_helpmenu_links a:link, table#LC_helpmenu_links a:visited,
4759: table#LC_helpmenu_links a:active {
4760: text-decoration: none;
4761: color: $font;
4762: }
4763: table#LC_helpmenu_links a:hover {
4764: text-decoration: underline;
4765: color: $vlink;
4766: }
1.396 albertel 4767:
1.417 albertel 4768: .LC_chrt_popup_exists {
4769: border: 1px solid #339933;
4770: margin: -1px;
4771: }
4772: .LC_chrt_popup_up {
4773: border: 1px solid yellow;
4774: margin: -1px;
4775: }
4776: .LC_chrt_popup {
4777: border: 1px solid #8888FF;
4778: background: #CCCCFF;
4779: }
1.421 albertel 4780: table.LC_pick_box {
4781: border-collapse: separate;
4782: background: white;
4783: border: 1px solid black;
4784: border-spacing: 1px;
4785: }
4786: table.LC_pick_box td.LC_pick_box_title {
4787: background: $tabbg;
4788: font-weight: bold;
4789: text-align: right;
4790: width: 184px;
4791: padding: 8px;
4792: }
1.645 ! raeburn 4793: table.LC_pick_box td.LC_selfenroll_pick_box_title {
! 4794: background: $tabbg;
! 4795: font-weight: bold;
! 4796: text-align: right;
! 4797: width: 350px;
! 4798: padding: 8px;
! 4799: }
! 4800:
1.579 raeburn 4801: table.LC_pick_box td.LC_pick_box_value {
4802: text-align: left;
4803: padding: 8px;
4804: }
4805: table.LC_pick_box td.LC_pick_box_select {
4806: text-align: left;
4807: padding: 8px;
4808: }
1.424 albertel 4809: table.LC_pick_box td.LC_pick_box_separator {
1.421 albertel 4810: padding: 0px;
4811: height: 1px;
4812: background: black;
4813: }
4814: table.LC_pick_box td.LC_pick_box_submit {
4815: text-align: right;
4816: }
1.579 raeburn 4817: table.LC_pick_box td.LC_evenrow_value {
4818: text-align: left;
4819: padding: 8px;
4820: background-color: $data_table_light;
4821: }
4822: table.LC_pick_box td.LC_oddrow_value {
4823: text-align: left;
4824: padding: 8px;
4825: background-color: $data_table_light;
4826: }
4827: table.LC_helpform_receipt {
4828: width: 620px;
4829: border-collapse: separate;
4830: background: white;
4831: border: 1px solid black;
4832: border-spacing: 1px;
4833: }
4834: table.LC_helpform_receipt td.LC_pick_box_title {
4835: background: $tabbg;
4836: font-weight: bold;
4837: text-align: right;
4838: width: 184px;
4839: padding: 8px;
4840: }
4841: table.LC_helpform_receipt td.LC_evenrow_value {
4842: text-align: left;
4843: padding: 8px;
4844: background-color: $data_table_light;
4845: }
4846: table.LC_helpform_receipt td.LC_oddrow_value {
4847: text-align: left;
4848: padding: 8px;
4849: background-color: $data_table_light;
4850: }
4851: table.LC_helpform_receipt td.LC_pick_box_separator {
4852: padding: 0px;
4853: height: 1px;
4854: background: black;
4855: }
4856: span.LC_helpform_receipt_cat {
4857: font-weight: bold;
4858: }
1.424 albertel 4859: table.LC_group_priv_box {
4860: background: white;
4861: border: 1px solid black;
4862: border-spacing: 1px;
4863: }
4864: table.LC_group_priv_box td.LC_pick_box_title {
4865: background: $tabbg;
4866: font-weight: bold;
4867: text-align: right;
4868: width: 184px;
4869: }
4870: table.LC_group_priv_box td.LC_groups_fixed {
4871: background: $data_table_light;
4872: text-align: center;
4873: }
4874: table.LC_group_priv_box td.LC_groups_optional {
4875: background: $data_table_dark;
4876: text-align: center;
4877: }
4878: table.LC_group_priv_box td.LC_groups_functionality {
4879: background: $data_table_darker;
4880: text-align: center;
4881: font-weight: bold;
4882: }
4883: table.LC_group_priv td {
4884: text-align: left;
4885: padding: 0px;
4886: }
4887:
1.421 albertel 4888: table.LC_notify_front_page {
4889: background: white;
4890: border: 1px solid black;
4891: padding: 8px;
4892: }
4893: table.LC_notify_front_page td {
4894: padding: 8px;
4895: }
1.424 albertel 4896: .LC_navbuttons {
4897: margin: 2ex 0ex 2ex 0ex;
4898: }
1.423 albertel 4899: .LC_topic_bar {
4900: font-family: $sans;
4901: font-weight: bold;
4902: width: 100%;
4903: background: $tabbg;
4904: vertical-align: middle;
4905: margin: 2ex 0ex 2ex 0ex;
4906: }
4907: .LC_topic_bar span {
4908: vertical-align: middle;
4909: }
4910: .LC_topic_bar img {
4911: vertical-align: bottom;
4912: }
4913: table.LC_course_group_status {
4914: margin: 20px;
4915: }
4916: table.LC_status_selector td {
4917: vertical-align: top;
4918: text-align: center;
1.424 albertel 4919: padding: 4px;
4920: }
4921: table.LC_descriptive_input td.LC_description {
4922: vertical-align: top;
4923: text-align: right;
4924: font-weight: bold;
1.423 albertel 4925: }
1.599 albertel 4926: div.LC_feedback_link {
1.616 albertel 4927: clear: both;
1.599 albertel 4928: background: white;
4929: width: 100%;
1.489 raeburn 4930: }
4931: span.LC_feedback_link {
1.599 albertel 4932: background: $feedback_link_bg;
4933: font-size: larger;
4934: }
4935: span.LC_message_link {
4936: background: $feedback_link_bg;
4937: font-size: larger;
4938: position: absolute;
4939: right: 1em;
1.489 raeburn 4940: }
1.421 albertel 4941:
1.515 albertel 4942: table.LC_prior_tries {
1.524 albertel 4943: border: 1px solid #000000;
4944: border-collapse: separate;
4945: border-spacing: 1px;
1.515 albertel 4946: }
1.523 albertel 4947:
1.515 albertel 4948: table.LC_prior_tries td {
1.524 albertel 4949: padding: 2px;
1.515 albertel 4950: }
1.523 albertel 4951:
4952: .LC_answer_correct {
4953: background: #AAFFAA;
4954: color: black;
4955: }
4956: .LC_answer_charged_try {
4957: background: #FFAAAA ! important;
4958: color: black;
4959: }
4960: .LC_answer_not_charged_try,
4961: .LC_answer_no_grade,
4962: .LC_answer_late {
4963: background: #FFFFAA;
4964: color: black;
4965: }
4966: .LC_answer_previous {
4967: background: #AAAAFF;
4968: color: black;
4969: }
4970: .LC_answer_no_message {
4971: background: #FFFFFF;
4972: color: black;
4973: }
4974: .LC_answer_unknown {
4975: background: orange;
4976: color: black;
4977: }
4978:
4979:
1.529 albertel 4980: span.LC_prior_numerical,
4981: span.LC_prior_string,
4982: span.LC_prior_custom,
4983: span.LC_prior_reaction,
4984: span.LC_prior_math {
1.523 albertel 4985: font-family: monospace;
4986: white-space: pre;
4987: }
4988:
1.525 albertel 4989: span.LC_prior_string {
4990: font-family: monospace;
4991: white-space: pre;
4992: }
4993:
1.523 albertel 4994: table.LC_prior_option {
4995: width: 100%;
4996: border-collapse: collapse;
4997: }
1.528 albertel 4998: table.LC_prior_rank, table.LC_prior_match {
4999: border-collapse: collapse;
5000: }
5001: table.LC_prior_option tr td,
5002: table.LC_prior_rank tr td,
5003: table.LC_prior_match tr td {
1.524 albertel 5004: border: 1px solid #000000;
1.515 albertel 5005: }
5006:
1.519 raeburn 5007: span.LC_nobreak {
1.544 albertel 5008: white-space: nowrap;
1.519 raeburn 5009: }
5010:
1.576 raeburn 5011: span.LC_cusr_emph {
5012: font-style: italic;
5013: }
5014:
1.633 raeburn 5015: span.LC_cusr_subheading {
5016: font-weight: normal;
5017: font-size: 85%;
5018: }
5019:
1.545 albertel 5020: table.LC_docs_documents {
5021: background: #BBBBBB;
1.547 albertel 5022: border-width: 0px;
1.545 albertel 5023: border-collapse: collapse;
5024: }
5025:
5026: table.LC_docs_documents td.LC_docs_document {
5027: border: 2px solid black;
5028: padding: 4px;
5029: }
5030:
5031: .LC_docs_course_commands div {
5032: float: left;
5033: border: 4px solid #AAAAAA;
5034: padding: 4px;
5035: background: #DDDDCC;
5036: }
5037:
5038: .LC_docs_entry_move {
5039: border: 0px;
5040: border-collapse: collapse;
1.544 albertel 5041: }
5042:
1.545 albertel 5043: .LC_docs_entry_move td {
5044: border: 2px solid #BBBBBB;
5045: background: #DDDDDD;
5046: }
5047:
5048: .LC_docs_editor td.LC_docs_entry_commands {
5049: background: #DDDDDD;
5050: font-size: x-small;
5051: }
1.544 albertel 5052: .LC_docs_copy {
1.545 albertel 5053: color: #000099;
1.544 albertel 5054: }
5055: .LC_docs_cut {
1.545 albertel 5056: color: #550044;
1.544 albertel 5057: }
5058: .LC_docs_rename {
1.545 albertel 5059: color: #009900;
1.544 albertel 5060: }
5061: .LC_docs_remove {
1.545 albertel 5062: color: #990000;
5063: }
5064:
1.547 albertel 5065: .LC_docs_reinit_warn,
5066: .LC_docs_ext_edit {
5067: font-size: x-small;
5068: }
5069:
1.545 albertel 5070: .LC_docs_editor td.LC_docs_entry_title,
5071: .LC_docs_editor td.LC_docs_entry_icon {
5072: background: #FFFFBB;
5073: }
5074: .LC_docs_editor td.LC_docs_entry_parameter {
5075: background: #BBBBFF;
5076: font-size: x-small;
5077: white-space: nowrap;
5078: }
5079:
5080: table.LC_docs_adddocs td,
5081: table.LC_docs_adddocs th {
5082: border: 1px solid #BBBBBB;
5083: padding: 4px;
5084: background: #DDDDDD;
1.543 albertel 5085: }
5086:
1.584 albertel 5087: table.LC_sty_begin {
5088: background: #BBFFBB;
5089: }
5090: table.LC_sty_end {
5091: background: #FFBBBB;
5092: }
5093:
1.589 raeburn 5094: table.LC_double_column {
5095: border-width: 0px;
5096: border-collapse: collapse;
5097: width: 100%;
5098: padding: 2px;
5099: }
5100:
5101: table.LC_double_column tr td.LC_left_col {
1.590 raeburn 5102: top: 2px;
1.589 raeburn 5103: left: 2px;
5104: width: 47%;
5105: vertical-align: top;
5106: }
5107:
5108: table.LC_double_column tr td.LC_right_col {
5109: top: 2px;
5110: right: 2px;
5111: width: 47%;
5112: vertical-align: top;
5113: }
5114:
1.594 raeburn 5115: span.LC_role_level {
5116: font-weight: bold;
5117: }
5118:
1.591 raeburn 5119: div.LC_left_float {
5120: float: left;
5121: padding-right: 5%;
1.597 albertel 5122: padding-bottom: 4px;
1.591 raeburn 5123: }
5124:
5125: div.LC_clear_float_header {
1.597 albertel 5126: padding-bottom: 2px;
1.591 raeburn 5127: }
5128:
5129: div.LC_clear_float_footer {
1.597 albertel 5130: padding-top: 10px;
1.591 raeburn 5131: clear: both;
5132: }
5133:
1.597 albertel 5134:
1.601 albertel 5135: div.LC_grade_select_mode {
1.604 albertel 5136: font-family: $sans;
1.601 albertel 5137: }
5138: div.LC_grade_select_mode div div {
5139: margin: 5px;
5140: }
5141: div.LC_grade_select_mode_selector {
5142: margin: 5px;
5143: float: left;
5144: }
5145: div.LC_grade_select_mode_selector_header {
5146: font: bold medium $sans;
5147: }
5148: div.LC_grade_select_mode_type {
5149: clear: left;
5150: }
5151:
1.597 albertel 5152: div.LC_grade_show_user {
5153: margin-top: 20px;
5154: border: 1px solid black;
5155: }
5156: div.LC_grade_user_name {
5157: background: #DDDDEE;
5158: border-bottom: 1px solid black;
5159: font: bold large $sans;
5160: }
5161: div.LC_grade_show_user_odd_row div.LC_grade_user_name {
5162: background: #DDEEDD;
5163: }
5164:
5165: div.LC_grade_show_problem,
5166: div.LC_grade_submissions,
5167: div.LC_grade_message_center,
5168: div.LC_grade_info_links,
5169: div.LC_grade_assign {
5170: margin: 5px;
5171: width: 99%;
5172: background: #FFFFFF;
5173: }
5174: div.LC_grade_show_problem_header,
5175: div.LC_grade_submissions_header,
5176: div.LC_grade_message_center_header,
5177: div.LC_grade_assign_header {
5178: font: bold large $sans;
5179: }
5180: div.LC_grade_show_problem_problem,
5181: div.LC_grade_submissions_body,
5182: div.LC_grade_message_center_body,
5183: div.LC_grade_assign_body {
5184: border: 1px solid black;
5185: width: 99%;
5186: background: #FFFFFF;
5187: }
1.598 albertel 5188: span.LC_grade_check_note {
5189: font: normal medium $sans;
5190: display: inline;
5191: position: absolute;
5192: right: 1em;
5193: }
1.597 albertel 5194:
1.613 albertel 5195: table.LC_scantron_action {
5196: width: 100%;
5197: }
5198: table.LC_scantron_action tr th {
5199: font: normal bold $sans;
5200: }
1.600 albertel 5201:
1.614 albertel 5202: div.LC_edit_problem_header,
5203: div.LC_edit_problem_footer {
1.600 albertel 5204: font: normal medium $sans;
1.602 albertel 5205: margin: 2px;
1.600 albertel 5206: }
5207: div.LC_edit_problem_header,
1.602 albertel 5208: div.LC_edit_problem_header div,
1.614 albertel 5209: div.LC_edit_problem_footer,
5210: div.LC_edit_problem_footer div,
1.602 albertel 5211: div.LC_edit_problem_editxml_header,
5212: div.LC_edit_problem_editxml_header div {
1.600 albertel 5213: margin-top: 5px;
5214: }
1.602 albertel 5215: div.LC_edit_problem_header_edit_row {
5216: background: $tabbg;
5217: padding: 3px;
5218: margin-bottom: 5px;
5219: }
1.600 albertel 5220: div.LC_edit_problem_header_title {
1.602 albertel 5221: font: larger bold $sans;
5222: background: $tabbg;
5223: padding: 3px;
5224: }
5225: table.LC_edit_problem_header_title {
5226: font: larger bold $sans;
5227: width: 100%;
5228: border-color: $pgbg;
5229: border-style: solid;
5230: border-width: $border;
5231:
1.600 albertel 5232: background: $tabbg;
1.602 albertel 5233: border-collapse: collapse;
5234: padding: 0px
5235: }
5236:
5237: div.LC_edit_problem_discards {
5238: float: left;
5239: padding-bottom: 5px;
5240: }
5241: div.LC_edit_problem_saves {
5242: float: right;
5243: padding-bottom: 5px;
1.600 albertel 5244: }
5245: hr.LC_edit_problem_divide {
1.602 albertel 5246: clear: both;
1.600 albertel 5247: color: $tabbg;
5248: background-color: $tabbg;
5249: height: 3px;
5250: border: 0px;
5251: }
1.343 albertel 5252: END
5253: }
5254:
1.306 albertel 5255: =pod
5256:
5257: =item * &headtag()
5258:
5259: Returns a uniform footer for LON-CAPA web pages.
5260:
1.307 albertel 5261: Inputs: $title - optional title for the head
5262: $head_extra - optional extra HTML to put inside the <head>
1.315 albertel 5263: $args - optional arguments
1.319 albertel 5264: force_register - if is true call registerurl so the remote is
5265: informed
1.415 albertel 5266: redirect -> array ref of
5267: 1- seconds before redirect occurs
5268: 2- url to redirect to
5269: 3- whether the side effect should occur
1.315 albertel 5270: (side effect of setting
5271: $env{'internal.head.redirect'} to the url
5272: redirected too)
1.352 albertel 5273: domain -> force to color decorate a page for a specific
5274: domain
5275: function -> force usage of a specific rolish color scheme
5276: bgcolor -> override the default page bgcolor
1.460 albertel 5277: no_auto_mt_title
5278: -> prevent &mt()ing the title arg
1.464 albertel 5279:
1.306 albertel 5280: =cut
5281:
5282: sub headtag {
1.313 albertel 5283: my ($title,$head_extra,$args) = @_;
1.306 albertel 5284:
1.363 albertel 5285: my $function = $args->{'function'} || &get_users_function();
5286: my $domain = $args->{'domain'} || &determinedomain();
5287: my $bgcolor = $args->{'bgcolor'} || &designparm($function.'.pgbg',$domain);
1.418 albertel 5288: my $url = join(':',$env{'user.name'},$env{'user.domain'},
1.458 albertel 5289: $Apache::lonnet::perlvar{'lonVersion'},
1.531 albertel 5290: #time(),
1.418 albertel 5291: $env{'environment.color.timestamp'},
1.363 albertel 5292: $function,$domain,$bgcolor);
5293:
1.369 www 5294: $url = '/adm/css/'.&escape($url).'.css';
1.363 albertel 5295:
1.308 albertel 5296: my $result =
5297: '<head>'.
1.461 albertel 5298: &font_settings();
1.319 albertel 5299:
1.461 albertel 5300: if (!$args->{'frameset'}) {
5301: $result .= &Apache::lonhtmlcommon::htmlareaheaders();
5302: }
1.319 albertel 5303: if ($args->{'force_register'}) {
5304: $result .= &Apache::lonmenu::registerurl(1);
5305: }
1.436 albertel 5306: if (!$args->{'no_nav_bar'}
5307: && !$args->{'only_body'}
5308: && !$args->{'frameset'}) {
5309: $result .= &help_menu_js();
5310: }
1.319 albertel 5311:
1.314 albertel 5312: if (ref($args->{'redirect'})) {
1.414 albertel 5313: my ($time,$url,$inhibit_continue) = @{$args->{'redirect'}};
1.315 albertel 5314: $url = &Apache::lonenc::check_encrypt($url);
1.414 albertel 5315: if (!$inhibit_continue) {
5316: $env{'internal.head.redirect'} = $url;
5317: }
1.313 albertel 5318: $result.=<<ADDMETA
5319: <meta http-equiv="pragma" content="no-cache" />
1.344 albertel 5320: <meta http-equiv="Refresh" content="$time; url=$url" />
1.313 albertel 5321: ADDMETA
5322: }
1.306 albertel 5323: if (!defined($title)) {
5324: $title = 'The LearningOnline Network with CAPA';
5325: }
1.460 albertel 5326: if (!$args->{'no_auto_mt_title'}) { $title = &mt($title); }
5327: $result .= '<title> LON-CAPA '.$title.'</title>'
1.414 albertel 5328: .'<link rel="stylesheet" type="text/css" href="'.$url.'" />'
5329: .$head_extra;
1.306 albertel 5330: return $result;
5331: }
5332:
5333: =pod
5334:
1.340 albertel 5335: =item * &font_settings()
5336:
5337: Returns neccessary <meta> to set the proper encoding
5338:
5339: Inputs: none
5340:
5341: =cut
5342:
5343: sub font_settings {
5344: my $headerstring='';
5345: if (($env{'browser.os'} eq 'mac') && (!$env{'browser.mathml'})) {
5346: $headerstring.=
5347: '<meta Content-Type="text/html; charset=x-mac-roman" />';
5348: } elsif (!$env{'browser.mathml'} && $env{'browser.unicode'}) {
5349: $headerstring.=
5350: '<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />';
5351: }
5352: return $headerstring;
5353: }
5354:
1.341 albertel 5355: =pod
5356:
5357: =item * &xml_begin()
5358:
5359: Returns the needed doctype and <html>
5360:
5361: Inputs: none
5362:
5363: =cut
5364:
5365: sub xml_begin {
5366: my $output='';
5367:
1.592 albertel 5368: if ($env{'internal.start_page'}==1) {
5369: &Apache::lonhtmlcommon::init_htmlareafields();
5370: }
1.342 albertel 5371:
1.341 albertel 5372: if ($env{'browser.mathml'}) {
5373: $output='<?xml version="1.0"?>'
5374: #.'<?xml-stylesheet type="text/css" href="/adm/MathML/mathml.css"?>'."\n"
5375: # .'<!DOCTYPE html SYSTEM "/adm/MathML/mathml.dtd" '
5376:
5377: # .'<!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">] >'
5378: .'<!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">'
5379: .'<html xmlns:math="http://www.w3.org/1998/Math/MathML" '
5380: .'xmlns="http://www.w3.org/1999/xhtml">';
5381: } else {
5382: $output='<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"><html>';
5383: }
5384: return $output;
5385: }
1.340 albertel 5386:
5387: =pod
5388:
1.306 albertel 5389: =item * &endheadtag()
5390:
5391: Returns a uniform </head> for LON-CAPA web pages.
5392:
5393: Inputs: none
5394:
5395: =cut
5396:
5397: sub endheadtag {
5398: return '</head>';
5399: }
5400:
5401: =pod
5402:
5403: =item * &head()
5404:
5405: Returns a uniform complete <head>..</head> section for LON-CAPA web pages.
5406:
5407: Inputs: $title - optional title for the page
1.307 albertel 5408: $head_extra - optional extra HTML to put inside the <head>
1.405 albertel 5409:
1.306 albertel 5410: =cut
5411:
5412: sub head {
1.325 albertel 5413: my ($title,$head_extra,$args) = @_;
5414: return &headtag($title,$head_extra,$args).&endheadtag();
1.306 albertel 5415: }
5416:
5417: =pod
5418:
5419: =item * &start_page()
5420:
5421: Returns a complete <html> .. <body> section for LON-CAPA web pages.
5422:
5423: Inputs: $title - optional title for the page
5424: $head_extra - optional extra HTML to incude inside the <head>
1.315 albertel 5425: $args - additional optional args supported are:
1.317 albertel 5426: only_body -> is true will set &bodytag() onlybodytag
5427: arg on
5428: no_nav_bar -> is true will set &bodytag() notopbar arg on
5429: add_entries -> additional attributes to add to the <body>
5430: domain -> force to color decorate a page for a
5431: specific domain
5432: function -> force usage of a specific rolish color
5433: scheme
5434: redirect -> see &headtag()
5435: bgcolor -> override the default page bg color
5436: js_ready -> return a string ready for being used in
5437: a javascript writeln
1.320 albertel 5438: html_encode -> return a string ready for being used in
5439: a html attribute
1.317 albertel 5440: force_register -> if is true will turn on the &bodytag()
5441: $forcereg arg
1.326 albertel 5442: body_title -> alternate text to use instead of $title
5443: in the title box that appears, this text
5444: is not auto translated like the $title is
1.330 albertel 5445: frameset -> if true will start with a <frameset>
5446: rather than <body>
1.338 albertel 5447: no_title -> if true the title bar won't be shown
5448: skip_phases -> hash ref of
5449: head -> skip the <html><head> generation
5450: body -> skip all <body> generation
1.337 albertel 5451:
1.361 albertel 5452: no_inline_link -> if true and in remote mode, don't show the
5453: 'Switch To Inline Menu' link
5454:
1.460 albertel 5455: no_auto_mt_title -> prevent &mt()ing the title arg
5456:
1.562 albertel 5457: inherit_jsmath -> when creating popup window in a page,
5458: should it have jsmath forced on by the
5459: current page
5460:
1.306 albertel 5461: =cut
5462:
5463: sub start_page {
1.309 albertel 5464: my ($title,$head_extra,$args) = @_;
1.318 albertel 5465: #&Apache::lonnet::logthis("start_page ".join(':',caller(0)));
1.313 albertel 5466: my %head_args;
1.352 albertel 5467: foreach my $arg ('redirect','force_register','domain','function',
1.460 albertel 5468: 'bgcolor','frameset','no_nav_bar','only_body',
5469: 'no_auto_mt_title') {
1.319 albertel 5470: if (defined($args->{$arg})) {
1.324 raeburn 5471: $head_args{$arg} = $args->{$arg};
1.319 albertel 5472: }
1.313 albertel 5473: }
1.319 albertel 5474:
1.315 albertel 5475: $env{'internal.start_page'}++;
1.338 albertel 5476: my $result;
5477: if (! exists($args->{'skip_phases'}{'head'}) ) {
5478: $result.=
1.341 albertel 5479: &xml_begin().
1.338 albertel 5480: &headtag($title,$head_extra,\%head_args).&endheadtag();
5481: }
5482:
5483: if (! exists($args->{'skip_phases'}{'body'}) ) {
5484: if ($args->{'frameset'}) {
5485: my $attr_string = &make_attr_string($args->{'force_register'},
5486: $args->{'add_entries'});
5487: $result .= "\n<frameset $attr_string>\n";
5488: } else {
5489: $result .=
5490: &bodytag($title,
5491: $args->{'function'}, $args->{'add_entries'},
5492: $args->{'only_body'}, $args->{'domain'},
5493: $args->{'force_register'}, $args->{'body_title'},
5494: $args->{'no_nav_bar'}, $args->{'bgcolor'},
1.460 albertel 5495: $args->{'no_title'}, $args->{'no_inline_link'},
5496: $args);
1.338 albertel 5497: }
1.330 albertel 5498: }
1.338 albertel 5499:
1.315 albertel 5500: if ($args->{'js_ready'}) {
1.317 albertel 5501: $result = &js_ready($result);
1.315 albertel 5502: }
1.320 albertel 5503: if ($args->{'html_encode'}) {
5504: $result = &html_encode($result);
5505: }
1.315 albertel 5506: return $result;
1.306 albertel 5507: }
5508:
1.330 albertel 5509:
1.306 albertel 5510: =pod
5511:
5512: =item * &head()
5513:
5514: Returns a complete </body></html> section for LON-CAPA web pages.
5515:
1.315 albertel 5516: Inputs: $args - additional optional args supported are:
5517: js_ready -> return a string ready for being used in
5518: a javascript writeln
1.320 albertel 5519: html_encode -> return a string ready for being used in
5520: a html attribute
1.330 albertel 5521: frameset -> if true will start with a <frameset>
5522: rather than <body>
1.493 albertel 5523: dicsussion -> if true will get discussion from
5524: lonxml::xmlend
5525: (you can pass the target and parser arguments
5526: through optional 'target' and 'parser' args
5527: to this routine)
1.306 albertel 5528:
5529: =cut
5530:
5531: sub end_page {
1.315 albertel 5532: my ($args) = @_;
5533: $env{'internal.end_page'}++;
1.330 albertel 5534: my $result;
1.335 albertel 5535: if ($args->{'discussion'}) {
5536: my ($target,$parser);
5537: if (ref($args->{'discussion'})) {
5538: ($target,$parser) =($args->{'discussion'}{'target'},
5539: $args->{'discussion'}{'parser'});
5540: }
5541: $result .= &Apache::lonxml::xmlend($target,$parser);
5542: }
5543:
1.330 albertel 5544: if ($args->{'frameset'}) {
5545: $result .= '</frameset>';
5546: } else {
1.635 raeburn 5547: $result .= &endbodytag($args);
1.330 albertel 5548: }
5549: $result .= "\n</html>";
5550:
1.315 albertel 5551: if ($args->{'js_ready'}) {
1.317 albertel 5552: $result = &js_ready($result);
1.315 albertel 5553: }
1.335 albertel 5554:
1.320 albertel 5555: if ($args->{'html_encode'}) {
5556: $result = &html_encode($result);
5557: }
1.335 albertel 5558:
1.315 albertel 5559: return $result;
5560: }
5561:
1.320 albertel 5562: sub html_encode {
5563: my ($result) = @_;
5564:
1.322 albertel 5565: $result = &HTML::Entities::encode($result,'<>&"');
1.320 albertel 5566:
5567: return $result;
5568: }
1.317 albertel 5569: sub js_ready {
5570: my ($result) = @_;
5571:
1.323 albertel 5572: $result =~ s/[\n\r]/ /xmsg;
5573: $result =~ s/\\/\\\\/xmsg;
5574: $result =~ s/'/\\'/xmsg;
1.372 albertel 5575: $result =~ s{</}{<\\/}xmsg;
1.317 albertel 5576:
5577: return $result;
5578: }
5579:
1.315 albertel 5580: sub validate_page {
5581: if ( exists($env{'internal.start_page'})
1.316 albertel 5582: && $env{'internal.start_page'} > 1) {
5583: &Apache::lonnet::logthis('start_page called multiple times '.
1.318 albertel 5584: $env{'internal.start_page'}.' '.
1.316 albertel 5585: $ENV{'request.filename'});
1.315 albertel 5586: }
5587: if ( exists($env{'internal.end_page'})
1.316 albertel 5588: && $env{'internal.end_page'} > 1) {
5589: &Apache::lonnet::logthis('end_page called multiple times '.
1.318 albertel 5590: $env{'internal.end_page'}.' '.
1.316 albertel 5591: $env{'request.filename'});
1.315 albertel 5592: }
5593: if ( exists($env{'internal.start_page'})
5594: && ! exists($env{'internal.end_page'})) {
1.316 albertel 5595: &Apache::lonnet::logthis('start_page called without end_page '.
5596: $env{'request.filename'});
1.315 albertel 5597: }
5598: if ( ! exists($env{'internal.start_page'})
5599: && exists($env{'internal.end_page'})) {
1.316 albertel 5600: &Apache::lonnet::logthis('end_page called without start_page'.
5601: $env{'request.filename'});
1.315 albertel 5602: }
1.306 albertel 5603: }
1.315 albertel 5604:
1.318 albertel 5605: sub simple_error_page {
5606: my ($r,$title,$msg) = @_;
5607: my $page =
5608: &Apache::loncommon::start_page($title).
5609: &mt($msg).
5610: &Apache::loncommon::end_page();
5611: if (ref($r)) {
5612: $r->print($page);
1.327 albertel 5613: return;
1.318 albertel 5614: }
5615: return $page;
5616: }
1.347 albertel 5617:
5618: {
1.610 albertel 5619: my @row_count;
1.347 albertel 5620: sub start_data_table {
1.422 albertel 5621: my ($add_class) = @_;
5622: my $css_class = (join(' ','LC_data_table',$add_class));
1.610 albertel 5623: unshift(@row_count,0);
1.422 albertel 5624: return '<table class="'.$css_class.'">'."\n";
1.347 albertel 5625: }
5626:
5627: sub end_data_table {
1.610 albertel 5628: shift(@row_count);
1.389 albertel 5629: return '</table>'."\n";;
1.347 albertel 5630: }
5631:
5632: sub start_data_table_row {
1.422 albertel 5633: my ($add_class) = @_;
1.610 albertel 5634: $row_count[0]++;
5635: my $css_class = ($row_count[0] % 2)?'LC_odd_row':'LC_even_row';
1.428 albertel 5636: $css_class = (join(' ',$css_class,$add_class));
1.422 albertel 5637: return '<tr class="'.$css_class.'">'."\n";;
1.347 albertel 5638: }
1.471 banghart 5639:
5640: sub continue_data_table_row {
5641: my ($add_class) = @_;
1.610 albertel 5642: my $css_class = ($row_count[0] % 2)?'LC_odd_row':'LC_even_row';
1.471 banghart 5643: $css_class = (join(' ',$css_class,$add_class));
5644: return '<tr class="'.$css_class.'">'."\n";;
5645: }
1.347 albertel 5646:
5647: sub end_data_table_row {
1.389 albertel 5648: return '</tr>'."\n";;
1.347 albertel 5649: }
1.367 www 5650:
1.421 albertel 5651: sub start_data_table_empty_row {
1.610 albertel 5652: $row_count[0]++;
1.421 albertel 5653: return '<tr class="LC_empty_row" >'."\n";;
5654: }
5655:
5656: sub end_data_table_empty_row {
5657: return '</tr>'."\n";;
5658: }
5659:
1.367 www 5660: sub start_data_table_header_row {
1.389 albertel 5661: return '<tr class="LC_header_row">'."\n";;
1.367 www 5662: }
5663:
5664: sub end_data_table_header_row {
1.389 albertel 5665: return '</tr>'."\n";;
1.367 www 5666: }
1.347 albertel 5667: }
5668:
1.548 albertel 5669: =pod
5670:
5671: =item * &inhibit_menu_check($arg)
5672:
5673: Checks for a inhibitmenu state and generates output to preserve it
5674:
5675: Inputs: $arg - can be any of
5676: - undef - in which case the return value is a string
5677: to add into arguments list of a uri
5678: - 'input' - in which case the return value is a HTML
5679: <form> <input> field of type hidden to
5680: preserve the value
5681: - a url - in which case the return value is the url with
5682: the neccesary cgi args added to preserve the
5683: inhibitmenu state
5684: - a ref to a url - no return value, but the string is
5685: updated to include the neccessary cgi
5686: args to preserve the inhibitmenu state
5687:
5688: =cut
5689:
5690: sub inhibit_menu_check {
5691: my ($arg) = @_;
5692: &get_unprocessed_cgi($ENV{'QUERY_STRING'}, ['inhibitmenu']);
5693: if ($arg eq 'input') {
5694: if ($env{'form.inhibitmenu'}) {
5695: return '<input type="hidden" name="inhibitmenu" value="'.$env{'form.inhibitmenu'}.'" />';
5696: } else {
5697: return
5698: }
5699: }
5700: if ($env{'form.inhibitmenu'}) {
5701: if (ref($arg)) {
5702: $$arg .= '?inhibitmenu='.$env{'form.inhibitmenu'};
5703: } elsif ($arg eq '') {
5704: $arg .= 'inhibitmenu='.$env{'form.inhibitmenu'};
5705: } else {
5706: $arg .= '?inhibitmenu='.$env{'form.inhibitmenu'};
5707: }
5708: }
5709: if (!ref($arg)) {
5710: return $arg;
5711: }
5712: }
5713:
1.251 albertel 5714: ###############################################
1.182 matthew 5715:
5716: =pod
5717:
1.549 albertel 5718: =back
5719:
5720: =head1 User Information Routines
5721:
5722: =over 4
5723:
1.405 albertel 5724: =item * &get_users_function()
1.182 matthew 5725:
5726: Used by &bodytag to determine the current users primary role.
5727: Returns either 'student','coordinator','admin', or 'author'.
5728:
5729: =cut
5730:
5731: ###############################################
5732: sub get_users_function {
5733: my $function = 'student';
1.258 albertel 5734: if ($env{'request.role'}=~/^(cc|in|ta|ep)/) {
1.182 matthew 5735: $function='coordinator';
5736: }
1.258 albertel 5737: if ($env{'request.role'}=~/^(su|dc|ad|li)/) {
1.182 matthew 5738: $function='admin';
5739: }
1.258 albertel 5740: if (($env{'request.role'}=~/^(au|ca)/) ||
1.182 matthew 5741: ($ENV{'REQUEST_URI'}=~/^(\/priv|\~)/)) {
5742: $function='author';
5743: }
5744: return $function;
1.54 www 5745: }
1.99 www 5746:
5747: ###############################################
5748:
1.233 raeburn 5749: =pod
5750:
1.542 raeburn 5751: =item * &check_user_status()
1.274 raeburn 5752:
5753: Determines current status of supplied role for a
5754: specific user. Roles can be active, previous or future.
5755:
5756: Inputs:
5757: user's domain, user's username, course's domain,
1.375 raeburn 5758: course's number, optional section ID.
1.274 raeburn 5759:
5760: Outputs:
5761: role status: active, previous or future.
5762:
5763: =cut
5764:
5765: sub check_user_status {
1.412 raeburn 5766: my ($udom,$uname,$cdom,$crs,$role,$sec) = @_;
1.274 raeburn 5767: my %userinfo = &Apache::lonnet::dump('roles',$udom,$uname);
5768: my @uroles = keys %userinfo;
5769: my $srchstr;
5770: my $active_chk = 'none';
1.412 raeburn 5771: my $now = time;
1.274 raeburn 5772: if (@uroles > 0) {
1.412 raeburn 5773: if (($role eq 'cc') || ($sec eq '') || (!defined($sec))) {
1.274 raeburn 5774: $srchstr = '/'.$cdom.'/'.$crs.'_'.$role;
5775: } else {
1.412 raeburn 5776: $srchstr = '/'.$cdom.'/'.$crs.'/'.$sec.'_'.$role;
5777: }
5778: if (grep/^\Q$srchstr\E$/,@uroles) {
1.274 raeburn 5779: my $role_end = 0;
5780: my $role_start = 0;
5781: $active_chk = 'active';
1.412 raeburn 5782: if ($userinfo{$srchstr} =~ m/^\Q$role\E_(\d+)/) {
5783: $role_end = $1;
5784: if ($userinfo{$srchstr} =~ m/^\Q$role\E_\Q$role_end\E_(\d+)$/) {
5785: $role_start = $1;
1.274 raeburn 5786: }
5787: }
5788: if ($role_start > 0) {
1.412 raeburn 5789: if ($now < $role_start) {
1.274 raeburn 5790: $active_chk = 'future';
5791: }
5792: }
5793: if ($role_end > 0) {
1.412 raeburn 5794: if ($now > $role_end) {
1.274 raeburn 5795: $active_chk = 'previous';
5796: }
5797: }
5798: }
5799: }
5800: return $active_chk;
5801: }
5802:
5803: ###############################################
5804:
5805: =pod
5806:
1.405 albertel 5807: =item * &get_sections()
1.233 raeburn 5808:
5809: Determines all the sections for a course including
5810: sections with students and sections containing other roles.
1.419 raeburn 5811: Incoming parameters:
5812:
5813: 1. domain
5814: 2. course number
5815: 3. reference to array containing roles for which sections should
5816: be gathered (optional).
5817: 4. reference to array containing status types for which sections
5818: should be gathered (optional).
5819:
5820: If the third argument is undefined, sections are gathered for any role.
5821: If the fourth argument is undefined, sections are gathered for any status.
5822: Permissible values are 'active' or 'future' or 'previous'.
1.233 raeburn 5823:
1.374 raeburn 5824: Returns section hash (keys are section IDs, values are
5825: number of users in each section), subject to the
1.419 raeburn 5826: optional roles filter, optional status filter
1.233 raeburn 5827:
5828: =cut
5829:
5830: ###############################################
5831: sub get_sections {
1.419 raeburn 5832: my ($cdom,$cnum,$possible_roles,$possible_status) = @_;
1.366 albertel 5833: if (!defined($cdom) || !defined($cnum)) {
5834: my $cid = $env{'request.course.id'};
5835:
5836: return if (!defined($cid));
5837:
5838: $cdom = $env{'course.'.$cid.'.domain'};
5839: $cnum = $env{'course.'.$cid.'.num'};
5840: }
5841:
5842: my %sectioncount;
1.419 raeburn 5843: my $now = time;
1.240 albertel 5844:
1.366 albertel 5845: if (!defined($possible_roles) || (grep(/^st$/,@$possible_roles))) {
1.276 albertel 5846: my ($classlist) = &Apache::loncoursedata::get_classlist($cdom,$cnum);
1.240 albertel 5847: my $sec_index = &Apache::loncoursedata::CL_SECTION();
5848: my $status_index = &Apache::loncoursedata::CL_STATUS();
1.419 raeburn 5849: my $start_index = &Apache::loncoursedata::CL_START();
5850: my $end_index = &Apache::loncoursedata::CL_END();
5851: my $status;
1.366 albertel 5852: while (my ($student,$data) = each(%$classlist)) {
1.419 raeburn 5853: my ($section,$stu_status,$start,$end) = ($data->[$sec_index],
5854: $data->[$status_index],
5855: $data->[$start_index],
5856: $data->[$end_index]);
5857: if ($stu_status eq 'Active') {
5858: $status = 'active';
5859: } elsif ($end < $now) {
5860: $status = 'previous';
5861: } elsif ($start > $now) {
5862: $status = 'future';
5863: }
5864: if ($section ne '-1' && $section !~ /^\s*$/) {
5865: if ((!defined($possible_status)) || (($status ne '') &&
5866: (grep/^\Q$status\E$/,@{$possible_status}))) {
5867: $sectioncount{$section}++;
5868: }
1.240 albertel 5869: }
5870: }
5871: }
5872: my %courseroles = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum);
5873: foreach my $user (sort(keys(%courseroles))) {
5874: if ($user !~ /^(\w{2})/) { next; }
5875: my ($role) = ($user =~ /^(\w{2})/);
5876: if ($possible_roles && !(grep(/^$role$/,@$possible_roles))) { next; }
1.419 raeburn 5877: my ($section,$status);
1.240 albertel 5878: if ($role eq 'cr' &&
5879: $user =~ m-^$role/[^/]*/[^/]*/[^/]*:[^:]*:[^:]*:(\w+)-) {
5880: $section=$1;
5881: }
5882: if ($user =~ /^$role:[^:]*:[^:]*:(\w+)/) { $section=$1; }
5883: if (!defined($section) || $section eq '-1') { next; }
1.419 raeburn 5884: my ($end,$start) = ($courseroles{$user} =~ /^([^:]*):([^:]*)$/);
5885: if ($end == -1 && $start == -1) {
5886: next; #deleted role
5887: }
5888: if (!defined($possible_status)) {
5889: $sectioncount{$section}++;
5890: } else {
5891: if ((!$end || $end >= $now) && (!$start || $start <= $now)) {
5892: $status = 'active';
5893: } elsif ($end < $now) {
5894: $status = 'future';
5895: } elsif ($start > $now) {
5896: $status = 'previous';
5897: }
5898: if (($status ne '') && (grep/^\Q$status\E$/,@{$possible_status})) {
5899: $sectioncount{$section}++;
5900: }
5901: }
1.233 raeburn 5902: }
1.366 albertel 5903: return %sectioncount;
1.233 raeburn 5904: }
5905:
1.274 raeburn 5906: ###############################################
1.294 raeburn 5907:
5908: =pod
1.405 albertel 5909:
5910: =item * &get_course_users()
5911:
1.275 raeburn 5912: Retrieves usernames:domains for users in the specified course
5913: with specific role(s), and access status.
5914:
5915: Incoming parameters:
1.277 albertel 5916: 1. course domain
5917: 2. course number
5918: 3. access status: users must have - either active,
1.275 raeburn 5919: previous, future, or all.
1.277 albertel 5920: 4. reference to array of permissible roles
1.288 raeburn 5921: 5. reference to array of section restrictions (optional)
5922: 6. reference to results object (hash of hashes).
5923: 7. reference to optional userdata hash
1.609 raeburn 5924: 8. reference to optional statushash
1.630 raeburn 5925: 9. flag if privileged users (except those set to unhide in
5926: course settings) should be excluded
1.609 raeburn 5927: Keys of top level results hash are roles.
1.275 raeburn 5928: Keys of inner hashes are username:domain, with
5929: values set to access type.
1.288 raeburn 5930: Optional userdata hash returns an array with arguments in the
5931: same order as loncoursedata::get_classlist() for student data.
5932:
1.609 raeburn 5933: Optional statushash returns
5934:
1.288 raeburn 5935: Entries for end, start, section and status are blank because
5936: of the possibility of multiple values for non-student roles.
5937:
1.275 raeburn 5938: =cut
1.405 albertel 5939:
1.275 raeburn 5940: ###############################################
1.405 albertel 5941:
1.275 raeburn 5942: sub get_course_users {
1.630 raeburn 5943: my ($cdom,$cnum,$types,$roles,$sections,$users,$userdata,$statushash,$hidepriv) = @_;
1.288 raeburn 5944: my %idx = ();
1.419 raeburn 5945: my %seclists;
1.288 raeburn 5946:
5947: $idx{udom} = &Apache::loncoursedata::CL_SDOM();
5948: $idx{uname} = &Apache::loncoursedata::CL_SNAME();
5949: $idx{end} = &Apache::loncoursedata::CL_END();
5950: $idx{start} = &Apache::loncoursedata::CL_START();
5951: $idx{id} = &Apache::loncoursedata::CL_ID();
5952: $idx{section} = &Apache::loncoursedata::CL_SECTION();
5953: $idx{fullname} = &Apache::loncoursedata::CL_FULLNAME();
5954: $idx{status} = &Apache::loncoursedata::CL_STATUS();
5955:
1.290 albertel 5956: if (grep(/^st$/,@{$roles})) {
1.276 albertel 5957: my ($classlist,$keylist)=&Apache::loncoursedata::get_classlist($cdom,$cnum);
1.278 raeburn 5958: my $now = time;
1.277 albertel 5959: foreach my $student (keys(%{$classlist})) {
1.288 raeburn 5960: my $match = 0;
1.412 raeburn 5961: my $secmatch = 0;
1.419 raeburn 5962: my $section = $$classlist{$student}[$idx{section}];
1.609 raeburn 5963: my $status = $$classlist{$student}[$idx{status}];
1.419 raeburn 5964: if ($section eq '') {
5965: $section = 'none';
5966: }
1.291 albertel 5967: if ((ref($sections) eq 'ARRAY') && (@{$sections} > 0)) {
1.420 albertel 5968: if (grep(/^all$/,@{$sections})) {
1.412 raeburn 5969: $secmatch = 1;
5970: } elsif ($$classlist{$student}[$idx{section}] eq '') {
1.420 albertel 5971: if (grep(/^none$/,@{$sections})) {
1.412 raeburn 5972: $secmatch = 1;
5973: }
5974: } else {
1.419 raeburn 5975: if (grep(/^\Q$section\E$/,@{$sections})) {
1.412 raeburn 5976: $secmatch = 1;
5977: }
1.290 albertel 5978: }
1.412 raeburn 5979: if (!$secmatch) {
5980: next;
5981: }
1.419 raeburn 5982: }
1.275 raeburn 5983: if (defined($$types{'active'})) {
1.288 raeburn 5984: if ($$classlist{$student}[$idx{status}] eq 'Active') {
1.275 raeburn 5985: push(@{$$users{st}{$student}},'active');
1.288 raeburn 5986: $match = 1;
1.275 raeburn 5987: }
5988: }
5989: if (defined($$types{'previous'})) {
1.609 raeburn 5990: if ($$classlist{$student}[$idx{status}] eq 'Expired') {
1.275 raeburn 5991: push(@{$$users{st}{$student}},'previous');
1.288 raeburn 5992: $match = 1;
1.275 raeburn 5993: }
5994: }
5995: if (defined($$types{'future'})) {
1.609 raeburn 5996: if ($$classlist{$student}[$idx{status}] eq 'Future') {
1.275 raeburn 5997: push(@{$$users{st}{$student}},'future');
1.288 raeburn 5998: $match = 1;
1.275 raeburn 5999: }
6000: }
1.609 raeburn 6001: if ($match) {
6002: push(@{$seclists{$student}},$section);
6003: if (ref($userdata) eq 'HASH') {
6004: $$userdata{$student} = $$classlist{$student};
6005: }
6006: if (ref($statushash) eq 'HASH') {
6007: $statushash->{$student}{'st'}{$section} = $status;
6008: }
1.288 raeburn 6009: }
1.275 raeburn 6010: }
6011: }
1.412 raeburn 6012: if ((@{$roles} > 1) || ((@{$roles} == 1) && ($$roles[0] ne "st"))) {
1.439 raeburn 6013: my %coursepersonnel = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum);
6014: my $now = time;
1.609 raeburn 6015: my %displaystatus = ( previous => 'Expired',
6016: active => 'Active',
6017: future => 'Future',
6018: );
1.630 raeburn 6019: my %nothide;
6020: if ($hidepriv) {
6021: my %coursehash=&Apache::lonnet::coursedescription($cdom.'_'.$cnum);
6022: foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
6023: if ($user !~ /:/) {
6024: $nothide{join(':',split(/[\@]/,$user))}=1;
6025: } else {
6026: $nothide{$user} = 1;
6027: }
6028: }
6029: }
1.439 raeburn 6030: foreach my $person (sort(keys(%coursepersonnel))) {
1.288 raeburn 6031: my $match = 0;
1.412 raeburn 6032: my $secmatch = 0;
1.439 raeburn 6033: my $status;
1.412 raeburn 6034: my ($role,$user,$usec) = ($person =~ /^([^:]*):([^:]+:[^:]+):([^:]*)/);
1.275 raeburn 6035: $user =~ s/:$//;
1.439 raeburn 6036: my ($end,$start) = split(/:/,$coursepersonnel{$person});
6037: if ($end == -1 || $start == -1) {
6038: next;
6039: }
6040: if (($role) && ((grep(/^\Q$role\E$/,@{$roles})) ||
6041: (grep(/^cr$/,@{$roles}) && $role =~ /^cr\//))) {
1.412 raeburn 6042: my ($uname,$udom) = split(/:/,$user);
6043: if ((ref($sections) eq 'ARRAY') && (@{$sections} > 0)) {
1.420 albertel 6044: if (grep(/^all$/,@{$sections})) {
1.412 raeburn 6045: $secmatch = 1;
6046: } elsif ($usec eq '') {
1.420 albertel 6047: if (grep(/^none$/,@{$sections})) {
1.412 raeburn 6048: $secmatch = 1;
6049: }
6050: } else {
6051: if (grep(/^\Q$usec\E$/,@{$sections})) {
6052: $secmatch = 1;
6053: }
6054: }
6055: if (!$secmatch) {
6056: next;
6057: }
1.288 raeburn 6058: }
1.419 raeburn 6059: if ($usec eq '') {
6060: $usec = 'none';
6061: }
1.275 raeburn 6062: if ($uname ne '' && $udom ne '') {
1.630 raeburn 6063: if ($hidepriv) {
6064: if ((&Apache::lonnet::privileged($uname,$udom)) &&
6065: (!$nothide{$uname.':'.$udom})) {
6066: next;
6067: }
6068: }
1.503 raeburn 6069: if ($end > 0 && $end < $now) {
1.439 raeburn 6070: $status = 'previous';
6071: } elsif ($start > $now) {
6072: $status = 'future';
6073: } else {
6074: $status = 'active';
6075: }
1.277 albertel 6076: foreach my $type (keys(%{$types})) {
1.275 raeburn 6077: if ($status eq $type) {
1.420 albertel 6078: if (!grep(/^\Q$type\E$/,@{$$users{$role}{$user}})) {
1.419 raeburn 6079: push(@{$$users{$role}{$user}},$type);
6080: }
1.288 raeburn 6081: $match = 1;
6082: }
6083: }
1.419 raeburn 6084: if (($match) && (ref($userdata) eq 'HASH')) {
6085: if (!exists($$userdata{$uname.':'.$udom})) {
6086: &get_user_info($udom,$uname,\%idx,$userdata);
6087: }
1.420 albertel 6088: if (!grep(/^\Q$usec\E$/,@{$seclists{$uname.':'.$udom}})) {
1.419 raeburn 6089: push(@{$seclists{$uname.':'.$udom}},$usec);
6090: }
1.609 raeburn 6091: if (ref($statushash) eq 'HASH') {
6092: $statushash->{$uname.':'.$udom}{$role}{$usec} = $displaystatus{$status};
6093: }
1.275 raeburn 6094: }
6095: }
6096: }
6097: }
1.290 albertel 6098: if (grep(/^ow$/,@{$roles})) {
1.279 raeburn 6099: if ((defined($cdom)) && (defined($cnum))) {
6100: my %csettings = &Apache::lonnet::get('environment',['internal.courseowner'],$cdom,$cnum);
6101: if ( defined($csettings{'internal.courseowner'}) ) {
6102: my $owner = $csettings{'internal.courseowner'};
1.609 raeburn 6103: next if ($owner eq '');
6104: my ($ownername,$ownerdom);
6105: if ($owner =~ /^([^:]+):([^:]+)$/) {
6106: $ownername = $1;
6107: $ownerdom = $2;
6108: } else {
6109: $ownername = $owner;
6110: $ownerdom = $cdom;
6111: $owner = $ownername.':'.$ownerdom;
1.439 raeburn 6112: }
6113: @{$$users{'ow'}{$owner}} = 'any';
1.290 albertel 6114: if (defined($userdata) &&
1.609 raeburn 6115: !exists($$userdata{$owner})) {
6116: &get_user_info($ownerdom,$ownername,\%idx,$userdata);
6117: if (!grep(/^none$/,@{$seclists{$owner}})) {
6118: push(@{$seclists{$owner}},'none');
6119: }
6120: if (ref($statushash) eq 'HASH') {
6121: $statushash->{$owner}{'ow'}{'none'} = 'Any';
1.419 raeburn 6122: }
1.290 albertel 6123: }
1.279 raeburn 6124: }
6125: }
6126: }
1.419 raeburn 6127: foreach my $user (keys(%seclists)) {
6128: @{$seclists{$user}} = (sort {$a <=> $b} @{$seclists{$user}});
6129: $$userdata{$user}[$idx{section}] = join(',',@{$seclists{$user}});
6130: }
1.275 raeburn 6131: }
6132: return;
6133: }
6134:
1.288 raeburn 6135: sub get_user_info {
6136: my ($udom,$uname,$idx,$userdata) = @_;
1.289 albertel 6137: $$userdata{$uname.':'.$udom}[$$idx{fullname}] =
6138: &plainname($uname,$udom,'lastname');
1.291 albertel 6139: $$userdata{$uname.':'.$udom}[$$idx{uname}] = $uname;
1.297 raeburn 6140: $$userdata{$uname.':'.$udom}[$$idx{udom}] = $udom;
1.609 raeburn 6141: my %idhash = &Apache::lonnet::idrget($udom,($uname));
6142: $$userdata{$uname.':'.$udom}[$$idx{id}] = $idhash{$uname};
1.288 raeburn 6143: return;
6144: }
1.275 raeburn 6145:
1.472 raeburn 6146: ###############################################
6147:
6148: =pod
6149:
6150: =item * &get_user_quota()
6151:
6152: Retrieves quota assigned for storage of portfolio files for a user
6153:
6154: Incoming parameters:
6155: 1. user's username
6156: 2. user's domain
6157:
6158: Returns:
1.536 raeburn 6159: 1. Disk quota (in Mb) assigned to student.
6160: 2. (Optional) Type of setting: custom or default
6161: (individually assigned or default for user's
6162: institutional status).
6163: 3. (Optional) - User's institutional status (e.g., faculty, staff
6164: or student - types as defined in localenroll::inst_usertypes
6165: for user's domain, which determines default quota for user.
6166: 4. (Optional) - Default quota which would apply to the user.
1.472 raeburn 6167:
6168: If a value has been stored in the user's environment,
1.536 raeburn 6169: it will return that, otherwise it returns the maximal default
6170: defined for the user's instituional status(es) in the domain.
1.472 raeburn 6171:
6172: =cut
6173:
6174: ###############################################
6175:
6176:
6177: sub get_user_quota {
6178: my ($uname,$udom) = @_;
1.536 raeburn 6179: my ($quota,$quotatype,$settingstatus,$defquota);
1.472 raeburn 6180: if (!defined($udom)) {
6181: $udom = $env{'user.domain'};
6182: }
6183: if (!defined($uname)) {
6184: $uname = $env{'user.name'};
6185: }
6186: if (($udom eq '' || $uname eq '') ||
6187: ($udom eq 'public') && ($uname eq 'public')) {
6188: $quota = 0;
1.536 raeburn 6189: $quotatype = 'default';
6190: $defquota = 0;
1.472 raeburn 6191: } else {
1.536 raeburn 6192: my $inststatus;
1.472 raeburn 6193: if ($udom eq $env{'user.domain'} && $uname eq $env{'user.name'}) {
6194: $quota = $env{'environment.portfolioquota'};
1.536 raeburn 6195: $inststatus = $env{'environment.inststatus'};
1.472 raeburn 6196: } else {
1.536 raeburn 6197: my %userenv =
6198: &Apache::lonnet::get('environment',['portfolioquota',
6199: 'inststatus'],$udom,$uname);
1.472 raeburn 6200: my ($tmp) = keys(%userenv);
6201: if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
6202: $quota = $userenv{'portfolioquota'};
1.536 raeburn 6203: $inststatus = $userenv{'inststatus'};
1.472 raeburn 6204: } else {
6205: undef(%userenv);
6206: }
6207: }
1.536 raeburn 6208: ($defquota,$settingstatus) = &default_quota($udom,$inststatus);
1.472 raeburn 6209: if ($quota eq '') {
1.536 raeburn 6210: $quota = $defquota;
6211: $quotatype = 'default';
6212: } else {
6213: $quotatype = 'custom';
1.472 raeburn 6214: }
6215: }
1.536 raeburn 6216: if (wantarray) {
6217: return ($quota,$quotatype,$settingstatus,$defquota);
6218: } else {
6219: return $quota;
6220: }
1.472 raeburn 6221: }
6222:
6223: ###############################################
6224:
6225: =pod
6226:
6227: =item * &default_quota()
6228:
1.536 raeburn 6229: Retrieves default quota assigned for storage of user portfolio files,
6230: given an (optional) user's institutional status.
1.472 raeburn 6231:
6232: Incoming parameters:
6233: 1. domain
1.536 raeburn 6234: 2. (Optional) institutional status(es). This is a : separated list of
6235: status types (e.g., faculty, staff, student etc.)
6236: which apply to the user for whom the default is being retrieved.
6237: If the institutional status string in undefined, the domain
6238: default quota will be returned.
1.472 raeburn 6239:
6240: Returns:
6241: 1. Default disk quota (in Mb) for user portfolios in the domain.
1.536 raeburn 6242: 2. (Optional) institutional type which determined the value of the
6243: default quota.
1.472 raeburn 6244:
6245: If a value has been stored in the domain's configuration db,
6246: it will return that, otherwise it returns 20 (for backwards
6247: compatibility with domains which have not set up a configuration
6248: db file; the original statically defined portfolio quota was 20 Mb).
6249:
1.536 raeburn 6250: If the user's status includes multiple types (e.g., staff and student),
6251: the largest default quota which applies to the user determines the
6252: default quota returned.
6253:
1.472 raeburn 6254: =cut
6255:
6256: ###############################################
6257:
6258:
6259: sub default_quota {
1.536 raeburn 6260: my ($udom,$inststatus) = @_;
6261: my ($defquota,$settingstatus);
6262: my %quotahash = &Apache::lonnet::get_dom('configuration',
1.622 raeburn 6263: ['quotas'],$udom);
6264: if (ref($quotahash{'quotas'}) eq 'HASH') {
1.536 raeburn 6265: if ($inststatus ne '') {
6266: my @statuses = split(/:/,$inststatus);
6267: foreach my $item (@statuses) {
1.622 raeburn 6268: if ($quotahash{'quotas'}{$item} ne '') {
1.536 raeburn 6269: if ($defquota eq '') {
1.622 raeburn 6270: $defquota = $quotahash{'quotas'}{$item};
1.536 raeburn 6271: $settingstatus = $item;
1.622 raeburn 6272: } elsif ($quotahash{'quotas'}{$item} > $defquota) {
6273: $defquota = $quotahash{'quotas'}{$item};
1.536 raeburn 6274: $settingstatus = $item;
6275: }
6276: }
6277: }
6278: }
6279: if ($defquota eq '') {
1.622 raeburn 6280: $defquota = $quotahash{'quotas'}{'default'};
1.536 raeburn 6281: $settingstatus = 'default';
6282: }
6283: } else {
6284: $settingstatus = 'default';
6285: $defquota = 20;
6286: }
6287: if (wantarray) {
6288: return ($defquota,$settingstatus);
1.472 raeburn 6289: } else {
1.536 raeburn 6290: return $defquota;
1.472 raeburn 6291: }
6292: }
6293:
1.384 raeburn 6294: sub get_secgrprole_info {
6295: my ($cdom,$cnum,$needroles,$type) = @_;
6296: my %sections_count = &get_sections($cdom,$cnum);
6297: my @sections = (sort {$a <=> $b} keys(%sections_count));
6298: my %curr_groups = &Apache::longroup::coursegroups($cdom,$cnum);
6299: my @groups = sort(keys(%curr_groups));
6300: my $allroles = [];
6301: my $rolehash;
6302: my $accesshash = {
6303: active => 'Currently has access',
6304: future => 'Will have future access',
6305: previous => 'Previously had access',
6306: };
6307: if ($needroles) {
6308: $rolehash = {'all' => 'all'};
1.385 albertel 6309: my %user_roles = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum);
6310: if (&Apache::lonnet::error(%user_roles)) {
6311: undef(%user_roles);
6312: }
6313: foreach my $item (keys(%user_roles)) {
1.384 raeburn 6314: my ($role)=split(/\:/,$item,2);
6315: if ($role eq 'cr') { next; }
6316: if ($role =~ /^cr/) {
6317: $$rolehash{$role} = (split('/',$role))[3];
6318: } else {
6319: $$rolehash{$role} = &Apache::lonnet::plaintext($role,$type);
6320: }
6321: }
6322: foreach my $key (sort(keys(%{$rolehash}))) {
6323: push(@{$allroles},$key);
6324: }
6325: push (@{$allroles},'st');
6326: $$rolehash{'st'} = &Apache::lonnet::plaintext('st',$type);
6327: }
6328: return (\@sections,\@groups,$allroles,$rolehash,$accesshash);
6329: }
6330:
1.555 raeburn 6331: sub user_picker {
1.627 raeburn 6332: my ($dom,$srch,$forcenewuser,$caller,$cancreate,$usertype) = @_;
1.555 raeburn 6333: my $currdom = $dom;
6334: my %curr_selected = (
6335: srchin => 'dom',
1.580 raeburn 6336: srchby => 'lastname',
1.555 raeburn 6337: );
6338: my $srchterm;
1.625 raeburn 6339: if ((ref($srch) eq 'HASH') && ($env{'form.origform'} ne 'crtusername')) {
1.555 raeburn 6340: if ($srch->{'srchby'} ne '') {
6341: $curr_selected{'srchby'} = $srch->{'srchby'};
6342: }
6343: if ($srch->{'srchin'} ne '') {
6344: $curr_selected{'srchin'} = $srch->{'srchin'};
6345: }
6346: if ($srch->{'srchtype'} ne '') {
6347: $curr_selected{'srchtype'} = $srch->{'srchtype'};
6348: }
6349: if ($srch->{'srchdomain'} ne '') {
6350: $currdom = $srch->{'srchdomain'};
6351: }
6352: $srchterm = $srch->{'srchterm'};
6353: }
6354: my %lt=&Apache::lonlocal::texthash(
1.573 raeburn 6355: 'usr' => 'Search criteria',
1.563 raeburn 6356: 'doma' => 'Domain/institution to search',
1.558 albertel 6357: 'uname' => 'username',
6358: 'lastname' => 'last name',
1.555 raeburn 6359: 'lastfirst' => 'last name, first name',
1.558 albertel 6360: 'crs' => 'in this course',
1.576 raeburn 6361: 'dom' => 'in selected LON-CAPA domain',
1.558 albertel 6362: 'alc' => 'all LON-CAPA',
1.573 raeburn 6363: 'instd' => 'in institutional directory for selected domain',
1.558 albertel 6364: 'exact' => 'is',
6365: 'contains' => 'contains',
1.569 raeburn 6366: 'begins' => 'begins with',
1.571 raeburn 6367: 'youm' => "You must include some text to search for.",
6368: 'thte' => "The text you are searching for must contain at least two characters when using a 'begins' type search.",
6369: 'thet' => "The text you are searching for must contain at least three characters when using a 'contains' type search.",
6370: 'yomc' => "You must choose a domain when using an institutional directory search.",
6371: 'ymcd' => "You must choose a domain when using a domain search.",
6372: 'whus' => "When using searching by last,first you must include a comma as separator between last name and first name.",
6373: 'whse' => "When searching by last,first you must include at least one character in the first name.",
6374: 'thfo' => "The following need to be corrected before the search can be run:",
1.555 raeburn 6375: );
1.563 raeburn 6376: my $domform = &select_dom_form($currdom,'srchdomain',1,1);
6377: my $srchinsel = ' <select name="srchin">';
1.555 raeburn 6378:
6379: my @srchins = ('crs','dom','alc','instd');
6380:
6381: foreach my $option (@srchins) {
6382: # FIXME 'alc' option unavailable until
6383: # loncreateuser::print_user_query_page()
6384: # has been completed.
6385: next if ($option eq 'alc');
6386: next if ($option eq 'crs' && !$env{'request.course.id'});
1.563 raeburn 6387: if ($curr_selected{'srchin'} eq $option) {
6388: $srchinsel .= '
6389: <option value="'.$option.'" selected="selected">'.$lt{$option}.'</option>';
6390: } else {
6391: $srchinsel .= '
6392: <option value="'.$option.'">'.$lt{$option}.'</option>';
6393: }
1.555 raeburn 6394: }
1.563 raeburn 6395: $srchinsel .= "\n </select>\n";
1.555 raeburn 6396:
6397: my $srchbysel = ' <select name="srchby">';
1.580 raeburn 6398: foreach my $option ('lastname','lastfirst','uname') {
1.555 raeburn 6399: if ($curr_selected{'srchby'} eq $option) {
6400: $srchbysel .= '
6401: <option value="'.$option.'" selected="selected">'.$lt{$option}.'</option>';
6402: } else {
6403: $srchbysel .= '
6404: <option value="'.$option.'">'.$lt{$option}.'</option>';
6405: }
6406: }
6407: $srchbysel .= "\n </select>\n";
6408:
6409: my $srchtypesel = ' <select name="srchtype">';
1.580 raeburn 6410: foreach my $option ('begins','contains','exact') {
1.555 raeburn 6411: if ($curr_selected{'srchtype'} eq $option) {
6412: $srchtypesel .= '
6413: <option value="'.$option.'" selected="selected">'.$lt{$option}.'</option>';
6414: } else {
6415: $srchtypesel .= '
6416: <option value="'.$option.'">'.$lt{$option}.'</option>';
6417: }
6418: }
6419: $srchtypesel .= "\n </select>\n";
6420:
1.558 albertel 6421: my ($newuserscript,$new_user_create);
1.556 raeburn 6422:
6423: if ($forcenewuser) {
1.576 raeburn 6424: if (ref($srch) eq 'HASH') {
6425: if ($srch->{'srchby'} eq 'uname' && $srch->{'srchtype'} eq 'exact' && $srch->{'srchin'} eq 'dom' && $srch->{'srchdomain'} eq $env{'request.role.domain'}) {
1.627 raeburn 6426: if ($cancreate) {
6427: $new_user_create = '<p> <input type="submit" name="forcenew" value="'.&HTML::Entities::encode(&mt('Make new user "[_1]"',$srchterm),'<>&"').'" onclick="javascript:setSearch(\'1\','.$caller.');" /> </p>';
6428: } else {
6429: my $helplink = ' href="javascript:helpMenu('."'display'".')"';
6430: my %usertypetext = (
6431: official => 'institutional',
6432: unofficial => 'non-institutional',
6433: );
6434: $new_user_create = '<br /><span class="LC_warning">'.&mt("You are not authorized to create new $usertypetext{$usertype} users in this domain.").' '.&mt('Contact the <a[_1]>helpdesk</a> for assistance.',$helplink).'</span><br /><br />';
6435: }
1.576 raeburn 6436: }
6437: }
6438:
1.556 raeburn 6439: $newuserscript = <<"ENDSCRIPT";
6440:
1.570 raeburn 6441: function setSearch(createnew,callingForm) {
1.556 raeburn 6442: if (createnew == 1) {
1.570 raeburn 6443: for (var i=0; i<callingForm.srchby.length; i++) {
6444: if (callingForm.srchby.options[i].value == 'uname') {
6445: callingForm.srchby.selectedIndex = i;
1.556 raeburn 6446: }
6447: }
1.570 raeburn 6448: for (var i=0; i<callingForm.srchin.length; i++) {
6449: if ( callingForm.srchin.options[i].value == 'dom') {
6450: callingForm.srchin.selectedIndex = i;
1.556 raeburn 6451: }
6452: }
1.570 raeburn 6453: for (var i=0; i<callingForm.srchtype.length; i++) {
6454: if (callingForm.srchtype.options[i].value == 'exact') {
6455: callingForm.srchtype.selectedIndex = i;
1.556 raeburn 6456: }
6457: }
1.570 raeburn 6458: for (var i=0; i<callingForm.srchdomain.length; i++) {
6459: if (callingForm.srchdomain.options[i].value == '$env{'request.role.domain'}') {
6460: callingForm.srchdomain.selectedIndex = i;
1.556 raeburn 6461: }
6462: }
6463: }
6464: }
6465: ENDSCRIPT
1.558 albertel 6466:
1.556 raeburn 6467: }
6468:
1.555 raeburn 6469: my $output = <<"END_BLOCK";
1.556 raeburn 6470: <script type="text/javascript">
1.570 raeburn 6471: function validateEntry(callingForm) {
1.558 albertel 6472:
1.556 raeburn 6473: var checkok = 1;
1.558 albertel 6474: var srchin;
1.570 raeburn 6475: for (var i=0; i<callingForm.srchin.length; i++) {
6476: if ( callingForm.srchin[i].checked ) {
6477: srchin = callingForm.srchin[i].value;
1.558 albertel 6478: }
6479: }
6480:
1.570 raeburn 6481: var srchtype = callingForm.srchtype.options[callingForm.srchtype.selectedIndex].value;
6482: var srchby = callingForm.srchby.options[callingForm.srchby.selectedIndex].value;
6483: var srchdomain = callingForm.srchdomain.options[callingForm.srchdomain.selectedIndex].value;
6484: var srchterm = callingForm.srchterm.value;
6485: var srchin = callingForm.srchin.options[callingForm.srchin.selectedIndex].value;
1.556 raeburn 6486: var msg = "";
6487:
6488: if (srchterm == "") {
6489: checkok = 0;
1.571 raeburn 6490: msg += "$lt{'youm'}\\n";
1.556 raeburn 6491: }
6492:
1.569 raeburn 6493: if (srchtype== 'begins') {
6494: if (srchterm.length < 2) {
6495: checkok = 0;
1.571 raeburn 6496: msg += "$lt{'thte'}\\n";
1.569 raeburn 6497: }
6498: }
6499:
1.556 raeburn 6500: if (srchtype== 'contains') {
6501: if (srchterm.length < 3) {
6502: checkok = 0;
1.571 raeburn 6503: msg += "$lt{'thet'}\\n";
1.556 raeburn 6504: }
6505: }
6506: if (srchin == 'instd') {
6507: if (srchdomain == '') {
6508: checkok = 0;
1.571 raeburn 6509: msg += "$lt{'yomc'}\\n";
1.556 raeburn 6510: }
6511: }
6512: if (srchin == 'dom') {
6513: if (srchdomain == '') {
6514: checkok = 0;
1.571 raeburn 6515: msg += "$lt{'ymcd'}\\n";
1.556 raeburn 6516: }
6517: }
6518: if (srchby == 'lastfirst') {
6519: if (srchterm.indexOf(",") == -1) {
6520: checkok = 0;
1.571 raeburn 6521: msg += "$lt{'whus'}\\n";
1.556 raeburn 6522: }
6523: if (srchterm.indexOf(",") == srchterm.length -1) {
6524: checkok = 0;
1.571 raeburn 6525: msg += "$lt{'whse'}\\n";
1.556 raeburn 6526: }
6527: }
6528: if (checkok == 0) {
1.571 raeburn 6529: alert("$lt{'thfo'}\\n"+msg);
1.556 raeburn 6530: return;
6531: }
6532: if (checkok == 1) {
1.570 raeburn 6533: callingForm.submit();
1.556 raeburn 6534: }
6535: }
6536:
6537: $newuserscript
6538:
6539: </script>
1.558 albertel 6540:
6541: $new_user_create
6542:
1.555 raeburn 6543: <table>
1.558 albertel 6544: <tr>
1.573 raeburn 6545: <td>$lt{'doma'}:</td>
6546: <td>$domform</td>
6547: </td>
6548: </tr>
6549: <tr>
6550: <td>$lt{'usr'}:</td>
1.563 raeburn 6551: <td>$srchbysel
6552: $srchtypesel
6553: <input type="text" size="15" name="srchterm" value="$srchterm" />
1.564 albertel 6554: $srchinsel
1.563 raeburn 6555: </td>
6556: </tr>
1.555 raeburn 6557: </table>
6558: <br />
6559: END_BLOCK
1.558 albertel 6560:
1.555 raeburn 6561: return $output;
6562: }
6563:
1.612 raeburn 6564: sub user_rule_check {
1.615 raeburn 6565: my ($usershash,$checks,$alerts,$rulematch,$inst_results,$curr_rules,$got_rules) = @_;
1.612 raeburn 6566: my $response;
6567: if (ref($usershash) eq 'HASH') {
6568: foreach my $user (keys(%{$usershash})) {
6569: my ($uname,$udom) = split(/:/,$user);
6570: next if ($udom eq '' || $uname eq '');
1.615 raeburn 6571: my ($id,$newuser);
1.612 raeburn 6572: if (ref($usershash->{$user}) eq 'HASH') {
1.615 raeburn 6573: $newuser = $usershash->{$user}->{'newuser'};
1.612 raeburn 6574: $id = $usershash->{$user}->{'id'};
6575: }
6576: my $inst_response;
6577: if (ref($checks) eq 'HASH') {
6578: if (defined($checks->{'username'})) {
1.615 raeburn 6579: ($inst_response,%{$inst_results->{$user}}) =
1.612 raeburn 6580: &Apache::lonnet::get_instuser($udom,$uname);
6581: } elsif (defined($checks->{'id'})) {
1.615 raeburn 6582: ($inst_response,%{$inst_results->{$user}}) =
1.612 raeburn 6583: &Apache::lonnet::get_instuser($udom,undef,$id);
6584: }
1.615 raeburn 6585: } else {
6586: ($inst_response,%{$inst_results->{$user}}) =
6587: &Apache::lonnet::get_instuser($udom,$uname);
6588: return;
1.612 raeburn 6589: }
1.615 raeburn 6590: if (!$got_rules->{$udom}) {
1.612 raeburn 6591: my %domconfig = &Apache::lonnet::get_dom('configuration',
6592: ['usercreation'],$udom);
6593: if (ref($domconfig{'usercreation'}) eq 'HASH') {
1.615 raeburn 6594: foreach my $item ('username','id') {
1.612 raeburn 6595: if (ref($domconfig{'usercreation'}{$item.'_rule'}) eq 'ARRAY') {
6596: $$curr_rules{$udom}{$item} =
6597: $domconfig{'usercreation'}{$item.'_rule'};
1.585 raeburn 6598: }
6599: }
6600: }
1.615 raeburn 6601: $got_rules->{$udom} = 1;
1.585 raeburn 6602: }
1.612 raeburn 6603: foreach my $item (keys(%{$checks})) {
6604: if (ref($$curr_rules{$udom}) eq 'HASH') {
6605: if (ref($$curr_rules{$udom}{$item}) eq 'ARRAY') {
6606: if (@{$$curr_rules{$udom}{$item}} > 0) {
6607: my %rule_check = &Apache::lonnet::inst_rulecheck($udom,$uname,$id,$item,$$curr_rules{$udom}{$item});
6608: foreach my $rule (@{$$curr_rules{$udom}{$item}}) {
6609: if ($rule_check{$rule}) {
6610: $$rulematch{$user}{$item} = $rule;
6611: if ($inst_response eq 'ok') {
1.615 raeburn 6612: if (ref($inst_results) eq 'HASH') {
6613: if (ref($inst_results->{$user}) eq 'HASH') {
6614: if (keys(%{$inst_results->{$user}}) == 0) {
6615: $$alerts{$item}{$udom}{$uname} = 1;
6616: }
1.612 raeburn 6617: }
6618: }
1.615 raeburn 6619: }
6620: last;
1.585 raeburn 6621: }
6622: }
6623: }
6624: }
6625: }
6626: }
6627: }
6628: }
1.612 raeburn 6629: return;
6630: }
6631:
6632: sub user_rule_formats {
6633: my ($domain,$domdesc,$curr_rules,$check) = @_;
6634: my %text = (
6635: 'username' => 'Usernames',
6636: 'id' => 'IDs',
6637: );
6638: my $output;
6639: my ($rules,$ruleorder) = &Apache::lonnet::inst_userrules($domain,$check);
6640: if ((ref($rules) eq 'HASH') && (ref($ruleorder) eq 'ARRAY')) {
6641: if (@{$ruleorder} > 0) {
6642: $output = '<br />'.&mt("$text{$check} with the following format(s) may <span class=\"LC_cusr_emph\">only</span> be used for verified users at [_1]:",$domdesc).' <ul>';
6643: foreach my $rule (@{$ruleorder}) {
6644: if (ref($curr_rules) eq 'ARRAY') {
6645: if (grep(/^\Q$rule\E$/,@{$curr_rules})) {
6646: if (ref($rules->{$rule}) eq 'HASH') {
6647: $output .= '<li>'.$rules->{$rule}{'name'}.': '.
6648: $rules->{$rule}{'desc'}.'</li>';
6649: }
6650: }
6651: }
6652: }
6653: $output .= '</ul>';
6654: }
6655: }
6656: return $output;
6657: }
6658:
6659: sub instrule_disallow_msg {
1.615 raeburn 6660: my ($checkitem,$domdesc,$count,$mode) = @_;
1.612 raeburn 6661: my $response;
6662: my %text = (
6663: item => 'username',
6664: items => 'usernames',
6665: match => 'matches',
6666: do => 'does',
6667: action => 'a username',
6668: one => 'one',
6669: );
6670: if ($count > 1) {
6671: $text{'item'} = 'usernames';
6672: $text{'match'} ='match';
6673: $text{'do'} = 'do';
6674: $text{'action'} = 'usernames',
6675: $text{'one'} = 'ones';
6676: }
6677: if ($checkitem eq 'id') {
6678: $text{'items'} = 'IDs';
6679: $text{'item'} = 'ID';
6680: $text{'action'} = 'an ID';
1.615 raeburn 6681: if ($count > 1) {
6682: $text{'item'} = 'IDs';
6683: $text{'action'} = 'IDs';
6684: }
1.612 raeburn 6685: }
6686: $response = &mt("The $text{'item'} you chose $text{'match'} the format of $text{'items'} defined for <span class=\"LC_cusr_emph\">[_1]</span>, but the $text{'item'} $text{'do'} not exist in the institutional directory.",$domdesc).'<br />';
1.615 raeburn 6687: if ($mode eq 'upload') {
6688: if ($checkitem eq 'username') {
6689: $response .= &mt("You will need to modify your upload file so it will include $text{'action'} with a different format -- $text{'one'} that will not conflict with 'official' institutional $text{'items'}.");
6690: } elsif ($checkitem eq 'id') {
6691: $response .= &mt("Either upload a file which includes $text{'action'} with a different format -- $text{'one'} that will not conflict with 'official' institutional $text{'items'}, or when associating fields with data columns, omit an association for the ID/Student Number field.");
6692: }
6693: } else {
6694: if ($checkitem eq 'username') {
6695: $response .= &mt("You must choose $text{'action'} with a different format -- $text{'one'} that will not conflict with 'official' institutional $text{'items'}.");
6696: } elsif ($checkitem eq 'id') {
6697: $response .= &mt("You must either choose $text{'action'} with a different format -- $text{'one'} that will not conflict with 'official' institutional $text{'items'}, or leave the ID field blank.");
6698: }
1.612 raeburn 6699: }
6700: return $response;
1.585 raeburn 6701: }
6702:
1.624 raeburn 6703: sub personal_data_fieldtitles {
6704: my %fieldtitles = &Apache::lonlocal::texthash (
6705: id => 'Student/Employee ID',
6706: permanentemail => 'E-mail address',
6707: lastname => 'Last Name',
6708: firstname => 'First Name',
6709: middlename => 'Middle Name',
6710: generation => 'Generation',
6711: gen => 'Generation',
6712: );
6713: return %fieldtitles;
6714: }
6715:
1.642 raeburn 6716: sub sorted_inst_types {
6717: my ($dom) = @_;
6718: my ($usertypes,$order) = &Apache::lonnet::retrieve_inst_usertypes($dom);
6719: my $othertitle = &mt('All users');
6720: if ($env{'request.course.id'}) {
6721: $othertitle = 'any';
6722: }
6723: my @types;
6724: if (ref($order) eq 'ARRAY') {
6725: @types = @{$order};
6726: }
6727: if (@types == 0) {
6728: if (ref($usertypes) eq 'HASH') {
6729: @types = sort(keys(%{$usertypes}));
6730: }
6731: }
6732: if (keys(%{$usertypes}) > 0) {
6733: $othertitle = &mt('Other users');
6734: if ($env{'request.course.id'}) {
6735: $othertitle = 'other';
6736: }
6737: }
6738: return ($othertitle,$usertypes,\@types);
6739: }
6740:
1.645 ! raeburn 6741: sub get_institutional_codes {
! 6742: my ($settings,$allcourses,$LC_code) = @_;
! 6743: # Get complete list of course sections to update
! 6744: my @currsections = ();
! 6745: my @currxlists = ();
! 6746: my $coursecode = $$settings{'internal.coursecode'};
! 6747:
! 6748: if ($$settings{'internal.sectionnums'} ne '') {
! 6749: @currsections = split(/,/,$$settings{'internal.sectionnums'});
! 6750: }
! 6751:
! 6752: if ($$settings{'internal.crosslistings'} ne '') {
! 6753: @currxlists = split(/,/,$$settings{'internal.crosslistings'});
! 6754: }
! 6755:
! 6756: if (@currxlists > 0) {
! 6757: foreach (@currxlists) {
! 6758: if (m/^([^:]+):(\w*)$/) {
! 6759: unless (grep/^$1$/,@{$allcourses}) {
! 6760: push @{$allcourses},$1;
! 6761: $$LC_code{$1} = $2;
! 6762: }
! 6763: }
! 6764: }
! 6765: }
! 6766:
! 6767: if (@currsections > 0) {
! 6768: foreach (@currsections) {
! 6769: if (m/^(\w+):(\w*)$/) {
! 6770: my $sec = $coursecode.$1;
! 6771: my $lc_sec = $2;
! 6772: unless (grep/^$sec$/,@{$allcourses}) {
! 6773: push @{$allcourses},$sec;
! 6774: $$LC_code{$sec} = $lc_sec;
! 6775: }
! 6776: }
! 6777: }
! 6778: }
! 6779: return;
! 6780: }
! 6781:
1.112 bowersj2 6782: =pod
6783:
1.549 albertel 6784: =back
6785:
6786: =head1 HTTP Helpers
6787:
6788: =over 4
6789:
1.112 bowersj2 6790: =item * get_unprocessed_cgi($query,$possible_names)
6791:
1.258 albertel 6792: Modify the %env hash to contain unprocessed CGI form parameters held in
1.112 bowersj2 6793: $query. The parameters listed in $possible_names (an array reference),
1.258 albertel 6794: will be set in $env{'form.name'} if they do not already exist.
1.112 bowersj2 6795:
6796: Typically called with $ENV{'QUERY_STRING'} as the first parameter.
6797: $possible_names is an ref to an array of form element names. As an example:
6798: get_unprocessed_cgi($ENV{'QUERY_STRING'},['uname','udom']);
1.258 albertel 6799: will result in $env{'form.uname'} and $env{'form.udom'} being set.
1.112 bowersj2 6800:
6801: =cut
1.1 albertel 6802:
1.6 albertel 6803: sub get_unprocessed_cgi {
1.25 albertel 6804: my ($query,$possible_names)= @_;
1.26 matthew 6805: # $Apache::lonxml::debug=1;
1.356 albertel 6806: foreach my $pair (split(/&/,$query)) {
6807: my ($name, $value) = split(/=/,$pair);
1.369 www 6808: $name = &unescape($name);
1.25 albertel 6809: if (!defined($possible_names) || (grep {$_ eq $name} @$possible_names)) {
6810: $value =~ tr/+/ /;
6811: $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
1.258 albertel 6812: unless (defined($env{'form.'.$name})) { &add_to_env('form.'.$name,$value) };
1.25 albertel 6813: }
1.16 harris41 6814: }
1.6 albertel 6815: }
6816:
1.112 bowersj2 6817: =pod
6818:
6819: =item * cacheheader()
6820:
6821: returns cache-controlling header code
6822:
6823: =cut
6824:
1.7 albertel 6825: sub cacheheader {
1.258 albertel 6826: unless ($env{'request.method'} eq 'GET') { return ''; }
1.216 albertel 6827: my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
6828: my $output .='<meta HTTP-EQUIV="Expires" CONTENT="'.$date.'" />
1.7 albertel 6829: <meta HTTP-EQUIV="Cache-control" CONTENT="no-cache" />
6830: <meta HTTP-EQUIV="Pragma" CONTENT="no-cache" />';
1.216 albertel 6831: return $output;
1.7 albertel 6832: }
6833:
1.112 bowersj2 6834: =pod
6835:
6836: =item * no_cache($r)
6837:
6838: specifies header code to not have cache
6839:
6840: =cut
6841:
1.9 albertel 6842: sub no_cache {
1.216 albertel 6843: my ($r) = @_;
6844: if ($ENV{'REQUEST_METHOD'} ne 'GET' &&
1.258 albertel 6845: $env{'request.method'} ne 'GET') { return ''; }
1.216 albertel 6846: my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime(time));
6847: $r->no_cache(1);
6848: $r->header_out("Expires" => $date);
6849: $r->header_out("Pragma" => "no-cache");
1.123 www 6850: }
6851:
6852: sub content_type {
1.181 albertel 6853: my ($r,$type,$charset) = @_;
1.299 foxr 6854: if ($r) {
6855: # Note that printout.pl calls this with undef for $r.
6856: &no_cache($r);
6857: }
1.258 albertel 6858: if ($env{'browser.mathml'} && $type eq 'text/html') { $type='text/xml'; }
1.181 albertel 6859: unless ($charset) {
6860: $charset=&Apache::lonlocal::current_encoding;
6861: }
6862: if ($charset) { $type.='; charset='.$charset; }
6863: if ($r) {
6864: $r->content_type($type);
6865: } else {
6866: print("Content-type: $type\n\n");
6867: }
1.9 albertel 6868: }
1.25 albertel 6869:
1.112 bowersj2 6870: =pod
6871:
6872: =item * add_to_env($name,$value)
6873:
1.258 albertel 6874: adds $name to the %env hash with value
1.112 bowersj2 6875: $value, if $name already exists, the entry is converted to an array
6876: reference and $value is added to the array.
6877:
6878: =cut
6879:
1.25 albertel 6880: sub add_to_env {
6881: my ($name,$value)=@_;
1.258 albertel 6882: if (defined($env{$name})) {
6883: if (ref($env{$name})) {
1.25 albertel 6884: #already have multiple values
1.258 albertel 6885: push(@{ $env{$name} },$value);
1.25 albertel 6886: } else {
6887: #first time seeing multiple values, convert hash entry to an arrayref
1.258 albertel 6888: my $first=$env{$name};
6889: undef($env{$name});
6890: push(@{ $env{$name} },$first,$value);
1.25 albertel 6891: }
6892: } else {
1.258 albertel 6893: $env{$name}=$value;
1.25 albertel 6894: }
1.31 albertel 6895: }
1.149 albertel 6896:
6897: =pod
6898:
6899: =item * get_env_multiple($name)
6900:
1.258 albertel 6901: gets $name from the %env hash, it seemlessly handles the cases where multiple
1.149 albertel 6902: values may be defined and end up as an array ref.
6903:
6904: returns an array of values
6905:
6906: =cut
6907:
6908: sub get_env_multiple {
6909: my ($name) = @_;
6910: my @values;
1.258 albertel 6911: if (defined($env{$name})) {
1.149 albertel 6912: # exists is it an array
1.258 albertel 6913: if (ref($env{$name})) {
6914: @values=@{ $env{$name} };
1.149 albertel 6915: } else {
1.258 albertel 6916: $values[0]=$env{$name};
1.149 albertel 6917: }
6918: }
6919: return(@values);
6920: }
6921:
1.31 albertel 6922:
1.41 ng 6923: =pod
1.45 matthew 6924:
1.464 albertel 6925: =back
1.41 ng 6926:
1.112 bowersj2 6927: =head1 CSV Upload/Handling functions
1.38 albertel 6928:
1.41 ng 6929: =over 4
6930:
1.112 bowersj2 6931: =item * upfile_store($r)
1.41 ng 6932:
6933: Store uploaded file, $r should be the HTTP Request object,
1.258 albertel 6934: needs $env{'form.upfile'}
1.41 ng 6935: returns $datatoken to be put into hidden field
6936:
6937: =cut
1.31 albertel 6938:
6939: sub upfile_store {
6940: my $r=shift;
1.258 albertel 6941: $env{'form.upfile'}=~s/\r/\n/gs;
6942: $env{'form.upfile'}=~s/\f/\n/gs;
6943: $env{'form.upfile'}=~s/\n+/\n/gs;
6944: $env{'form.upfile'}=~s/\n+$//gs;
1.31 albertel 6945:
1.258 albertel 6946: my $datatoken=$env{'user.name'}.'_'.$env{'user.domain'}.
6947: '_enroll_'.$env{'request.course.id'}.'_'.time.'_'.$$;
1.31 albertel 6948: {
1.158 raeburn 6949: my $datafile = $r->dir_config('lonDaemons').
6950: '/tmp/'.$datatoken.'.tmp';
6951: if ( open(my $fh,">$datafile") ) {
1.258 albertel 6952: print $fh $env{'form.upfile'};
1.158 raeburn 6953: close($fh);
6954: }
1.31 albertel 6955: }
6956: return $datatoken;
6957: }
6958:
1.56 matthew 6959: =pod
6960:
1.112 bowersj2 6961: =item * load_tmp_file($r)
1.41 ng 6962:
6963: Load uploaded file from tmp, $r should be the HTTP Request object,
1.258 albertel 6964: needs $env{'form.datatoken'},
6965: sets $env{'form.upfile'} to the contents of the file
1.41 ng 6966:
6967: =cut
1.31 albertel 6968:
6969: sub load_tmp_file {
6970: my $r=shift;
6971: my @studentdata=();
6972: {
1.158 raeburn 6973: my $studentfile = $r->dir_config('lonDaemons').
1.258 albertel 6974: '/tmp/'.$env{'form.datatoken'}.'.tmp';
1.158 raeburn 6975: if ( open(my $fh,"<$studentfile") ) {
6976: @studentdata=<$fh>;
6977: close($fh);
6978: }
1.31 albertel 6979: }
1.258 albertel 6980: $env{'form.upfile'}=join('',@studentdata);
1.31 albertel 6981: }
6982:
1.56 matthew 6983: =pod
6984:
1.112 bowersj2 6985: =item * upfile_record_sep()
1.41 ng 6986:
6987: Separate uploaded file into records
6988: returns array of records,
1.258 albertel 6989: needs $env{'form.upfile'} and $env{'form.upfiletype'}
1.41 ng 6990:
6991: =cut
1.31 albertel 6992:
6993: sub upfile_record_sep {
1.258 albertel 6994: if ($env{'form.upfiletype'} eq 'xml') {
1.31 albertel 6995: } else {
1.248 albertel 6996: my @records;
1.258 albertel 6997: foreach my $line (split(/\n/,$env{'form.upfile'})) {
1.248 albertel 6998: if ($line=~/^\s*$/) { next; }
6999: push(@records,$line);
7000: }
7001: return @records;
1.31 albertel 7002: }
7003: }
7004:
1.56 matthew 7005: =pod
7006:
1.112 bowersj2 7007: =item * record_sep($record)
1.41 ng 7008:
1.258 albertel 7009: Separate a record into fields $record should be an item from the upfile_record_sep(), needs $env{'form.upfiletype'}
1.41 ng 7010:
7011: =cut
7012:
1.263 www 7013: sub takeleft {
7014: my $index=shift;
7015: return substr('0000'.$index,-4,4);
7016: }
7017:
1.31 albertel 7018: sub record_sep {
7019: my $record=shift;
7020: my %components=();
1.258 albertel 7021: if ($env{'form.upfiletype'} eq 'xml') {
7022: } elsif ($env{'form.upfiletype'} eq 'space') {
1.31 albertel 7023: my $i=0;
1.356 albertel 7024: foreach my $field (split(/\s+/,$record)) {
1.31 albertel 7025: $field=~s/^(\"|\')//;
7026: $field=~s/(\"|\')$//;
1.263 www 7027: $components{&takeleft($i)}=$field;
1.31 albertel 7028: $i++;
7029: }
1.258 albertel 7030: } elsif ($env{'form.upfiletype'} eq 'tab') {
1.31 albertel 7031: my $i=0;
1.356 albertel 7032: foreach my $field (split(/\t/,$record)) {
1.31 albertel 7033: $field=~s/^(\"|\')//;
7034: $field=~s/(\"|\')$//;
1.263 www 7035: $components{&takeleft($i)}=$field;
1.31 albertel 7036: $i++;
7037: }
7038: } else {
1.561 www 7039: my $separator=',';
1.480 banghart 7040: if ($env{'form.upfiletype'} eq 'semisv') {
1.561 www 7041: $separator=';';
1.480 banghart 7042: }
1.31 albertel 7043: my $i=0;
1.561 www 7044: # the character we are looking for to indicate the end of a quote or a record
7045: my $looking_for=$separator;
7046: # do not add the characters to the fields
7047: my $ignore=0;
7048: # we just encountered a separator (or the beginning of the record)
7049: my $just_found_separator=1;
7050: # store the field we are working on here
7051: my $field='';
7052: # work our way through all characters in record
7053: foreach my $character ($record=~/(.)/g) {
7054: if ($character eq $looking_for) {
7055: if ($character ne $separator) {
7056: # Found the end of a quote, again looking for separator
7057: $looking_for=$separator;
7058: $ignore=1;
7059: } else {
7060: # Found a separator, store away what we got
7061: $components{&takeleft($i)}=$field;
7062: $i++;
7063: $just_found_separator=1;
7064: $ignore=0;
7065: $field='';
7066: }
7067: next;
7068: }
7069: # single or double quotation marks after a separator indicate beginning of a quote
7070: # we are now looking for the end of the quote and need to ignore separators
7071: if ((($character eq '"') || ($character eq "'")) && ($just_found_separator)) {
7072: $looking_for=$character;
7073: next;
7074: }
7075: # ignore would be true after we reached the end of a quote
7076: if ($ignore) { next; }
7077: if (($just_found_separator) && ($character=~/\s/)) { next; }
7078: $field.=$character;
7079: $just_found_separator=0;
1.31 albertel 7080: }
1.561 www 7081: # catch the very last entry, since we never encountered the separator
7082: $components{&takeleft($i)}=$field;
1.31 albertel 7083: }
7084: return %components;
7085: }
7086:
1.144 matthew 7087: ######################################################
7088: ######################################################
7089:
1.56 matthew 7090: =pod
7091:
1.112 bowersj2 7092: =item * upfile_select_html()
1.41 ng 7093:
1.144 matthew 7094: Return HTML code to select a file from the users machine and specify
7095: the file type.
1.41 ng 7096:
7097: =cut
7098:
1.144 matthew 7099: ######################################################
7100: ######################################################
1.31 albertel 7101: sub upfile_select_html {
1.144 matthew 7102: my %Types = (
7103: csv => &mt('CSV (comma separated values, spreadsheet)'),
1.480 banghart 7104: semisv => &mt('Semicolon separated values'),
1.144 matthew 7105: space => &mt('Space separated'),
7106: tab => &mt('Tabulator separated'),
7107: # xml => &mt('HTML/XML'),
7108: );
7109: my $Str = '<input type="file" name="upfile" size="50" />'.
7110: '<br />Type: <select name="upfiletype">';
7111: foreach my $type (sort(keys(%Types))) {
7112: $Str .= '<option value="'.$type.'" >'.$Types{$type}."</option>\n";
7113: }
7114: $Str .= "</select>\n";
7115: return $Str;
1.31 albertel 7116: }
7117:
1.301 albertel 7118: sub get_samples {
7119: my ($records,$toget) = @_;
7120: my @samples=({});
7121: my $got=0;
7122: foreach my $rec (@$records) {
7123: my %temp = &record_sep($rec);
7124: if (! grep(/\S/, values(%temp))) { next; }
7125: if (%temp) {
7126: $samples[$got]=\%temp;
7127: $got++;
7128: if ($got == $toget) { last; }
7129: }
7130: }
7131: return \@samples;
7132: }
7133:
1.144 matthew 7134: ######################################################
7135: ######################################################
7136:
1.56 matthew 7137: =pod
7138:
1.112 bowersj2 7139: =item * csv_print_samples($r,$records)
1.41 ng 7140:
7141: Prints a table of sample values from each column uploaded $r is an
7142: Apache Request ref, $records is an arrayref from
7143: &Apache::loncommon::upfile_record_sep
7144:
7145: =cut
7146:
1.144 matthew 7147: ######################################################
7148: ######################################################
1.31 albertel 7149: sub csv_print_samples {
7150: my ($r,$records) = @_;
1.301 albertel 7151: my $samples = &get_samples($records,3);
7152:
1.594 raeburn 7153: $r->print(&mt('Samples').'<br />'.&start_data_table().
7154: &start_data_table_header_row());
1.356 albertel 7155: foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
7156: $r->print('<th>'.&mt('Column [_1]',($sample+1)).'</th>'); }
1.594 raeburn 7157: $r->print(&end_data_table_header_row());
1.301 albertel 7158: foreach my $hash (@$samples) {
1.594 raeburn 7159: $r->print(&start_data_table_row());
1.356 albertel 7160: foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
1.31 albertel 7161: $r->print('<td>');
1.356 albertel 7162: if (defined($$hash{$sample})) { $r->print($$hash{$sample}); }
1.31 albertel 7163: $r->print('</td>');
7164: }
1.594 raeburn 7165: $r->print(&end_data_table_row());
1.31 albertel 7166: }
1.594 raeburn 7167: $r->print(&end_data_table().'<br />'."\n");
1.31 albertel 7168: }
7169:
1.144 matthew 7170: ######################################################
7171: ######################################################
7172:
1.56 matthew 7173: =pod
7174:
1.112 bowersj2 7175: =item * csv_print_select_table($r,$records,$d)
1.41 ng 7176:
7177: Prints a table to create associations between values and table columns.
1.144 matthew 7178:
1.41 ng 7179: $r is an Apache Request ref,
7180: $records is an arrayref from &Apache::loncommon::upfile_record_sep,
1.174 matthew 7181: $d is an array of 2 element arrays (internal name, displayed name,defaultcol)
1.41 ng 7182:
7183: =cut
7184:
1.144 matthew 7185: ######################################################
7186: ######################################################
1.31 albertel 7187: sub csv_print_select_table {
7188: my ($r,$records,$d) = @_;
1.301 albertel 7189: my $i=0;
7190: my $samples = &get_samples($records,1);
1.144 matthew 7191: $r->print(&mt('Associate columns with student attributes.')."\n".
1.594 raeburn 7192: &start_data_table().&start_data_table_header_row().
1.144 matthew 7193: '<th>'.&mt('Attribute').'</th>'.
1.594 raeburn 7194: '<th>'.&mt('Column').'</th>'.
7195: &end_data_table_header_row()."\n");
1.356 albertel 7196: foreach my $array_ref (@$d) {
7197: my ($value,$display,$defaultcol)=@{ $array_ref };
1.594 raeburn 7198: $r->print(&start_data_table_row().'<tr><td>'.$display.'</td>');
1.31 albertel 7199:
7200: $r->print('<td><select name=f'.$i.
1.32 matthew 7201: ' onchange="javascript:flip(this.form,'.$i.');">');
1.31 albertel 7202: $r->print('<option value="none"></option>');
1.356 albertel 7203: foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
7204: $r->print('<option value="'.$sample.'"'.
7205: ($sample eq $defaultcol ? ' selected="selected" ' : '').
7206: '>Column '.($sample+1).'</option>');
1.31 albertel 7207: }
1.594 raeburn 7208: $r->print('</select></td>'.&end_data_table_row()."\n");
1.31 albertel 7209: $i++;
7210: }
1.594 raeburn 7211: $r->print(&end_data_table());
1.31 albertel 7212: $i--;
7213: return $i;
7214: }
1.56 matthew 7215:
1.144 matthew 7216: ######################################################
7217: ######################################################
7218:
1.56 matthew 7219: =pod
1.31 albertel 7220:
1.112 bowersj2 7221: =item * csv_samples_select_table($r,$records,$d)
1.41 ng 7222:
7223: Prints a table of sample values from the upload and can make associate samples to internal names.
7224:
7225: $r is an Apache Request ref,
7226: $records is an arrayref from &Apache::loncommon::upfile_record_sep,
7227: $d is an array of 2 element arrays (internal name, displayed name)
7228:
7229: =cut
7230:
1.144 matthew 7231: ######################################################
7232: ######################################################
1.31 albertel 7233: sub csv_samples_select_table {
7234: my ($r,$records,$d) = @_;
7235: my $i=0;
1.144 matthew 7236: #
1.301 albertel 7237: my $samples = &get_samples($records,3);
1.594 raeburn 7238: $r->print(&start_data_table().
7239: &start_data_table_header_row().'<th>'.
7240: &mt('Field').'</th><th>'.&mt('Samples').'</th>'.
7241: &end_data_table_header_row());
1.301 albertel 7242:
7243: foreach my $key (sort(keys(%{ $samples->[0] }))) {
1.594 raeburn 7244: $r->print(&start_data_table_row().'<td><select name="f'.$i.'"'.
1.32 matthew 7245: ' onchange="javascript:flip(this.form,'.$i.');">');
1.301 albertel 7246: foreach my $option (@$d) {
7247: my ($value,$display,$defaultcol)=@{ $option };
1.174 matthew 7248: $r->print('<option value="'.$value.'"'.
1.253 albertel 7249: ($i eq $defaultcol ? ' selected="selected" ':'').'>'.
1.174 matthew 7250: $display.'</option>');
1.31 albertel 7251: }
7252: $r->print('</select></td><td>');
1.301 albertel 7253: foreach my $line (0..2) {
7254: if (defined($samples->[$line]{$key})) {
7255: $r->print($samples->[$line]{$key}."<br />\n");
7256: }
7257: }
1.594 raeburn 7258: $r->print('</td>'.&end_data_table_row());
1.31 albertel 7259: $i++;
7260: }
1.594 raeburn 7261: $r->print(&end_data_table());
1.31 albertel 7262: $i--;
7263: return($i);
1.115 matthew 7264: }
7265:
1.144 matthew 7266: ######################################################
7267: ######################################################
7268:
1.115 matthew 7269: =pod
7270:
7271: =item clean_excel_name($name)
7272:
7273: Returns a replacement for $name which does not contain any illegal characters.
7274:
7275: =cut
7276:
1.144 matthew 7277: ######################################################
7278: ######################################################
1.115 matthew 7279: sub clean_excel_name {
7280: my ($name) = @_;
7281: $name =~ s/[:\*\?\/\\]//g;
7282: if (length($name) > 31) {
7283: $name = substr($name,0,31);
7284: }
7285: return $name;
1.25 albertel 7286: }
1.84 albertel 7287:
1.85 albertel 7288: =pod
7289:
1.112 bowersj2 7290: =item * check_if_partid_hidden($id,$symb,$udom,$uname)
1.85 albertel 7291:
7292: Returns either 1 or undef
7293:
7294: 1 if the part is to be hidden, undef if it is to be shown
7295:
7296: Arguments are:
7297:
7298: $id the id of the part to be checked
7299: $symb, optional the symb of the resource to check
7300: $udom, optional the domain of the user to check for
7301: $uname, optional the username of the user to check for
7302:
7303: =cut
1.84 albertel 7304:
7305: sub check_if_partid_hidden {
7306: my ($id,$symb,$udom,$uname) = @_;
1.133 albertel 7307: my $hiddenparts=&Apache::lonnet::EXT('resource.0.hiddenparts',
1.84 albertel 7308: $symb,$udom,$uname);
1.141 albertel 7309: my $truth=1;
7310: #if the string starts with !, then the list is the list to show not hide
7311: if ($hiddenparts=~s/^\s*!//) { $truth=undef; }
1.84 albertel 7312: my @hiddenlist=split(/,/,$hiddenparts);
7313: foreach my $checkid (@hiddenlist) {
1.141 albertel 7314: if ($checkid =~ /^\s*\Q$id\E\s*$/) { return $truth; }
1.84 albertel 7315: }
1.141 albertel 7316: return !$truth;
1.84 albertel 7317: }
1.127 matthew 7318:
1.138 matthew 7319:
7320: ############################################################
7321: ############################################################
7322:
7323: =pod
7324:
1.157 matthew 7325: =back
7326:
1.138 matthew 7327: =head1 cgi-bin script and graphing routines
7328:
1.157 matthew 7329: =over 4
7330:
1.138 matthew 7331: =item get_cgi_id
7332:
7333: Inputs: none
7334:
7335: Returns an id which can be used to pass environment variables
7336: to various cgi-bin scripts. These environment variables will
7337: be removed from the users environment after a given time by
7338: the routine &Apache::lonnet::transfer_profile_to_env.
7339:
7340: =cut
7341:
7342: ############################################################
7343: ############################################################
1.152 albertel 7344: my $uniq=0;
1.136 matthew 7345: sub get_cgi_id {
1.154 albertel 7346: $uniq=($uniq+1)%100000;
1.280 albertel 7347: return (time.'_'.$$.'_'.$uniq);
1.136 matthew 7348: }
7349:
1.127 matthew 7350: ############################################################
7351: ############################################################
7352:
7353: =pod
7354:
1.134 matthew 7355: =item DrawBarGraph
1.127 matthew 7356:
1.138 matthew 7357: Facilitates the plotting of data in a (stacked) bar graph.
7358: Puts plot definition data into the users environment in order for
7359: graph.png to plot it. Returns an <img> tag for the plot.
7360: The bars on the plot are labeled '1','2',...,'n'.
7361:
7362: Inputs:
7363:
7364: =over 4
7365:
7366: =item $Title: string, the title of the plot
7367:
7368: =item $xlabel: string, text describing the X-axis of the plot
7369:
7370: =item $ylabel: string, text describing the Y-axis of the plot
7371:
7372: =item $Max: scalar, the maximum Y value to use in the plot
7373: If $Max is < any data point, the graph will not be rendered.
7374:
1.140 matthew 7375: =item $colors: array ref holding the colors to be used for the data sets when
1.138 matthew 7376: they are plotted. If undefined, default values will be used.
7377:
1.178 matthew 7378: =item $labels: array ref holding the labels to use on the x-axis for the bars.
7379:
1.138 matthew 7380: =item @Values: An array of array references. Each array reference holds data
7381: to be plotted in a stacked bar chart.
7382:
1.239 matthew 7383: =item If the final element of @Values is a hash reference the key/value
7384: pairs will be added to the graph definition.
7385:
1.138 matthew 7386: =back
7387:
7388: Returns:
7389:
7390: An <img> tag which references graph.png and the appropriate identifying
7391: information for the plot.
7392:
1.127 matthew 7393: =cut
7394:
7395: ############################################################
7396: ############################################################
1.134 matthew 7397: sub DrawBarGraph {
1.178 matthew 7398: my ($Title,$xlabel,$ylabel,$Max,$colors,$labels,@Values)=@_;
1.134 matthew 7399: #
7400: if (! defined($colors)) {
7401: $colors = ['#33ff00',
7402: '#0033cc', '#990000', '#aaaa66', '#663399', '#ff9933',
7403: '#66ccff', '#ff9999', '#cccc33', '#660000', '#33cc66',
7404: ];
7405: }
1.228 matthew 7406: my $extra_settings = {};
7407: if (ref($Values[-1]) eq 'HASH') {
7408: $extra_settings = pop(@Values);
7409: }
1.127 matthew 7410: #
1.136 matthew 7411: my $identifier = &get_cgi_id();
7412: my $id = 'cgi.'.$identifier;
1.129 matthew 7413: if (! @Values || ref($Values[0]) ne 'ARRAY') {
1.127 matthew 7414: return '';
7415: }
1.225 matthew 7416: #
7417: my @Labels;
7418: if (defined($labels)) {
7419: @Labels = @$labels;
7420: } else {
7421: for (my $i=0;$i<@{$Values[0]};$i++) {
7422: push (@Labels,$i+1);
7423: }
7424: }
7425: #
1.129 matthew 7426: my $NumBars = scalar(@{$Values[0]});
1.225 matthew 7427: if ($NumBars < scalar(@Labels)) { $NumBars = scalar(@Labels); }
1.129 matthew 7428: my %ValuesHash;
7429: my $NumSets=1;
7430: foreach my $array (@Values) {
7431: next if (! ref($array));
1.136 matthew 7432: $ValuesHash{$id.'.data.'.$NumSets++} =
1.132 matthew 7433: join(',',@$array);
1.129 matthew 7434: }
1.127 matthew 7435: #
1.136 matthew 7436: my ($height,$width,$xskip,$bar_width) = (200,120,1,15);
1.225 matthew 7437: if ($NumBars < 3) {
7438: $width = 120+$NumBars*32;
1.220 matthew 7439: $xskip = 1;
1.225 matthew 7440: $bar_width = 30;
7441: } elsif ($NumBars < 5) {
7442: $width = 120+$NumBars*20;
7443: $xskip = 1;
7444: $bar_width = 20;
1.220 matthew 7445: } elsif ($NumBars < 10) {
1.136 matthew 7446: $width = 120+$NumBars*15;
7447: $xskip = 1;
7448: $bar_width = 15;
7449: } elsif ($NumBars <= 25) {
7450: $width = 120+$NumBars*11;
7451: $xskip = 5;
7452: $bar_width = 8;
7453: } elsif ($NumBars <= 50) {
7454: $width = 120+$NumBars*8;
7455: $xskip = 5;
7456: $bar_width = 4;
7457: } else {
7458: $width = 120+$NumBars*8;
7459: $xskip = 5;
7460: $bar_width = 4;
7461: }
7462: #
1.137 matthew 7463: $Max = 1 if ($Max < 1);
7464: if ( int($Max) < $Max ) {
7465: $Max++;
7466: $Max = int($Max);
7467: }
1.127 matthew 7468: $Title = '' if (! defined($Title));
7469: $xlabel = '' if (! defined($xlabel));
7470: $ylabel = '' if (! defined($ylabel));
1.369 www 7471: $ValuesHash{$id.'.title'} = &escape($Title);
7472: $ValuesHash{$id.'.xlabel'} = &escape($xlabel);
7473: $ValuesHash{$id.'.ylabel'} = &escape($ylabel);
1.137 matthew 7474: $ValuesHash{$id.'.y_max_value'} = $Max;
1.136 matthew 7475: $ValuesHash{$id.'.NumBars'} = $NumBars;
7476: $ValuesHash{$id.'.NumSets'} = $NumSets;
7477: $ValuesHash{$id.'.PlotType'} = 'bar';
7478: $ValuesHash{$id.'.Colors'} = join(',',@{$colors});
7479: $ValuesHash{$id.'.height'} = $height;
7480: $ValuesHash{$id.'.width'} = $width;
7481: $ValuesHash{$id.'.xskip'} = $xskip;
7482: $ValuesHash{$id.'.bar_width'} = $bar_width;
7483: $ValuesHash{$id.'.labels'} = join(',',@Labels);
1.127 matthew 7484: #
1.228 matthew 7485: # Deal with other parameters
7486: while (my ($key,$value) = each(%$extra_settings)) {
7487: $ValuesHash{$id.'.'.$key} = $value;
7488: }
7489: #
1.137 matthew 7490: &Apache::lonnet::appenv(%ValuesHash);
7491: return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';
7492: }
7493:
7494: ############################################################
7495: ############################################################
7496:
7497: =pod
7498:
7499: =item DrawXYGraph
7500:
1.138 matthew 7501: Facilitates the plotting of data in an XY graph.
7502: Puts plot definition data into the users environment in order for
7503: graph.png to plot it. Returns an <img> tag for the plot.
7504:
7505: Inputs:
7506:
7507: =over 4
7508:
7509: =item $Title: string, the title of the plot
7510:
7511: =item $xlabel: string, text describing the X-axis of the plot
7512:
7513: =item $ylabel: string, text describing the Y-axis of the plot
7514:
7515: =item $Max: scalar, the maximum Y value to use in the plot
7516: If $Max is < any data point, the graph will not be rendered.
7517:
7518: =item $colors: Array ref containing the hex color codes for the data to be
7519: plotted in. If undefined, default values will be used.
7520:
7521: =item $Xlabels: Array ref containing the labels to be used for the X-axis.
7522:
7523: =item $Ydata: Array ref containing Array refs.
1.185 www 7524: Each of the contained arrays will be plotted as a separate curve.
1.138 matthew 7525:
7526: =item %Values: hash indicating or overriding any default values which are
7527: passed to graph.png.
7528: Possible values are: width, xskip, x_ticks, x_tick_offset, among others.
7529:
7530: =back
7531:
7532: Returns:
7533:
7534: An <img> tag which references graph.png and the appropriate identifying
7535: information for the plot.
7536:
1.137 matthew 7537: =cut
7538:
7539: ############################################################
7540: ############################################################
7541: sub DrawXYGraph {
7542: my ($Title,$xlabel,$ylabel,$Max,$colors,$Xlabels,$Ydata,%Values)=@_;
7543: #
7544: # Create the identifier for the graph
7545: my $identifier = &get_cgi_id();
7546: my $id = 'cgi.'.$identifier;
7547: #
7548: $Title = '' if (! defined($Title));
7549: $xlabel = '' if (! defined($xlabel));
7550: $ylabel = '' if (! defined($ylabel));
7551: my %ValuesHash =
7552: (
1.369 www 7553: $id.'.title' => &escape($Title),
7554: $id.'.xlabel' => &escape($xlabel),
7555: $id.'.ylabel' => &escape($ylabel),
1.137 matthew 7556: $id.'.y_max_value'=> $Max,
7557: $id.'.labels' => join(',',@$Xlabels),
7558: $id.'.PlotType' => 'XY',
7559: );
7560: #
7561: if (defined($colors) && ref($colors) eq 'ARRAY') {
7562: $ValuesHash{$id.'.Colors'} = join(',',@{$colors});
7563: }
7564: #
7565: if (! ref($Ydata) || ref($Ydata) ne 'ARRAY') {
7566: return '';
7567: }
7568: my $NumSets=1;
1.138 matthew 7569: foreach my $array (@{$Ydata}){
1.137 matthew 7570: next if (! ref($array));
7571: $ValuesHash{$id.'.data.'.$NumSets++} = join(',',@$array);
7572: }
1.138 matthew 7573: $ValuesHash{$id.'.NumSets'} = $NumSets-1;
1.137 matthew 7574: #
7575: # Deal with other parameters
7576: while (my ($key,$value) = each(%Values)) {
7577: $ValuesHash{$id.'.'.$key} = $value;
1.127 matthew 7578: }
7579: #
1.136 matthew 7580: &Apache::lonnet::appenv(%ValuesHash);
7581: return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';
7582: }
7583:
7584: ############################################################
7585: ############################################################
7586:
7587: =pod
7588:
1.138 matthew 7589: =item DrawXYYGraph
7590:
7591: Facilitates the plotting of data in an XY graph with two Y axes.
7592: Puts plot definition data into the users environment in order for
7593: graph.png to plot it. Returns an <img> tag for the plot.
7594:
7595: Inputs:
7596:
7597: =over 4
7598:
7599: =item $Title: string, the title of the plot
7600:
7601: =item $xlabel: string, text describing the X-axis of the plot
7602:
7603: =item $ylabel: string, text describing the Y-axis of the plot
7604:
7605: =item $colors: Array ref containing the hex color codes for the data to be
7606: plotted in. If undefined, default values will be used.
7607:
7608: =item $Xlabels: Array ref containing the labels to be used for the X-axis.
7609:
7610: =item $Ydata1: The first data set
7611:
7612: =item $Min1: The minimum value of the left Y-axis
7613:
7614: =item $Max1: The maximum value of the left Y-axis
7615:
7616: =item $Ydata2: The second data set
7617:
7618: =item $Min2: The minimum value of the right Y-axis
7619:
7620: =item $Max2: The maximum value of the left Y-axis
7621:
7622: =item %Values: hash indicating or overriding any default values which are
7623: passed to graph.png.
7624: Possible values are: width, xskip, x_ticks, x_tick_offset, among others.
7625:
7626: =back
7627:
7628: Returns:
7629:
7630: An <img> tag which references graph.png and the appropriate identifying
7631: information for the plot.
1.136 matthew 7632:
7633: =cut
7634:
7635: ############################################################
7636: ############################################################
1.137 matthew 7637: sub DrawXYYGraph {
7638: my ($Title,$xlabel,$ylabel,$colors,$Xlabels,$Ydata1,$Min1,$Max1,
7639: $Ydata2,$Min2,$Max2,%Values)=@_;
1.136 matthew 7640: #
7641: # Create the identifier for the graph
7642: my $identifier = &get_cgi_id();
7643: my $id = 'cgi.'.$identifier;
7644: #
7645: $Title = '' if (! defined($Title));
7646: $xlabel = '' if (! defined($xlabel));
7647: $ylabel = '' if (! defined($ylabel));
7648: my %ValuesHash =
7649: (
1.369 www 7650: $id.'.title' => &escape($Title),
7651: $id.'.xlabel' => &escape($xlabel),
7652: $id.'.ylabel' => &escape($ylabel),
1.136 matthew 7653: $id.'.labels' => join(',',@$Xlabels),
7654: $id.'.PlotType' => 'XY',
7655: $id.'.NumSets' => 2,
1.137 matthew 7656: $id.'.two_axes' => 1,
7657: $id.'.y1_max_value' => $Max1,
7658: $id.'.y1_min_value' => $Min1,
7659: $id.'.y2_max_value' => $Max2,
7660: $id.'.y2_min_value' => $Min2,
1.136 matthew 7661: );
7662: #
1.137 matthew 7663: if (defined($colors) && ref($colors) eq 'ARRAY') {
7664: $ValuesHash{$id.'.Colors'} = join(',',@{$colors});
7665: }
7666: #
7667: if (! ref($Ydata1) || ref($Ydata1) ne 'ARRAY' ||
7668: ! ref($Ydata2) || ref($Ydata2) ne 'ARRAY'){
1.136 matthew 7669: return '';
7670: }
7671: my $NumSets=1;
1.137 matthew 7672: foreach my $array ($Ydata1,$Ydata2){
1.136 matthew 7673: next if (! ref($array));
7674: $ValuesHash{$id.'.data.'.$NumSets++} = join(',',@$array);
1.137 matthew 7675: }
7676: #
7677: # Deal with other parameters
7678: while (my ($key,$value) = each(%Values)) {
7679: $ValuesHash{$id.'.'.$key} = $value;
1.136 matthew 7680: }
7681: #
7682: &Apache::lonnet::appenv(%ValuesHash);
1.130 albertel 7683: return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';
1.139 matthew 7684: }
7685:
7686: ############################################################
7687: ############################################################
7688:
7689: =pod
7690:
1.157 matthew 7691: =back
7692:
1.139 matthew 7693: =head1 Statistics helper routines?
7694:
7695: Bad place for them but what the hell.
7696:
1.157 matthew 7697: =over 4
7698:
1.139 matthew 7699: =item &chartlink
7700:
7701: Returns a link to the chart for a specific student.
7702:
7703: Inputs:
7704:
7705: =over 4
7706:
7707: =item $linktext: The text of the link
7708:
7709: =item $sname: The students username
7710:
7711: =item $sdomain: The students domain
7712:
7713: =back
7714:
1.157 matthew 7715: =back
7716:
1.139 matthew 7717: =cut
7718:
7719: ############################################################
7720: ############################################################
7721: sub chartlink {
7722: my ($linktext, $sname, $sdomain) = @_;
7723: my $link = '<a href="/adm/statistics?reportSelected=student_assessment'.
1.369 www 7724: '&SelectedStudent='.&escape($sname.':'.$sdomain).
1.219 albertel 7725: '&chartoutputmode='.HTML::Entities::encode('html, with all links').
1.139 matthew 7726: '">'.$linktext.'</a>';
1.153 matthew 7727: }
7728:
7729: #######################################################
7730: #######################################################
7731:
7732: =pod
7733:
7734: =head1 Course Environment Routines
1.157 matthew 7735:
7736: =over 4
1.153 matthew 7737:
7738: =item &restore_course_settings
7739:
7740: =item &store_course_settings
7741:
7742: Restores/Store indicated form parameters from the course environment.
7743: Will not overwrite existing values of the form parameters.
7744:
7745: Inputs:
7746: a scalar describing the data (e.g. 'chart', 'problem_analysis')
7747:
7748: a hash ref describing the data to be stored. For example:
7749:
7750: %Save_Parameters = ('Status' => 'scalar',
7751: 'chartoutputmode' => 'scalar',
7752: 'chartoutputdata' => 'scalar',
7753: 'Section' => 'array',
1.373 raeburn 7754: 'Group' => 'array',
1.153 matthew 7755: 'StudentData' => 'array',
7756: 'Maps' => 'array');
7757:
7758: Returns: both routines return nothing
7759:
1.631 raeburn 7760: =back
7761:
1.153 matthew 7762: =cut
7763:
7764: #######################################################
7765: #######################################################
7766: sub store_course_settings {
1.496 albertel 7767: return &store_settings($env{'request.course.id'},@_);
7768: }
7769:
7770: sub store_settings {
1.153 matthew 7771: # save to the environment
7772: # appenv the same items, just to be safe
1.300 albertel 7773: my $udom = $env{'user.domain'};
7774: my $uname = $env{'user.name'};
1.496 albertel 7775: my ($context,$prefix,$Settings) = @_;
1.153 matthew 7776: my %SaveHash;
7777: my %AppHash;
7778: while (my ($setting,$type) = each(%$Settings)) {
1.496 albertel 7779: my $basename = join('.','internal',$context,$prefix,$setting);
1.300 albertel 7780: my $envname = 'environment.'.$basename;
1.258 albertel 7781: if (exists($env{'form.'.$setting})) {
1.153 matthew 7782: # Save this value away
7783: if ($type eq 'scalar' &&
1.258 albertel 7784: (! exists($env{$envname}) ||
7785: $env{$envname} ne $env{'form.'.$setting})) {
7786: $SaveHash{$basename} = $env{'form.'.$setting};
7787: $AppHash{$envname} = $env{'form.'.$setting};
1.153 matthew 7788: } elsif ($type eq 'array') {
7789: my $stored_form;
1.258 albertel 7790: if (ref($env{'form.'.$setting})) {
1.153 matthew 7791: $stored_form = join(',',
7792: map {
1.369 www 7793: &escape($_);
1.258 albertel 7794: } sort(@{$env{'form.'.$setting}}));
1.153 matthew 7795: } else {
7796: $stored_form =
1.369 www 7797: &escape($env{'form.'.$setting});
1.153 matthew 7798: }
7799: # Determine if the array contents are the same.
1.258 albertel 7800: if ($stored_form ne $env{$envname}) {
1.153 matthew 7801: $SaveHash{$basename} = $stored_form;
7802: $AppHash{$envname} = $stored_form;
7803: }
7804: }
7805: }
7806: }
7807: my $put_result = &Apache::lonnet::put('environment',\%SaveHash,
1.300 albertel 7808: $udom,$uname);
1.153 matthew 7809: if ($put_result !~ /^(ok|delayed)/) {
7810: &Apache::lonnet::logthis('unable to save form parameters, '.
7811: 'got error:'.$put_result);
7812: }
7813: # Make sure these settings stick around in this session, too
7814: &Apache::lonnet::appenv(%AppHash);
7815: return;
7816: }
7817:
7818: sub restore_course_settings {
1.499 albertel 7819: return &restore_settings($env{'request.course.id'},@_);
1.496 albertel 7820: }
7821:
7822: sub restore_settings {
7823: my ($context,$prefix,$Settings) = @_;
1.153 matthew 7824: while (my ($setting,$type) = each(%$Settings)) {
1.258 albertel 7825: next if (exists($env{'form.'.$setting}));
1.496 albertel 7826: my $envname = 'environment.internal.'.$context.'.'.$prefix.
1.153 matthew 7827: '.'.$setting;
1.258 albertel 7828: if (exists($env{$envname})) {
1.153 matthew 7829: if ($type eq 'scalar') {
1.258 albertel 7830: $env{'form.'.$setting} = $env{$envname};
1.153 matthew 7831: } elsif ($type eq 'array') {
1.258 albertel 7832: $env{'form.'.$setting} = [
1.153 matthew 7833: map {
1.369 www 7834: &unescape($_);
1.258 albertel 7835: } split(',',$env{$envname})
1.153 matthew 7836: ];
7837: }
7838: }
7839: }
1.127 matthew 7840: }
7841:
1.618 raeburn 7842: #######################################################
7843: #######################################################
7844:
7845: =pod
7846:
7847: =head1 Domain E-mail Routines
7848:
7849: =over 4
7850:
7851: =item &build_recipient_list
7852:
7853: Build recipient lists for three types of e-mail:
7854: (a) Error Reports, (b) Package Updates, (c) Help requests, generated by
1.619 raeburn 7855: lonerrorhandler.pm, CHECKRPMS and lonsupportreq.pm respectively.
1.618 raeburn 7856:
7857: Inputs:
1.619 raeburn 7858: defmail (scalar - email address of default recipient),
1.618 raeburn 7859: mailing type (scalar - errormail, packagesmail, or helpdeskmail),
1.619 raeburn 7860: defdom (domain for which to retrieve configuration settings),
7861: origmail (scalar - email address of recipient from loncapa.conf,
7862: i.e., predates configuration by DC via domainprefs.pm
1.618 raeburn 7863:
7864: Returns: comma separated list of addresses to which to send e-mail.
7865:
7866: =cut
7867:
7868: ############################################################
7869: ############################################################
7870: sub build_recipient_list {
1.619 raeburn 7871: my ($defmail,$mailing,$defdom,$origmail) = @_;
1.618 raeburn 7872: my @recipients;
7873: my $otheremails;
7874: my %domconfig =
7875: &Apache::lonnet::get_dom('configuration',['contacts'],$defdom);
7876: if (ref($domconfig{'contacts'}) eq 'HASH') {
7877: if (ref($domconfig{'contacts'}{$mailing}) eq 'HASH') {
7878: my @contacts = ('adminemail','supportemail');
7879: foreach my $item (@contacts) {
7880: if ($domconfig{'contacts'}{$mailing}{$item}) {
1.619 raeburn 7881: my $addr = $domconfig{'contacts'}{$item};
7882: if (!grep(/^\Q$addr\E$/,@recipients)) {
7883: push(@recipients,$addr);
7884: }
1.618 raeburn 7885: }
7886: $otheremails = $domconfig{'contacts'}{$mailing}{'others'};
7887: }
7888: }
1.619 raeburn 7889: } elsif ($origmail ne '') {
7890: push(@recipients,$origmail);
1.618 raeburn 7891: }
7892: if ($defmail ne '') {
7893: push(@recipients,$defmail);
7894: }
7895: if ($otheremails) {
1.619 raeburn 7896: my @others;
7897: if ($otheremails =~ /,/) {
7898: @others = split(/,/,$otheremails);
1.618 raeburn 7899: } else {
1.619 raeburn 7900: push(@others,$otheremails);
7901: }
7902: foreach my $addr (@others) {
7903: if (!grep(/^\Q$addr\E$/,@recipients)) {
7904: push(@recipients,$addr);
7905: }
1.618 raeburn 7906: }
7907: }
1.619 raeburn 7908: my $recipientlist = join(',',@recipients);
1.618 raeburn 7909: return $recipientlist;
7910: }
7911:
1.127 matthew 7912: ############################################################
7913: ############################################################
1.154 albertel 7914:
1.443 albertel 7915: sub commit_customrole {
7916: my ($udom,$uname,$url,$three,$four,$five,$start,$end) = @_;
1.630 raeburn 7917: my $output = &mt('Assigning custom role').' "'.$five.'" by '.$four.':'.$three.' in '.$url.
1.443 albertel 7918: ($start?', '.&mt('starting').' '.localtime($start):'').
7919: ($end?', ending '.localtime($end):'').': <b>'.
7920: &Apache::lonnet::assigncustomrole(
7921: $udom,$uname,$url,$three,$four,$five,$end,$start).
7922: '</b><br />';
7923: return $output;
7924: }
7925:
7926: sub commit_standardrole {
1.541 raeburn 7927: my ($udom,$uname,$url,$three,$start,$end,$one,$two,$sec,$context) = @_;
7928: my ($output,$logmsg,$linefeed);
7929: if ($context eq 'auto') {
7930: $linefeed = "\n";
7931: } else {
7932: $linefeed = "<br />\n";
7933: }
1.443 albertel 7934: if ($three eq 'st') {
1.541 raeburn 7935: my $result = &commit_studentrole(\$logmsg,$udom,$uname,$url,$three,$start,$end,
7936: $one,$two,$sec,$context);
7937: if (($result =~ /^error/) || ($result eq 'not_in_class') ||
1.626 raeburn 7938: ($result eq 'unknown_course') || ($result eq 'refused')) {
7939: $output = $logmsg.' '.&mt('Error: ').$result."\n";
1.443 albertel 7940: } else {
1.541 raeburn 7941: $output = $logmsg.$linefeed.&mt('Assigning').' '.$three.' in '.$url.
1.443 albertel 7942: ($start?', '.&mt('starting').' '.localtime($start):'').
1.541 raeburn 7943: ($end?', '.&mt('ending').' '.localtime($end):'').': ';
7944: if ($context eq 'auto') {
7945: $output .= $result.$linefeed.&mt('Add to classlist').': ok';
7946: } else {
7947: $output .= '<b>'.$result.'</b>'.$linefeed.
7948: &mt('Add to classlist').': <b>ok</b>';
7949: }
7950: $output .= $linefeed;
1.443 albertel 7951: }
7952: } else {
7953: $output = &mt('Assigning').' '.$three.' in '.$url.
7954: ($start?', '.&mt('starting').' '.localtime($start):'').
1.541 raeburn 7955: ($end?', '.&mt('ending').' '.localtime($end):'').': ';
7956: my $result = &Apache::lonnet::assignrole($udom,$uname,$url,$three,$end,$start);
7957: if ($context eq 'auto') {
7958: $output .= $result.$linefeed;
7959: } else {
7960: $output .= '<b>'.$result.'</b>'.$linefeed;
7961: }
1.443 albertel 7962: }
7963: return $output;
7964: }
7965:
7966: sub commit_studentrole {
1.541 raeburn 7967: my ($logmsg,$udom,$uname,$url,$three,$start,$end,$one,$two,$sec,$context) = @_;
1.626 raeburn 7968: my ($result,$linefeed,$oldsecurl,$newsecurl);
1.541 raeburn 7969: if ($context eq 'auto') {
7970: $linefeed = "\n";
7971: } else {
7972: $linefeed = '<br />'."\n";
7973: }
1.443 albertel 7974: if (defined($one) && defined($two)) {
7975: my $cid=$one.'_'.$two;
7976: my $oldsec=&Apache::lonnet::getsection($udom,$uname,$cid);
7977: my $secchange = 0;
7978: my $expire_role_result;
7979: my $modify_section_result;
1.628 raeburn 7980: if ($oldsec ne '-1') {
7981: if ($oldsec ne $sec) {
1.443 albertel 7982: $secchange = 1;
1.628 raeburn 7983: my $now = time;
1.443 albertel 7984: my $uurl='/'.$cid;
7985: $uurl=~s/\_/\//g;
7986: if ($oldsec) {
7987: $uurl.='/'.$oldsec;
7988: }
1.626 raeburn 7989: $oldsecurl = $uurl;
1.628 raeburn 7990: $expire_role_result =
7991: &Apache::lonnet::assignrole($udom,$uname,$uurl,'st',$now);
7992: if ($env{'request.course.sec'} ne '') {
7993: if ($expire_role_result eq 'refused') {
7994: my @roles = ('st');
7995: my @statuses = ('previous');
7996: my @roledoms = ($one);
7997: my $withsec = 1;
7998: my %roleshash =
7999: &Apache::lonnet::get_my_roles($uname,$udom,'userroles',
8000: \@statuses,\@roles,\@roledoms,$withsec);
8001: if (defined ($roleshash{$two.':'.$one.':st:'.$oldsec})) {
8002: my ($oldstart,$oldend) =
8003: split(':',$roleshash{$two.':'.$one.':st:'.$oldsec});
8004: if ($oldend > 0 && $oldend <= $now) {
8005: $expire_role_result = 'ok';
8006: }
8007: }
8008: }
8009: }
1.443 albertel 8010: $result = $expire_role_result;
8011: }
8012: }
8013: if (($expire_role_result eq 'ok') || ($secchange == 0)) {
8014: $modify_section_result = &Apache::lonnet::modify_student_enrollment($udom,$uname,undef,undef,undef,undef,undef,$sec,$end,$start,'','',$cid);
8015: if ($modify_section_result =~ /^ok/) {
8016: if ($secchange == 1) {
1.628 raeburn 8017: if ($sec eq '') {
8018: $$logmsg .= &mt('Section for [_1] switched from (possibly expired) old section: [_2] to student role without a section.',$uname,$oldsec).$linefeed;
8019: } else {
8020: $$logmsg .= &mt('Section for [_1] switched from (possibly expired) old section: [_2] to new section: [_3].',$uname,$oldsec,$sec).$linefeed;
8021: }
1.443 albertel 8022: } elsif ($oldsec eq '-1') {
1.628 raeburn 8023: if ($sec eq '') {
8024: $$logmsg .= &mt('New student role without a section for [_1] in course [_2].',$uname,$cid).$linefeed;
8025: } else {
8026: $$logmsg .= &mt('New student role for [_1] in section [_2] in course [_3].',$uname,$sec,$cid).$linefeed;
8027: }
1.443 albertel 8028: } else {
1.628 raeburn 8029: if ($sec eq '') {
8030: $$logmsg .= &mt('Student [_1] assigned to course [_2] without a section.',$uname,$cid).$linefeed;
8031: } else {
8032: $$logmsg .= &mt('Student [_1] assigned to section [_2] in course [_3].',$uname,$sec,$cid).$linefeed;
8033: }
1.443 albertel 8034: }
8035: } else {
1.628 raeburn 8036: if ($secchange) {
8037: $$logmsg .= &mt('Error when attempting section change for [_1] from old section "[_2]" to new section: "[_3]" in course [_4] -error:',$uname,$oldsec,$sec,$cid).' '.$modify_section_result.$linefeed;
8038: } else {
8039: $$logmsg .= &mt('Error when attempting to modify role for [_1] for section: "[_2]" in course [_3] -error:',$uname,$sec,$cid).' '.$modify_section_result.$linefeed;
8040: }
1.443 albertel 8041: }
8042: $result = $modify_section_result;
8043: } elsif ($secchange == 1) {
1.628 raeburn 8044: if ($oldsec eq '') {
8045: $$logmsg .= &mt('Error when attempting to expire existing role without a section for [_1] in course [_3] -error: ',$uname,$cid).' '.$expire_role_result.$linefeed;
8046: } else {
8047: $$logmsg .= &mt('Error when attempting to expire existing role for [_1] in section [_2] in course [_3] -error: ',$uname,$oldsec,$cid).' '.$expire_role_result.$linefeed;
8048: }
1.626 raeburn 8049: if ($expire_role_result eq 'refused') {
8050: my $newsecurl = '/'.$cid;
8051: $newsecurl =~ s/\_/\//g;
8052: if ($sec ne '') {
8053: $newsecurl.='/'.$sec;
8054: }
8055: if (&Apache::lonnet::allowed('cst',$newsecurl) && !(&Apache::lonnet::allowed('cst',$oldsecurl))) {
8056: if ($sec eq '') {
8057: $$logmsg .= &mt('Although your current role has privileges to add students to section "[_1]", you do not have privileges to modify existing enrollments unaffiliated with any section.',$sec).$linefeed;
8058: } else {
8059: $$logmsg .= &mt('Although your current role has privileges to add students to section "[_1]", you do not have privileges to modify existing enrollments in other sections.',$sec).$linefeed;
8060: }
8061: }
8062: }
1.443 albertel 8063: }
8064: } else {
1.626 raeburn 8065: $$logmsg .= &mt('Incomplete course id defined.').$linefeed.&mt('Addition of user [_1] from domain [_2] to course [_3], section [_4] not completed.',$uname,$udom,$one.'_'.$two,$sec).$linefeed;
1.443 albertel 8066: $result = "error: incomplete course id\n";
8067: }
8068: return $result;
8069: }
8070:
8071: ############################################################
8072: ############################################################
8073:
1.566 albertel 8074: sub check_clone {
1.578 raeburn 8075: my ($args,$linefeed) = @_;
1.566 albertel 8076: my $cloneid='/'.$args->{'clonedomain'}.'/'.$args->{'clonecourse'};
8077: my ($clonecrsudom,$clonecrsunum)= &LONCAPA::split_courseid($cloneid);
8078: my $clonehome=&Apache::lonnet::homeserver($clonecrsunum,$clonecrsudom);
8079: my $clonemsg;
8080: my $can_clone = 0;
8081:
8082: if ($clonehome eq 'no_host') {
1.578 raeburn 8083: $clonemsg = &mt('No new course created.').$linefeed.&mt('A new course could not be cloned from the specified original - [_1] - because it is a non-existent course.',$args->{'clonecourse'}.':'.$args->{'clonedomain'});
1.566 albertel 8084: } else {
8085: my %clonedesc = &Apache::lonnet::coursedescription($cloneid,{'one_time' => 1});
1.568 albertel 8086: if ($env{'request.role.domain'} eq $args->{'clonedomain'}) {
1.566 albertel 8087: $can_clone = 1;
8088: } else {
8089: my %clonehash = &Apache::lonnet::get('environment',['cloners'],
8090: $args->{'clonedomain'},$args->{'clonecourse'});
8091: my @cloners = split(/,/,$clonehash{'cloners'});
1.578 raeburn 8092: if (grep(/^\*$/,@cloners)) {
8093: $can_clone = 1;
8094: } elsif (grep(/^\*\:\Q$args->{'ccdomain'}\E$/,@cloners)) {
8095: $can_clone = 1;
8096: } else {
8097: my %roleshash =
8098: &Apache::lonnet::get_my_roles($args->{'ccuname'},
8099: $args->{'ccdomain'},
8100: 'userroles',['active'],['cc'],
8101: [$args->{'clonedomain'}]);
8102: if (($roleshash{$args->{'clonecourse'}.':'.$args->{'clonedomain'}.':cc'}) || (grep(/^\Q$args->{'ccuname'}\E:\Q$args->{'ccdomain'}\E$/,@cloners))) {
8103: $can_clone = 1;
8104: } else {
8105: $clonemsg = &mt('No new course created.').$linefeed.&mt('The new course could not be cloned from the existing course because the new course owner ([_1]) does not have cloning rights in the existing course ([_2]).',$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'});
8106: }
1.566 albertel 8107: }
1.578 raeburn 8108: }
1.566 albertel 8109: }
8110: return ($can_clone, $clonemsg, $cloneid, $clonehome);
8111: }
8112:
1.444 albertel 8113: sub construct_course {
1.541 raeburn 8114: my ($args,$logmsg,$courseid,$crsudom,$crsunum,$udom,$uname,$context) = @_;
1.444 albertel 8115: my $outcome;
1.541 raeburn 8116: my $linefeed = '<br />'."\n";
8117: if ($context eq 'auto') {
8118: $linefeed = "\n";
8119: }
1.566 albertel 8120:
8121: #
8122: # Are we cloning?
8123: #
8124: my ($can_clone, $clonemsg, $cloneid, $clonehome);
8125: if (($args->{'clonecourse'}) && ($args->{'clonedomain'})) {
1.578 raeburn 8126: ($can_clone, $clonemsg, $cloneid, $clonehome) = &check_clone($args,$linefeed);
1.566 albertel 8127: if ($context ne 'auto') {
1.578 raeburn 8128: if ($clonemsg ne '') {
8129: $clonemsg = '<span class="LC_error">'.$clonemsg.'</span>';
8130: }
1.566 albertel 8131: }
8132: $outcome .= $clonemsg.$linefeed;
8133:
8134: if (!$can_clone) {
8135: return (0,$outcome);
8136: }
8137: }
8138:
1.444 albertel 8139: #
8140: # Open course
8141: #
8142: my $crstype = lc($args->{'crstype'});
8143: my %cenv=();
8144: $$courseid=&Apache::lonnet::createcourse($args->{'course_domain'},
8145: $args->{'cdescr'},
8146: $args->{'curl'},
8147: $args->{'course_home'},
8148: $args->{'nonstandard'},
8149: $args->{'crscode'},
8150: $args->{'ccuname'}.':'.
8151: $args->{'ccdomain'},
8152: $args->{'crstype'});
8153:
8154: # Note: The testing routines depend on this being output; see
8155: # Utils::Course. This needs to at least be output as a comment
8156: # if anyone ever decides to not show this, and Utils::Course::new
8157: # will need to be suitably modified.
1.541 raeburn 8158: $outcome .= &mt('New LON-CAPA [_1] ID: [_2]',$crstype,$$courseid).$linefeed;
1.444 albertel 8159: #
8160: # Check if created correctly
8161: #
1.479 albertel 8162: ($$crsudom,$$crsunum)= &LONCAPA::split_courseid($$courseid);
1.444 albertel 8163: my $crsuhome=&Apache::lonnet::homeserver($$crsunum,$$crsudom);
1.541 raeburn 8164: $outcome .= &mt('Created on').': '.$crsuhome.$linefeed;
1.566 albertel 8165:
1.444 albertel 8166: #
1.566 albertel 8167: # Do the cloning
8168: #
8169: if ($can_clone && $cloneid) {
8170: $clonemsg = &mt('Cloning [_1] from [_2]',$crstype,$clonehome);
8171: if ($context ne 'auto') {
8172: $clonemsg = '<span class="LC_success">'.$clonemsg.'</span>';
8173: }
8174: $outcome .= $clonemsg.$linefeed;
8175: my %oldcenv=&Apache::lonnet::dump('environment',$$crsudom,$$crsunum);
1.444 albertel 8176: # Copy all files
1.637 www 8177: &Apache::lonclonecourse::copycoursefiles($cloneid,$$courseid,$args->{'datemode'},$args->{'dateshift'});
1.444 albertel 8178: # Restore URL
1.566 albertel 8179: $cenv{'url'}=$oldcenv{'url'};
1.444 albertel 8180: # Restore title
1.566 albertel 8181: $cenv{'description'}=$oldcenv{'description'};
1.444 albertel 8182: # Mark as cloned
1.566 albertel 8183: $cenv{'clonedfrom'}=$cloneid;
1.638 www 8184: # Need to clone grading mode
8185: my %newenv=&Apache::lonnet::get('environment',['grading'],$$crsudom,$$crsunum);
8186: $cenv{'grading'}=$newenv{'grading'};
8187: # Do not clone these environment entries
8188: &Apache::lonnet::del('environment',
8189: ['default_enrollment_start_date',
8190: 'default_enrollment_end_date',
8191: 'question.email',
8192: 'policy.email',
8193: 'comment.email',
8194: 'pch.users.denied',
8195: 'plc.users.denied'],
8196: $$crsudom,$$crsunum);
1.444 albertel 8197: }
1.566 albertel 8198:
1.444 albertel 8199: #
8200: # Set environment (will override cloned, if existing)
8201: #
8202: my @sections = ();
8203: my @xlists = ();
8204: if ($args->{'crstype'}) {
8205: $cenv{'type'}=$args->{'crstype'};
8206: }
8207: if ($args->{'crsid'}) {
8208: $cenv{'courseid'}=$args->{'crsid'};
8209: }
8210: if ($args->{'crscode'}) {
8211: $cenv{'internal.coursecode'}=$args->{'crscode'};
8212: }
8213: if ($args->{'crsquota'} ne '') {
8214: $cenv{'internal.coursequota'}=$args->{'crsquota'};
8215: } else {
8216: $cenv{'internal.coursequota'}=$args->{'crsquota'} = 20;
8217: }
8218: if ($args->{'ccuname'}) {
8219: $cenv{'internal.courseowner'} = $args->{'ccuname'}.
8220: ':'.$args->{'ccdomain'};
8221: } else {
8222: $cenv{'internal.courseowner'} = $args->{'curruser'};
8223: }
8224: my @badclasses = (); # Used to accumulate sections/crosslistings that did not pass classlist access check for course owner.
8225: if ($args->{'crssections'}) {
8226: $cenv{'internal.sectionnums'} = '';
8227: if ($args->{'crssections'} =~ m/,/) {
8228: @sections = split/,/,$args->{'crssections'};
8229: } else {
8230: $sections[0] = $args->{'crssections'};
8231: }
8232: if (@sections > 0) {
8233: foreach my $item (@sections) {
8234: my ($sec,$gp) = split/:/,$item;
8235: my $class = $args->{'crscode'}.$sec;
8236: my $addcheck = &Apache::lonnet::auto_new_course($$crsunum,$$crsudom,$class,$cenv{'internal.courseowner'});
8237: $cenv{'internal.sectionnums'} .= $item.',';
8238: unless ($addcheck eq 'ok') {
8239: push @badclasses, $class;
8240: }
8241: }
8242: $cenv{'internal.sectionnums'} =~ s/,$//;
8243: }
8244: }
8245: # do not hide course coordinator from staff listing,
8246: # even if privileged
8247: $cenv{'nothideprivileged'}=$args->{'ccuname'}.':'.$args->{'ccdomain'};
8248: # add crosslistings
8249: if ($args->{'crsxlist'}) {
8250: $cenv{'internal.crosslistings'}='';
8251: if ($args->{'crsxlist'} =~ m/,/) {
8252: @xlists = split/,/,$args->{'crsxlist'};
8253: } else {
8254: $xlists[0] = $args->{'crsxlist'};
8255: }
8256: if (@xlists > 0) {
8257: foreach my $item (@xlists) {
8258: my ($xl,$gp) = split/:/,$item;
8259: my $addcheck = &Apache::lonnet::auto_new_course($$crsunum,$$crsudom,$xl,$cenv{'internal.courseowner'});
8260: $cenv{'internal.crosslistings'} .= $item.',';
8261: unless ($addcheck eq 'ok') {
8262: push @badclasses, $xl;
8263: }
8264: }
8265: $cenv{'internal.crosslistings'} =~ s/,$//;
8266: }
8267: }
8268: if ($args->{'autoadds'}) {
8269: $cenv{'internal.autoadds'}=$args->{'autoadds'};
8270: }
8271: if ($args->{'autodrops'}) {
8272: $cenv{'internal.autodrops'}=$args->{'autodrops'};
8273: }
8274: # check for notification of enrollment changes
8275: my @notified = ();
8276: if ($args->{'notify_owner'}) {
8277: if ($args->{'ccuname'} ne '') {
8278: push(@notified,$args->{'ccuname'}.':'.$args->{'ccdomain'});
8279: }
8280: }
8281: if ($args->{'notify_dc'}) {
8282: if ($uname ne '') {
1.630 raeburn 8283: push(@notified,$uname.':'.$udom);
1.444 albertel 8284: }
8285: }
8286: if (@notified > 0) {
8287: my $notifylist;
8288: if (@notified > 1) {
8289: $notifylist = join(',',@notified);
8290: } else {
8291: $notifylist = $notified[0];
8292: }
8293: $cenv{'internal.notifylist'} = $notifylist;
8294: }
8295: if (@badclasses > 0) {
8296: my %lt=&Apache::lonlocal::texthash(
8297: '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',
8298: 'dnhr' => 'does not have rights to access enrollment in these classes',
8299: 'adby' => 'as determined by the policies of your institution on access to official classlists'
8300: );
1.541 raeburn 8301: my $badclass_msg = $cenv{'internal.courseowner'}.') - '.$lt{'dnhr'}.
8302: ' ('.$lt{'adby'}.')';
8303: if ($context eq 'auto') {
8304: $outcome .= $badclass_msg.$linefeed;
1.566 albertel 8305: $outcome .= '<div class="LC_warning">'.$badclass_msg.$linefeed.'<ul>'."\n";
1.541 raeburn 8306: foreach my $item (@badclasses) {
8307: if ($context eq 'auto') {
8308: $outcome .= " - $item\n";
8309: } else {
8310: $outcome .= "<li>$item</li>\n";
8311: }
8312: }
8313: if ($context eq 'auto') {
8314: $outcome .= $linefeed;
8315: } else {
1.566 albertel 8316: $outcome .= "</ul><br /><br /></div>\n";
1.541 raeburn 8317: }
8318: }
1.444 albertel 8319: }
8320: if ($args->{'no_end_date'}) {
8321: $args->{'endaccess'} = 0;
8322: }
8323: $cenv{'internal.autostart'}=$args->{'enrollstart'};
8324: $cenv{'internal.autoend'}=$args->{'enrollend'};
8325: $cenv{'default_enrollment_start_date'}=$args->{'startaccess'};
8326: $cenv{'default_enrollment_end_date'}=$args->{'endaccess'};
8327: if ($args->{'showphotos'}) {
8328: $cenv{'internal.showphotos'}=$args->{'showphotos'};
8329: }
8330: $cenv{'internal.authtype'} = $args->{'authtype'};
8331: $cenv{'internal.autharg'} = $args->{'autharg'};
8332: if ( ($cenv{'internal.authtype'} =~ /^krb/) && ($cenv{'internal.autoadds'} == 1)) {
8333: if (! defined($cenv{'internal.autharg'}) || $cenv{'internal.autharg'} eq '') {
1.541 raeburn 8334: my $krb_msg = &mt('As you did not include the default Kerberos domain to be used for authentication in this class, the institutional data used by the automated enrollment process must include the Kerberos domain for each new student');
8335: if ($context eq 'auto') {
8336: $outcome .= $krb_msg;
8337: } else {
1.566 albertel 8338: $outcome .= '<span class="LC_error">'.$krb_msg.'</span>';
1.541 raeburn 8339: }
8340: $outcome .= $linefeed;
1.444 albertel 8341: }
8342: }
8343: if (($args->{'ccdomain'}) && ($args->{'ccuname'})) {
8344: if ($args->{'setpolicy'}) {
8345: $cenv{'policy.email'}=$args->{'ccuname'}.':'.$args->{'ccdomain'};
8346: }
8347: if ($args->{'setcontent'}) {
8348: $cenv{'question.email'}=$args->{'ccuname'}.':'.$args->{'ccdomain'};
8349: }
8350: }
8351: if ($args->{'reshome'}) {
8352: $cenv{'reshome'}=$args->{'reshome'}.'/';
8353: $cenv{'reshome'}=~s/\/+$/\//;
8354: }
8355: #
8356: # course has keyed access
8357: #
8358: if ($args->{'setkeys'}) {
8359: $cenv{'keyaccess'}='yes';
8360: }
8361: # if specified, key authority is not course, but user
8362: # only active if keyaccess is yes
8363: if ($args->{'keyauth'}) {
1.487 albertel 8364: my ($user,$domain) = split(':',$args->{'keyauth'});
8365: $user = &LONCAPA::clean_username($user);
8366: $domain = &LONCAPA::clean_username($domain);
1.488 foxr 8367: if ($user ne '' && $domain ne '') {
1.487 albertel 8368: $cenv{'keyauth'}=$user.':'.$domain;
1.444 albertel 8369: }
8370: }
8371:
8372: if ($args->{'disresdis'}) {
8373: $cenv{'pch.roles.denied'}='st';
8374: }
8375: if ($args->{'disablechat'}) {
8376: $cenv{'plc.roles.denied'}='st';
8377: }
8378:
8379: # Record we've not yet viewed the Course Initialization Helper for this
8380: # course
8381: $cenv{'course.helper.not.run'} = 1;
8382: #
8383: # Use new Randomseed
8384: #
8385: $cenv{'rndseed'}=&Apache::lonnet::latest_rnd_algorithm_id();;
8386: $cenv{'receiptalg'}=&Apache::lonnet::latest_receipt_algorithm_id();;
8387: #
8388: # The encryption code and receipt prefix for this course
8389: #
8390: $cenv{'internal.encseed'}=$Apache::lonnet::perlvar{'lonReceipt'}.$$.time.int(rand(9999));
8391: $cenv{'internal.encpref'}=100+int(9*rand(99));
8392: #
8393: # By default, use standard grading
8394: if (!defined($cenv{'grading'})) { $cenv{'grading'} = 'standard'; }
8395:
1.541 raeburn 8396: $outcome .= $linefeed.&mt('Setting environment').': '.
8397: &Apache::lonnet::put('environment',\%cenv,$$crsudom,$$crsunum).$linefeed;
1.444 albertel 8398: #
8399: # Open all assignments
8400: #
8401: if ($args->{'openall'}) {
8402: my $storeunder=$$crsudom.'_'.$$crsunum.'.0.opendate';
8403: my %storecontent = ($storeunder => time,
8404: $storeunder.'.type' => 'date_start');
8405:
8406: $outcome .= &mt('Opening all assignments').': '.&Apache::lonnet::cput
1.541 raeburn 8407: ('resourcedata',\%storecontent,$$crsudom,$$crsunum).$linefeed;
1.444 albertel 8408: }
8409: #
8410: # Set first page
8411: #
8412: unless (($args->{'nonstandard'}) || ($args->{'firstres'} eq 'blank')
8413: || ($cloneid)) {
1.445 albertel 8414: use LONCAPA::map;
1.444 albertel 8415: $outcome .= &mt('Setting first resource').': ';
1.445 albertel 8416:
8417: my $map = '/uploaded/'.$$crsudom.'/'.$$crsunum.'/default.sequence';
8418: my ($errtext,$fatal)=&LONCAPA::map::mapread($map);
8419:
1.444 albertel 8420: $outcome .= ($fatal?$errtext:'read ok').' - ';
8421: my $title; my $url;
8422: if ($args->{'firstres'} eq 'syl') {
8423: $title='Syllabus';
8424: $url='/public/'.$$crsudom.'/'.$$crsunum.'/syllabus';
8425: } else {
8426: $title='Navigate Contents';
8427: $url='/adm/navmaps';
8428: }
1.445 albertel 8429:
8430: $LONCAPA::map::resources[1]=$title.':'.$url.':false:start:res';
8431: (my $outtext,$errtext) = &LONCAPA::map::storemap($map,1);
8432:
8433: if ($errtext) { $fatal=2; }
1.541 raeburn 8434: $outcome .= ($fatal?$errtext:'write ok').$linefeed;
1.444 albertel 8435: }
1.566 albertel 8436:
8437: return (1,$outcome);
1.444 albertel 8438: }
8439:
8440: ############################################################
8441: ############################################################
8442:
1.378 raeburn 8443: sub course_type {
8444: my ($cid) = @_;
8445: if (!defined($cid)) {
8446: $cid = $env{'request.course.id'};
8447: }
1.404 albertel 8448: if (defined($env{'course.'.$cid.'.type'})) {
8449: return $env{'course.'.$cid.'.type'};
1.378 raeburn 8450: } else {
8451: return 'Course';
1.377 raeburn 8452: }
8453: }
1.156 albertel 8454:
1.406 raeburn 8455: sub group_term {
8456: my $crstype = &course_type();
8457: my %names = (
8458: 'Course' => 'group',
8459: 'Group' => 'team',
8460: );
8461: return $names{$crstype};
8462: }
8463:
1.156 albertel 8464: sub icon {
8465: my ($file)=@_;
1.505 albertel 8466: my $curfext = lc((split(/\./,$file))[-1]);
1.168 albertel 8467: my $iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/unknown.gif';
1.156 albertel 8468: my $embstyle = &Apache::loncommon::fileembstyle($curfext);
1.168 albertel 8469: if (!(!defined($embstyle) || $embstyle eq 'unk' || $embstyle eq 'hdn')) {
8470: if (-e $Apache::lonnet::perlvar{'lonDocRoot'}.'/'.
8471: $Apache::lonnet::perlvar{'lonIconsURL'}.'/'.
8472: $curfext.".gif") {
8473: $iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/'.
8474: $curfext.".gif";
8475: }
8476: }
1.249 albertel 8477: return &lonhttpdurl($iconname);
1.154 albertel 8478: }
1.84 albertel 8479:
1.575 albertel 8480: sub lonhttpd_port {
1.215 albertel 8481: my $lonhttpd_port=$Apache::lonnet::perlvar{'lonhttpdPort'};
8482: if (!defined($lonhttpd_port)) { $lonhttpd_port='8080'; }
1.574 albertel 8483: # IE doesn't like a secure page getting images from a non-secure
8484: # port (when logging we haven't parsed the browser type so default
8485: # back to secure
8486: if ((!exists($env{'browser.type'}) || $env{'browser.type'} eq 'explorer')
8487: && $ENV{'SERVER_PORT'} == 443) {
1.575 albertel 8488: return 443;
8489: }
8490: return $lonhttpd_port;
8491:
8492: }
8493:
8494: sub lonhttpdurl {
8495: my ($url)=@_;
8496:
8497: my $lonhttpd_port = &lonhttpd_port();
8498: if ($lonhttpd_port == 443) {
1.574 albertel 8499: return 'https://'.$ENV{'SERVER_NAME'}.$url;
8500: }
1.215 albertel 8501: return 'http://'.$ENV{'SERVER_NAME'}.':'.$lonhttpd_port.$url;
8502: }
8503:
1.213 albertel 8504: sub connection_aborted {
8505: my ($r)=@_;
8506: $r->print(" ");$r->rflush();
8507: my $c = $r->connection;
8508: return $c->aborted();
8509: }
8510:
1.221 foxr 8511: # Escapes strings that may have embedded 's that will be put into
1.222 foxr 8512: # strings as 'strings'.
8513: sub escape_single {
1.221 foxr 8514: my ($input) = @_;
1.223 albertel 8515: $input =~ s/\\/\\\\/g; # Escape the \'s..(must be first)>
1.221 foxr 8516: $input =~ s/\'/\\\'/g; # Esacpe the 's....
8517: return $input;
8518: }
1.223 albertel 8519:
1.222 foxr 8520: # Same as escape_single, but escape's "'s This
8521: # can be used for "strings"
8522: sub escape_double {
8523: my ($input) = @_;
8524: $input =~ s/\\/\\\\/g; # Escape the /'s..(must be first)>
8525: $input =~ s/\"/\\\"/g; # Esacpe the "s....
8526: return $input;
8527: }
1.223 albertel 8528:
1.222 foxr 8529: # Escapes the last element of a full URL.
8530: sub escape_url {
8531: my ($url) = @_;
1.238 raeburn 8532: my @urlslices = split(/\//, $url,-1);
1.369 www 8533: my $lastitem = &escape(pop(@urlslices));
1.223 albertel 8534: return join('/',@urlslices).'/'.$lastitem;
1.222 foxr 8535: }
1.462 albertel 8536:
8537: # -------------------------------------------------------- Initliaze user login
8538: sub init_user_environment {
1.463 albertel 8539: my ($r, $username, $domain, $authhost, $form, $args) = @_;
1.462 albertel 8540: my $lonids=$Apache::lonnet::perlvar{'lonIDsDir'};
8541:
8542: my $public=($username eq 'public' && $domain eq 'public');
8543:
8544: # See if old ID present, if so, remove
8545:
8546: my ($filename,$cookie,$userroles);
8547: my $now=time;
8548:
8549: if ($public) {
8550: my $max_public=100;
8551: my $oldest;
8552: my $oldest_time=0;
8553: for(my $next=1;$next<=$max_public;$next++) {
8554: if (-e $lonids."/publicuser_$next.id") {
8555: my $mtime=(stat($lonids."/publicuser_$next.id"))[9];
8556: if ($mtime<$oldest_time || !$oldest_time) {
8557: $oldest_time=$mtime;
8558: $oldest=$next;
8559: }
8560: } else {
8561: $cookie="publicuser_$next";
8562: last;
8563: }
8564: }
8565: if (!$cookie) { $cookie="publicuser_$oldest"; }
8566: } else {
1.463 albertel 8567: # if this isn't a robot, kill any existing non-robot sessions
8568: if (!$args->{'robot'}) {
8569: opendir(DIR,$lonids);
8570: while ($filename=readdir(DIR)) {
8571: if ($filename=~/^$username\_\d+\_$domain\_$authhost\.id$/) {
8572: unlink($lonids.'/'.$filename);
8573: }
1.462 albertel 8574: }
1.463 albertel 8575: closedir(DIR);
1.462 albertel 8576: }
8577: # Give them a new cookie
1.463 albertel 8578: my $id = ($args->{'robot'} ? 'robot'.$args->{'robot'}
8579: : $now);
8580: $cookie="$username\_$id\_$domain\_$authhost";
1.462 albertel 8581:
8582: # Initialize roles
8583:
8584: $userroles=&Apache::lonnet::rolesinit($domain,$username,$authhost);
8585: }
8586: # ------------------------------------ Check browser type and MathML capability
8587:
8588: my ($httpbrowser,$clientbrowser,$clientversion,$clientmathml,
8589: $clientunicode,$clientos) = &decode_user_agent($r);
8590:
8591: # -------------------------------------- Any accessibility options to remember?
8592: if (($form->{'interface'}) && ($form->{'remember'} eq 'true')) {
8593: foreach my $option ('imagesuppress','appletsuppress',
8594: 'embedsuppress','fontenhance','blackwhite') {
8595: if ($form->{$option} eq 'true') {
8596: &Apache::lonnet::put('environment',{$option => 'on'},
8597: $domain,$username);
8598: } else {
8599: &Apache::lonnet::del('environment',[$option],
8600: $domain,$username);
8601: }
8602: }
8603: }
8604: # ------------------------------------------------------------- Get environment
8605:
8606: my %userenv = &Apache::lonnet::dump('environment',$domain,$username);
8607: my ($tmp) = keys(%userenv);
8608: if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
8609: # default remote control to off
8610: if ($userenv{'remote'} ne 'on') { $userenv{'remote'} = 'off'; }
8611: } else {
8612: undef(%userenv);
8613: }
8614: if (($userenv{'interface'}) && (!$form->{'interface'})) {
8615: $form->{'interface'}=$userenv{'interface'};
8616: }
8617: $env{'environment.remote'}=$userenv{'remote'};
8618: if ($userenv{'texengine'} eq 'ttm') { $clientmathml=1; }
8619:
8620: # --------------- Do not trust query string to be put directly into environment
8621: foreach my $option ('imagesuppress','appletsuppress',
8622: 'embedsuppress','fontenhance','blackwhite',
8623: 'interface','localpath','localres') {
8624: $form->{$option}=~s/[\n\r\=]//gs;
8625: }
8626: # --------------------------------------------------------- Write first profile
8627:
8628: {
8629: my %initial_env =
8630: ("user.name" => $username,
8631: "user.domain" => $domain,
8632: "user.home" => $authhost,
8633: "browser.type" => $clientbrowser,
8634: "browser.version" => $clientversion,
8635: "browser.mathml" => $clientmathml,
8636: "browser.unicode" => $clientunicode,
8637: "browser.os" => $clientos,
8638: "server.domain" => $Apache::lonnet::perlvar{'lonDefDomain'},
8639: "request.course.fn" => '',
8640: "request.course.uri" => '',
8641: "request.course.sec" => '',
8642: "request.role" => 'cm',
8643: "request.role.adv" => $env{'user.adv'},
8644: "request.host" => $ENV{'REMOTE_ADDR'},);
8645:
8646: if ($form->{'localpath'}) {
8647: $initial_env{"browser.localpath"} = $form->{'localpath'};
8648: $initial_env{"browser.localres"} = $form->{'localres'};
8649: }
8650:
8651: if ($public) {
8652: $initial_env{"environment.remote"} = "off";
8653: }
8654: if ($form->{'interface'}) {
8655: $form->{'interface'}=~s/\W//gs;
8656: $initial_env{"browser.interface"} = $form->{'interface'};
8657: $env{'browser.interface'}=$form->{'interface'};
8658: foreach my $option ('imagesuppress','appletsuppress',
8659: 'embedsuppress','fontenhance','blackwhite') {
8660: if (($form->{$option} eq 'true') ||
8661: ($userenv{$option} eq 'on')) {
8662: $initial_env{"browser.$option"} = "on";
8663: }
8664: }
8665: }
8666:
8667: $env{'user.environment'} = "$lonids/$cookie.id";
8668:
8669: if (tie(my %disk_env,'GDBM_File',"$lonids/$cookie.id",
8670: &GDBM_WRCREAT(),0640)) {
8671: &_add_to_env(\%disk_env,\%initial_env);
8672: &_add_to_env(\%disk_env,\%userenv,'environment.');
8673: &_add_to_env(\%disk_env,$userroles);
1.463 albertel 8674: if (ref($args->{'extra_env'})) {
8675: &_add_to_env(\%disk_env,$args->{'extra_env'});
8676: }
1.462 albertel 8677: untie(%disk_env);
8678: } else {
8679: &Apache::lonnet::logthis("<font color=\"blue\">WARNING: ".
8680: 'Could not create environment storage in lonauth: '.$!.'</font>');
8681: return 'error: '.$!;
8682: }
8683: }
8684: $env{'request.role'}='cm';
8685: $env{'request.role.adv'}=$env{'user.adv'};
8686: $env{'browser.type'}=$clientbrowser;
8687:
8688: return $cookie;
8689:
8690: }
8691:
8692: sub _add_to_env {
8693: my ($idf,$env_data,$prefix) = @_;
8694: while (my ($key,$value) = each(%$env_data)) {
8695: $idf->{$prefix.$key} = $value;
8696: $env{$prefix.$key} = $value;
8697: }
8698: }
8699:
8700:
1.41 ng 8701: =pod
8702:
8703: =back
8704:
1.112 bowersj2 8705: =cut
1.41 ng 8706:
1.112 bowersj2 8707: 1;
8708: __END__;
1.41 ng 8709:
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