Annotation of loncom/interface/loncommon.pm, revision 1.655
1.10 albertel 1: # The LearningOnline Network with CAPA
1.1 albertel 2: # a pile of common routines
1.10 albertel 3: #
1.655 ! raeburn 4: # $Id: loncommon.pm,v 1.654 2008/05/27 22:26:11 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:
1.648 raeburn 87: =head1 Server Side include with retries:
1.643 foxr 88:
89: =over 4
90:
1.648 raeburn 91: =item * &ssi_with_retries(resource,retries form)
1.643 foxr 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:
1.648 raeburn 98:
99: =over 4
100:
1.643 foxr 101: resource - Identifies the resource to insert.
1.648 raeburn 102:
1.643 foxr 103: retries - Count of the number of retries allowed.
1.648 raeburn 104:
1.643 foxr 105: form - Hash that identifies the rendering options.
106:
1.648 raeburn 107: =back
108:
109: Returns:
110:
111: =over 4
112:
1.643 foxr 113: content - The content of the response. If retries were exhausted this is empty.
1.648 raeburn 114:
1.643 foxr 115: response - The response from the last attempt (which may or may not have been successful.
116:
1.648 raeburn 117: =back
118:
119: =back
120:
1.643 foxr 121: =cut
122:
123: sub ssi_with_retries {
124: my ($resource, $retries, %form) = @_;
125:
126:
127: my $ok = 0; # True if we got a good response.
128: my $content;
129: my $response;
130:
131: # Try to get the ssi done. within the retries count:
132:
133: do {
134: ($content, $response) = &Apache::lonnet::ssi($resource, %form);
135: $ok = $response->is_success;
1.650 www 136: if (!$ok) {
137: &Apache::lonnet::logthis("Failed ssi_with_retries on $resource: ".$response->is_success.', '.$response->code.', '.$response->message);
138: }
1.643 foxr 139: $retries--;
140: } while (!$ok && ($retries > 0));
141:
142: if (!$ok) {
143: $content = ''; # On error return an empty content.
144: }
145: return ($content, $response);
146:
147: }
148:
149:
150:
1.20 www 151: # ----------------------------------------------- Filetypes/Languages/Copyright
1.12 harris41 152: my %language;
1.124 www 153: my %supported_language;
1.12 harris41 154: my %cprtag;
1.192 taceyjo1 155: my %scprtag;
1.351 www 156: my %fe; my %fd; my %fm;
1.41 ng 157: my %category_extensions;
1.12 harris41 158:
1.46 matthew 159: # ---------------------------------------------- Thesaurus variables
1.144 matthew 160: #
161: # %Keywords:
162: # A hash used by &keyword to determine if a word is considered a keyword.
163: # $thesaurus_db_file
164: # Scalar containing the full path to the thesaurus database.
1.46 matthew 165:
166: my %Keywords;
167: my $thesaurus_db_file;
168:
1.144 matthew 169: #
170: # Initialize values from language.tab, copyright.tab, filetypes.tab,
171: # thesaurus.tab, and filecategories.tab.
172: #
1.18 www 173: BEGIN {
1.46 matthew 174: # Variable initialization
175: $thesaurus_db_file = $Apache::lonnet::perlvar{'lonTabDir'}."/thesaurus.db";
176: #
1.22 www 177: unless ($readit) {
1.12 harris41 178: # ------------------------------------------------------------------- languages
179: {
1.158 raeburn 180: my $langtabfile = $Apache::lonnet::perlvar{'lonTabDir'}.
181: '/language.tab';
182: if ( open(my $fh,"<$langtabfile") ) {
1.356 albertel 183: while (my $line = <$fh>) {
184: next if ($line=~/^\#/);
185: chomp($line);
186: my ($key,$two,$country,$three,$enc,$val,$sup)=(split(/\t/,$line));
1.158 raeburn 187: $language{$key}=$val.' - '.$enc;
188: if ($sup) {
189: $supported_language{$key}=$sup;
190: }
191: }
192: close($fh);
193: }
1.12 harris41 194: }
195: # ------------------------------------------------------------------ copyrights
196: {
1.158 raeburn 197: my $copyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.
198: '/copyright.tab';
199: if ( open (my $fh,"<$copyrightfile") ) {
1.356 albertel 200: while (my $line = <$fh>) {
201: next if ($line=~/^\#/);
202: chomp($line);
203: my ($key,$val)=(split(/\s+/,$line,2));
1.158 raeburn 204: $cprtag{$key}=$val;
205: }
206: close($fh);
207: }
1.12 harris41 208: }
1.351 www 209: # ----------------------------------------------------------- source copyrights
1.192 taceyjo1 210: {
211: my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.
212: '/source_copyright.tab';
213: if ( open (my $fh,"<$sourcecopyrightfile") ) {
1.356 albertel 214: while (my $line = <$fh>) {
215: next if ($line =~ /^\#/);
216: chomp($line);
217: my ($key,$val)=(split(/\s+/,$line,2));
1.192 taceyjo1 218: $scprtag{$key}=$val;
219: }
220: close($fh);
221: }
222: }
1.63 www 223:
1.517 raeburn 224: # -------------------------------------------------------------- default domain designs
1.63 www 225: my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors';
1.517 raeburn 226: my $designfile = $designdir.'/default.tab';
227: if ( open (my $fh,"<$designfile") ) {
228: while (my $line = <$fh>) {
229: next if ($line =~ /^\#/);
230: chomp($line);
231: my ($key,$val)=(split(/\=/,$line));
232: if ($val) { $defaultdesign{$key}=$val; }
233: }
234: close($fh);
1.63 www 235: }
236:
1.15 harris41 237: # ------------------------------------------------------------- file categories
238: {
1.158 raeburn 239: my $categoryfile = $Apache::lonnet::perlvar{'lonTabDir'}.
240: '/filecategories.tab';
241: if ( open (my $fh,"<$categoryfile") ) {
1.356 albertel 242: while (my $line = <$fh>) {
243: next if ($line =~ /^\#/);
244: chomp($line);
245: my ($extension,$category)=(split(/\s+/,$line,2));
1.158 raeburn 246: push @{$category_extensions{lc($category)}},$extension;
247: }
248: close($fh);
249: }
250:
1.15 harris41 251: }
1.12 harris41 252: # ------------------------------------------------------------------ file types
253: {
1.158 raeburn 254: my $typesfile = $Apache::lonnet::perlvar{'lonTabDir'}.
255: '/filetypes.tab';
256: if ( open (my $fh,"<$typesfile") ) {
1.356 albertel 257: while (my $line = <$fh>) {
258: next if ($line =~ /^\#/);
259: chomp($line);
260: my ($ending,$emb,$mime,$descr)=split(/\s+/,$line,4);
1.158 raeburn 261: if ($descr ne '') {
262: $fe{$ending}=lc($emb);
263: $fd{$ending}=$descr;
1.351 www 264: if ($mime ne 'unk') { $fm{$ending}=$mime; }
1.158 raeburn 265: }
266: }
267: close($fh);
268: }
1.12 harris41 269: }
1.22 www 270: &Apache::lonnet::logthis(
1.46 matthew 271: "<font color=yellow>INFO: Read file types</font>");
1.22 www 272: $readit=1;
1.46 matthew 273: } # end of unless($readit)
1.32 matthew 274:
275: }
1.112 bowersj2 276:
1.42 matthew 277: ###############################################################
278: ## HTML and Javascript Helper Functions ##
279: ###############################################################
280:
281: =pod
282:
1.112 bowersj2 283: =head1 HTML and Javascript Functions
1.42 matthew 284:
1.112 bowersj2 285: =over 4
286:
1.648 raeburn 287: =item * &browser_and_searcher_javascript()
1.112 bowersj2 288:
289: X<browsing, javascript>X<searching, javascript>Returns a string
290: containing javascript with two functions, C<openbrowser> and
291: C<opensearcher>. Returned string does not contain E<lt>scriptE<gt>
292: tags.
1.42 matthew 293:
1.648 raeburn 294: =item * &openbrowser(formname,elementname,only,omit) [javascript]
1.42 matthew 295:
296: inputs: formname, elementname, only, omit
297:
298: formname and elementname indicate the name of the html form and name of
299: the element that the results of the browsing selection are to be placed in.
300:
301: Specifying 'only' will restrict the browser to displaying only files
1.185 www 302: with the given extension. Can be a comma separated list.
1.42 matthew 303:
304: Specifying 'omit' will restrict the browser to NOT displaying files
1.185 www 305: with the given extension. Can be a comma separated list.
1.42 matthew 306:
1.648 raeburn 307: =item * &opensearcher(formname,elementname) [javascript]
1.42 matthew 308:
309: Inputs: formname, elementname
310:
311: formname and elementname specify the name of the html form and the name
312: of the element the selection from the search results will be placed in.
1.542 raeburn 313:
1.42 matthew 314: =cut
315:
316: sub browser_and_searcher_javascript {
1.199 albertel 317: my ($mode)=@_;
318: if (!defined($mode)) { $mode='edit'; }
1.453 albertel 319: my $resurl=&escape_single(&lastresurl());
1.42 matthew 320: return <<END;
1.219 albertel 321: // <!-- BEGIN LON-CAPA Internal
1.50 matthew 322: var editbrowser = null;
1.135 albertel 323: function openbrowser(formname,elementname,only,omit,titleelement) {
1.170 www 324: var url = '$resurl/?';
1.42 matthew 325: if (editbrowser == null) {
326: url += 'launch=1&';
327: }
328: url += 'catalogmode=interactive&';
1.199 albertel 329: url += 'mode=$mode&';
1.611 albertel 330: url += 'inhibitmenu=yes&';
1.42 matthew 331: url += 'form=' + formname + '&';
332: if (only != null) {
333: url += 'only=' + only + '&';
1.217 albertel 334: } else {
335: url += 'only=&';
336: }
1.42 matthew 337: if (omit != null) {
338: url += 'omit=' + omit + '&';
1.217 albertel 339: } else {
340: url += 'omit=&';
341: }
1.135 albertel 342: if (titleelement != null) {
343: url += 'titleelement=' + titleelement + '&';
1.217 albertel 344: } else {
345: url += 'titleelement=&';
346: }
1.42 matthew 347: url += 'element=' + elementname + '';
348: var title = 'Browser';
1.435 albertel 349: var options = 'scrollbars=1,resizable=1,menubar=0,toolbar=1,location=1';
1.42 matthew 350: options += ',width=700,height=600';
351: editbrowser = open(url,title,options,'1');
352: editbrowser.focus();
353: }
354: var editsearcher;
1.135 albertel 355: function opensearcher(formname,elementname,titleelement) {
1.42 matthew 356: var url = '/adm/searchcat?';
357: if (editsearcher == null) {
358: url += 'launch=1&';
359: }
360: url += 'catalogmode=interactive&';
1.199 albertel 361: url += 'mode=$mode&';
1.42 matthew 362: url += 'form=' + formname + '&';
1.135 albertel 363: if (titleelement != null) {
364: url += 'titleelement=' + titleelement + '&';
1.217 albertel 365: } else {
366: url += 'titleelement=&';
367: }
1.42 matthew 368: url += 'element=' + elementname + '';
369: var title = 'Search';
1.435 albertel 370: var options = 'scrollbars=1,resizable=1,menubar=0,toolbar=1,location=1';
1.42 matthew 371: options += ',width=700,height=600';
372: editsearcher = open(url,title,options,'1');
373: editsearcher.focus();
374: }
1.219 albertel 375: // END LON-CAPA Internal -->
1.42 matthew 376: END
1.170 www 377: }
378:
379: sub lastresurl {
1.258 albertel 380: if ($env{'environment.lastresurl'}) {
381: return $env{'environment.lastresurl'}
1.170 www 382: } else {
383: return '/res';
384: }
385: }
386:
387: sub storeresurl {
388: my $resurl=&Apache::lonnet::clutter(shift);
389: unless ($resurl=~/^\/res/) { return 0; }
390: $resurl=~s/\/$//;
391: &Apache::lonnet::put('environment',{'lastresurl' => $resurl});
1.646 raeburn 392: &Apache::lonnet::appenv({'environment.lastresurl' => $resurl});
1.170 www 393: return 1;
1.42 matthew 394: }
395:
1.74 www 396: sub studentbrowser_javascript {
1.111 www 397: unless (
1.258 albertel 398: (($env{'request.course.id'}) &&
1.302 albertel 399: (&Apache::lonnet::allowed('srm',$env{'request.course.id'})
400: || &Apache::lonnet::allowed('srm',$env{'request.course.id'}.
401: '/'.$env{'request.course.sec'})
402: ))
1.258 albertel 403: || ($env{'request.role'}=~/^(au|dc|su)/)
1.111 www 404: ) { return ''; }
1.74 www 405: return (<<'ENDSTDBRW');
406: <script type="text/javascript" language="Javascript" >
407: var stdeditbrowser;
1.558 albertel 408: function openstdbrowser(formname,uname,udom,roleflag,ignorefilter) {
1.74 www 409: var url = '/adm/pickstudent?';
410: var filter;
1.558 albertel 411: if (!ignorefilter) {
412: eval('filter=document.'+formname+'.'+uname+'.value;');
413: }
1.74 www 414: if (filter != null) {
415: if (filter != '') {
416: url += 'filter='+filter+'&';
417: }
418: }
419: url += 'form=' + formname + '&unameelement='+uname+
420: '&udomelement='+udom;
1.111 www 421: if (roleflag) { url+="&roles=1"; }
1.102 www 422: var title = 'Student_Browser';
1.74 www 423: var options = 'scrollbars=1,resizable=1,menubar=0';
424: options += ',width=700,height=600';
425: stdeditbrowser = open(url,title,options,'1');
426: stdeditbrowser.focus();
427: }
428: </script>
429: ENDSTDBRW
430: }
1.42 matthew 431:
1.74 www 432: sub selectstudent_link {
1.111 www 433: my ($form,$unameele,$udomele)=@_;
1.258 albertel 434: if ($env{'request.course.id'}) {
1.302 albertel 435: if (!&Apache::lonnet::allowed('srm',$env{'request.course.id'})
436: && !&Apache::lonnet::allowed('srm',$env{'request.course.id'}.
437: '/'.$env{'request.course.sec'})) {
1.111 www 438: return '';
439: }
440: return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele.
1.607 albertel 441: '","'.$udomele.'");'."'>".&mt('Select User')."</a>";
1.74 www 442: }
1.258 albertel 443: if ($env{'request.role'}=~/^(au|dc|su)/) {
1.111 www 444: return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele.
1.119 www 445: '","'.$udomele.'",1);'."'>".&mt('Select User')."</a>";
1.111 www 446: }
447: return '';
1.91 www 448: }
449:
1.653 raeburn 450: sub authorbrowser_javascript {
451: return <<"ENDAUTHORBRW";
452: <script type="text/javascript">
453: var stdeditbrowser;
454:
455: function openauthorbrowser(formname,udom) {
456: var url = '/adm/pickauthor?';
457: url += 'form='+formname+'&roledom='+udom;
458: var title = 'Author_Browser';
459: var options = 'scrollbars=1,resizable=1,menubar=0';
460: options += ',width=700,height=600';
461: stdeditbrowser = open(url,title,options,'1');
462: stdeditbrowser.focus();
463: }
464:
465: </script>
466: ENDAUTHORBRW
467: }
468:
1.91 www 469: sub coursebrowser_javascript {
1.468 raeburn 470: my ($domainfilter,$sec_element,$formname)=@_;
1.377 raeburn 471: 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 472: my $output = '
1.538 albertel 473: <script type="text/javascript">
1.468 raeburn 474: var stdeditbrowser;'."\n";
475: $output .= <<"ENDSTDBRW";
1.377 raeburn 476: function opencrsbrowser(formname,uname,udom,desc,extra_element,multflag,crstype) {
1.91 www 477: var url = '/adm/pickcourse?';
1.468 raeburn 478: var domainfilter = '';
479: var formid = getFormIdByName(formname);
480: if (formid > -1) {
481: var domid = getIndexByName(formid,udom);
482: if (domid > -1) {
483: if (document.forms[formid].elements[domid].type == 'select-one') {
484: domainfilter=document.forms[formid].elements[domid].options[document.forms[formid].elements[domid].selectedIndex].value;
485: }
486: if (document.forms[formid].elements[domid].type == 'hidden') {
487: domainfilter=document.forms[formid].elements[domid].value;
488: }
489: }
1.91 www 490: }
1.128 albertel 491: if (domainfilter != null) {
492: if (domainfilter != '') {
493: url += 'domainfilter='+domainfilter+'&';
494: }
495: }
1.91 www 496: url += 'form=' + formname + '&cnumelement='+uname+
1.187 albertel 497: '&cdomelement='+udom+
498: '&cnameelement='+desc;
1.468 raeburn 499: if (extra_element !=null && extra_element != '') {
1.594 raeburn 500: if (formname == 'rolechoice' || formname == 'studentform') {
1.468 raeburn 501: url += '&roleelement='+extra_element;
502: if (domainfilter == null || domainfilter == '') {
503: url += '&domainfilter='+extra_element;
504: }
1.234 raeburn 505: }
1.468 raeburn 506: else {
507: if (formname == 'portform') {
508: url += '&setroles='+extra_element;
509: }
510: }
1.230 raeburn 511: }
1.293 raeburn 512: if (multflag !=null && multflag != '') {
513: url += '&multiple='+multflag;
514: }
1.377 raeburn 515: if (crstype == 'Course/Group') {
516: if (formname == 'cu') {
517: crstype = document.cu.crstype.options[document.cu.crstype.selectedIndex].value;
518: if (crstype == "") {
519: alert("$crs_or_grp_alert");
520: return;
521: }
522: }
523: }
524: if (crstype !=null && crstype != '') {
525: url += '&type='+crstype;
526: }
1.102 www 527: var title = 'Course_Browser';
1.91 www 528: var options = 'scrollbars=1,resizable=1,menubar=0';
529: options += ',width=700,height=600';
530: stdeditbrowser = open(url,title,options,'1');
531: stdeditbrowser.focus();
532: }
1.468 raeburn 533:
534: function getFormIdByName(formname) {
535: for (var i=0;i<document.forms.length;i++) {
536: if (document.forms[i].name == formname) {
537: return i;
538: }
539: }
540: return -1;
541: }
542:
543: function getIndexByName(formid,item) {
544: for (var i=0;i<document.forms[formid].elements.length;i++) {
545: if (document.forms[formid].elements[i].name == item) {
546: return i;
547: }
548: }
549: return -1;
550: }
1.91 www 551: ENDSTDBRW
1.468 raeburn 552: if ($sec_element ne '') {
553: $output .= &setsec_javascript($sec_element,$formname);
554: }
555: $output .= '
556: </script>';
557: return $output;
558: }
559:
560: sub setsec_javascript {
561: my ($sec_element,$formname) = @_;
562: my $setsections = qq|
563: function setSect(sectionlist) {
1.629 raeburn 564: var sectionsArray = new Array();
565: if ((sectionlist != '') && (typeof sectionlist != "undefined")) {
566: sectionsArray = sectionlist.split(",");
567: }
1.468 raeburn 568: var numSections = sectionsArray.length;
569: document.$formname.$sec_element.length = 0;
570: if (numSections == 0) {
571: document.$formname.$sec_element.multiple=false;
572: document.$formname.$sec_element.size=1;
573: document.$formname.$sec_element.options[0] = new Option('No existing sections','',false,false)
574: } else {
575: if (numSections == 1) {
576: document.$formname.$sec_element.multiple=false;
577: document.$formname.$sec_element.size=1;
578: document.$formname.$sec_element.options[0] = new Option('Select','',true,true);
579: document.$formname.$sec_element.options[1] = new Option('No section','',false,false)
580: document.$formname.$sec_element.options[2] = new Option(sectionsArray[0],sectionsArray[0],false,false);
581: } else {
582: for (var i=0; i<numSections; i++) {
583: document.$formname.$sec_element.options[i] = new Option(sectionsArray[i],sectionsArray[i],false,false)
584: }
585: document.$formname.$sec_element.multiple=true
586: if (numSections < 3) {
587: document.$formname.$sec_element.size=numSections;
588: } else {
589: document.$formname.$sec_element.size=3;
590: }
591: document.$formname.$sec_element.options[0].selected = false
592: }
593: }
1.91 www 594: }
1.468 raeburn 595: |;
596: return $setsections;
597: }
598:
1.91 www 599:
600: sub selectcourse_link {
1.377 raeburn 601: my ($form,$unameele,$udomele,$desc,$extra_element,$multflag,$selecttype)=@_;
1.492 albertel 602: return "<a href='".'javascript:opencrsbrowser("'.$form.'","'.$unameele.
603: '","'.$udomele.'","'.$desc.'","'.$extra_element.'","'.$multflag.'","'.$selecttype.'");'."'>".&mt('Select Course')."</a>";
1.74 www 604: }
1.42 matthew 605:
1.653 raeburn 606: sub selectauthor_link {
607: my ($form,$udom)=@_;
608: return '<a href="javascript:openauthorbrowser('."'$form','$udom'".');">'.
609: &mt('Select Author').'</a>';
610: }
611:
1.273 raeburn 612: sub check_uncheck_jscript {
613: my $jscript = <<"ENDSCRT";
614: function checkAll(field) {
615: if (field.length > 0) {
616: for (i = 0; i < field.length; i++) {
617: field[i].checked = true ;
618: }
619: } else {
620: field.checked = true
621: }
622: }
623:
624: function uncheckAll(field) {
625: if (field.length > 0) {
626: for (i = 0; i < field.length; i++) {
627: field[i].checked = false ;
1.543 albertel 628: }
629: } else {
1.273 raeburn 630: field.checked = false ;
631: }
632: }
633: ENDSCRT
634: return $jscript;
635: }
636:
637:
1.42 matthew 638: =pod
1.36 matthew 639:
1.648 raeburn 640: =item * &linked_select_forms(...)
1.36 matthew 641:
642: linked_select_forms returns a string containing a <script></script> block
643: and html for two <select> menus. The select menus will be linked in that
644: changing the value of the first menu will result in new values being placed
645: in the second menu. The values in the select menu will appear in alphabetical
1.609 raeburn 646: order unless a defined order is provided.
1.36 matthew 647:
648: linked_select_forms takes the following ordered inputs:
649:
650: =over 4
651:
1.112 bowersj2 652: =item * $formname, the name of the <form> tag
1.36 matthew 653:
1.112 bowersj2 654: =item * $middletext, the text which appears between the <select> tags
1.36 matthew 655:
1.112 bowersj2 656: =item * $firstdefault, the default value for the first menu
1.36 matthew 657:
1.112 bowersj2 658: =item * $firstselectname, the name of the first <select> tag
1.36 matthew 659:
1.112 bowersj2 660: =item * $secondselectname, the name of the second <select> tag
1.36 matthew 661:
1.112 bowersj2 662: =item * $hashref, a reference to a hash containing the data for the menus.
1.36 matthew 663:
1.609 raeburn 664: =item * $menuorder, the order of values in the first menu
665:
1.41 ng 666: =back
667:
1.36 matthew 668: Below is an example of such a hash. Only the 'text', 'default', and
669: 'select2' keys must appear as stated. keys(%menu) are the possible
670: values for the first select menu. The text that coincides with the
1.41 ng 671: first menu value is given in $menu{$choice1}->{'text'}. The values
1.36 matthew 672: and text for the second menu are given in the hash pointed to by
673: $menu{$choice1}->{'select2'}.
674:
1.112 bowersj2 675: my %menu = ( A1 => { text =>"Choice A1" ,
676: default => "B3",
677: select2 => {
678: B1 => "Choice B1",
679: B2 => "Choice B2",
680: B3 => "Choice B3",
681: B4 => "Choice B4"
1.609 raeburn 682: },
683: order => ['B4','B3','B1','B2'],
1.112 bowersj2 684: },
685: A2 => { text =>"Choice A2" ,
686: default => "C2",
687: select2 => {
688: C1 => "Choice C1",
689: C2 => "Choice C2",
690: C3 => "Choice C3"
1.609 raeburn 691: },
692: order => ['C2','C1','C3'],
1.112 bowersj2 693: },
694: A3 => { text =>"Choice A3" ,
695: default => "D6",
696: select2 => {
697: D1 => "Choice D1",
698: D2 => "Choice D2",
699: D3 => "Choice D3",
700: D4 => "Choice D4",
701: D5 => "Choice D5",
702: D6 => "Choice D6",
703: D7 => "Choice D7"
1.609 raeburn 704: },
705: order => ['D4','D3','D2','D1','D7','D6','D5'],
1.112 bowersj2 706: }
707: );
1.36 matthew 708:
709: =cut
710:
711: sub linked_select_forms {
712: my ($formname,
713: $middletext,
714: $firstdefault,
715: $firstselectname,
716: $secondselectname,
1.609 raeburn 717: $hashref,
718: $menuorder,
1.36 matthew 719: ) = @_;
720: my $second = "document.$formname.$secondselectname";
721: my $first = "document.$formname.$firstselectname";
722: # output the javascript to do the changing
723: my $result = '';
1.219 albertel 724: $result.="<script type=\"text/javascript\">\n";
1.36 matthew 725: $result.="var select2data = new Object();\n";
726: $" = '","';
727: my $debug = '';
728: foreach my $s1 (sort(keys(%$hashref))) {
729: $result.="select2data.d_$s1 = new Object();\n";
730: $result.="select2data.d_$s1.def = new String('".
731: $hashref->{$s1}->{'default'}."');\n";
1.609 raeburn 732: $result.="select2data.d_$s1.values = new Array(";
1.36 matthew 733: my @s2values = sort(keys( %{ $hashref->{$s1}->{'select2'} } ));
1.609 raeburn 734: if (ref($hashref->{$s1}->{'order'}) eq 'ARRAY') {
735: @s2values = @{$hashref->{$s1}->{'order'}};
736: }
1.36 matthew 737: $result.="\"@s2values\");\n";
738: $result.="select2data.d_$s1.texts = new Array(";
739: my @s2texts;
740: foreach my $value (@s2values) {
741: push @s2texts, $hashref->{$s1}->{'select2'}->{$value};
742: }
743: $result.="\"@s2texts\");\n";
744: }
745: $"=' ';
746: $result.= <<"END";
747:
748: function select1_changed() {
749: // Determine new choice
750: var newvalue = "d_" + $first.value;
751: // update select2
752: var values = select2data[newvalue].values;
753: var texts = select2data[newvalue].texts;
754: var select2def = select2data[newvalue].def;
755: var i;
756: // out with the old
757: for (i = 0; i < $second.options.length; i++) {
758: $second.options[i] = null;
759: }
760: // in with the nuclear
761: for (i=0;i<values.length; i++) {
762: $second.options[i] = new Option(values[i]);
1.143 matthew 763: $second.options[i].value = values[i];
1.36 matthew 764: $second.options[i].text = texts[i];
765: if (values[i] == select2def) {
766: $second.options[i].selected = true;
767: }
768: }
769: }
770: </script>
771: END
772: # output the initial values for the selection lists
773: $result .= "<select size=\"1\" name=\"$firstselectname\" onchange=\"select1_changed()\">\n";
1.609 raeburn 774: my @order = sort(keys(%{$hashref}));
775: if (ref($menuorder) eq 'ARRAY') {
776: @order = @{$menuorder};
777: }
778: foreach my $value (@order) {
1.36 matthew 779: $result.=" <option value=\"$value\" ";
1.253 albertel 780: $result.=" selected=\"selected\" " if ($value eq $firstdefault);
1.119 www 781: $result.=">".&mt($hashref->{$value}->{'text'})."</option>\n";
1.36 matthew 782: }
783: $result .= "</select>\n";
784: my %select2 = %{$hashref->{$firstdefault}->{'select2'}};
785: $result .= $middletext;
786: $result .= "<select size=\"1\" name=\"$secondselectname\">\n";
787: my $seconddefault = $hashref->{$firstdefault}->{'default'};
1.609 raeburn 788:
789: my @secondorder = sort(keys(%select2));
790: if (ref($hashref->{$firstdefault}->{'order'}) eq 'ARRAY') {
791: @secondorder = @{$hashref->{$firstdefault}->{'order'}};
792: }
793: foreach my $value (@secondorder) {
1.36 matthew 794: $result.=" <option value=\"$value\" ";
1.253 albertel 795: $result.=" selected=\"selected\" " if ($value eq $seconddefault);
1.119 www 796: $result.=">".&mt($select2{$value})."</option>\n";
1.36 matthew 797: }
798: $result .= "</select>\n";
799: # return $debug;
800: return $result;
801: } # end of sub linked_select_forms {
802:
1.45 matthew 803: =pod
1.44 bowersj2 804:
1.648 raeburn 805: =item * &help_open_topic($topic,$text,$stayOnPage,$width,$height)
1.44 bowersj2 806:
1.112 bowersj2 807: Returns a string corresponding to an HTML link to the given help
808: $topic, where $topic corresponds to the name of a .tex file in
809: /home/httpd/html/adm/help/tex, with underscores replaced by
810: spaces.
811:
812: $text will optionally be linked to the same topic, allowing you to
813: link text in addition to the graphic. If you do not want to link
814: text, but wish to specify one of the later parameters, pass an
815: empty string.
816:
817: $stayOnPage is a value that will be interpreted as a boolean. If true,
818: the link will not open a new window. If false, the link will open
819: a new window using Javascript. (Default is false.)
820:
821: $width and $height are optional numerical parameters that will
822: override the width and height of the popped up window, which may
823: be useful for certain help topics with big pictures included.
1.44 bowersj2 824:
825: =cut
826:
827: sub help_open_topic {
1.48 bowersj2 828: my ($topic, $text, $stayOnPage, $width, $height) = @_;
829: $text = "" if (not defined $text);
1.44 bowersj2 830: $stayOnPage = 0 if (not defined $stayOnPage);
1.552 banghart 831: if ($env{'browser.interface'} eq 'textual') {
1.79 www 832: $stayOnPage=1;
833: }
1.44 bowersj2 834: $width = 350 if (not defined $width);
835: $height = 400 if (not defined $height);
836: my $filename = $topic;
837: $filename =~ s/ /_/g;
838:
1.48 bowersj2 839: my $template = "";
840: my $link;
1.572 banghart 841:
1.159 www 842: $topic=~s/\W/\_/g;
1.44 bowersj2 843:
1.572 banghart 844: if (!$stayOnPage) {
1.72 bowersj2 845: $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 846: } else {
1.48 bowersj2 847: $link = "/adm/help/${filename}.hlp";
848: }
849:
850: # Add the text
1.572 banghart 851: if ($text ne "") {
1.77 www 852: $template .=
1.572 banghart 853: "<table bgcolor='#3333AA' cellspacing='1' cellpadding='1' border='0'><tr>".
854: "<td bgcolor='#5555FF'><a target=\"_top\" href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";
1.48 bowersj2 855: }
856:
857: # Add the graphic
1.179 matthew 858: my $title = &mt('Online Help');
1.649 www 859: my $helpicon=&lonhttpdurl("/res/adm/pages/help.png");
1.48 bowersj2 860: $template .= <<"ENDTEMPLATE";
1.436 albertel 861: <a target="_top" href="$link" title="$title"><img src="$helpicon" border="0" alt="(Help: $topic)" /></a>
1.44 bowersj2 862: ENDTEMPLATE
1.78 www 863: if ($text ne '') { $template.='</td></tr></table>' };
1.44 bowersj2 864: return $template;
865:
1.106 bowersj2 866: }
867:
868: # This is a quicky function for Latex cheatsheet editing, since it
869: # appears in at least four places
870: sub helpLatexCheatsheet {
871: my $other = shift;
872: my $addOther = '';
873: if ($other) {
874: $addOther = Apache::loncommon::help_open_topic($other, shift,
875: undef, undef, 600) .
876: '</td><td>';
877: }
878: return '<table><tr><td>'.
879: $addOther .
1.636 raeburn 880: &Apache::loncommon::help_open_topic("Greek_Symbols",&mt('Greek Symbols'),
1.106 bowersj2 881: undef,undef,600)
882: .'</td><td>'.
1.636 raeburn 883: &Apache::loncommon::help_open_topic("Other_Symbols",&mt('Other Symbols'),
1.106 bowersj2 884: undef,undef,600)
885: .'</td></tr></table>';
1.172 www 886: }
887:
1.430 albertel 888: sub general_help {
889: my $helptopic='Student_Intro';
890: if ($env{'request.role'}=~/^(ca|au)/) {
891: $helptopic='Authoring_Intro';
892: } elsif ($env{'request.role'}=~/^cc/) {
893: $helptopic='Course_Coordination_Intro';
894: }
895: return $helptopic;
896: }
897:
898: sub update_help_link {
899: my ($topic,$component_help,$faq,$bug,$stayOnPage) = @_;
900: my $origurl = $ENV{'REQUEST_URI'};
901: $origurl=~s|^/~|/priv/|;
902: my $timestamp = time;
903: foreach my $datum (\$topic,\$component_help,\$faq,\$bug,\$origurl) {
904: $$datum = &escape($$datum);
905: }
906:
907: my $banner_link = "/adm/helpmenu?page=banner&topic=$topic&component_help=$component_help&faq=$faq&bug=$bug&origurl=$origurl&stamp=$timestamp&stayonpage=$stayOnPage";
908: my $output .= <<"ENDOUTPUT";
909: <script type="text/javascript">
910: banner_link = '$banner_link';
911: </script>
912: ENDOUTPUT
913: return $output;
914: }
915:
916: # now just updates the help link and generates a blue icon
1.193 raeburn 917: sub help_open_menu {
1.430 albertel 918: my ($topic,$component_help,$faq,$bug,$stayOnPage,$width,$height,$text)
1.552 banghart 919: = @_;
1.430 albertel 920: $stayOnPage = 0 if (not defined $stayOnPage);
1.572 banghart 921: # only use pop-up help (stayOnPage == 0)
1.552 banghart 922: # if environment.remote is on (using remote control UI)
1.572 banghart 923: if ($env{'browser.interface'} eq 'textual' ||
924: $env{'environment.remote'} eq 'off' ) {
1.552 banghart 925: $stayOnPage=1;
1.430 albertel 926: }
927: my $output;
928: if ($component_help) {
929: if (!$text) {
930: $output=&help_open_topic($component_help,undef,$stayOnPage,
931: $width,$height);
932: } else {
933: my $help_text;
934: $help_text=&unescape($topic);
935: $output='<table><tr><td>'.
936: &help_open_topic($component_help,$help_text,$stayOnPage,
937: $width,$height).'</td></tr></table>';
938: }
939: }
940: my $banner_link = &update_help_link($topic,$component_help,$faq,$bug,$stayOnPage);
941: return $output.$banner_link;
942: }
943:
944: sub top_nav_help {
945: my ($text) = @_;
1.436 albertel 946: $text = &mt($text);
1.572 banghart 947: my $stay_on_page =
1.436 albertel 948: ($env{'browser.interface'} eq 'textual' ||
949: $env{'environment.remote'} eq 'off' );
1.572 banghart 950: my $link = ($stay_on_page) ? "javascript:helpMenu('display')"
1.436 albertel 951: : "javascript:helpMenu('open')";
1.572 banghart 952: my $banner_link = &update_help_link(undef,undef,undef,undef,$stay_on_page);
1.436 albertel 953:
1.201 raeburn 954: my $title = &mt('Get help');
1.436 albertel 955:
956: return <<"END";
957: $banner_link
958: <a href="$link" title="$title">$text</a>
959: END
960: }
961:
962: sub help_menu_js {
963: my ($text) = @_;
964:
965: my $stayOnPage =
966: ($env{'browser.interface'} eq 'textual' ||
967: $env{'environment.remote'} eq 'off' );
968:
969: my $width = 620;
970: my $height = 600;
1.430 albertel 971: my $helptopic=&general_help();
972: my $details_link = '/adm/help/'.$helptopic.'.hlp';
1.261 albertel 973: my $nothing=&Apache::lonhtmlcommon::javascript_nothing();
1.331 albertel 974: my $start_page =
975: &Apache::loncommon::start_page('Help Menu', undef,
976: {'frameset' => 1,
977: 'js_ready' => 1,
978: 'add_entries' => {
979: 'border' => '0',
1.579 raeburn 980: 'rows' => "110,*",},});
1.331 albertel 981: my $end_page =
982: &Apache::loncommon::end_page({'frameset' => 1,
983: 'js_ready' => 1,});
984:
1.436 albertel 985: my $template .= <<"ENDTEMPLATE";
986: <script type="text/javascript">
1.253 albertel 987: // <!-- BEGIN LON-CAPA Internal
988: // <![CDATA[
1.430 albertel 989: var banner_link = '';
1.243 raeburn 990: function helpMenu(target) {
991: var caller = this;
992: if (target == 'open') {
993: var newWindow = null;
994: try {
1.262 albertel 995: newWindow = window.open($nothing,"helpmenu","HEIGHT=$height,WIDTH=$width,resizable=yes,scrollbars=yes" )
1.243 raeburn 996: }
997: catch(error) {
998: writeHelp(caller);
999: return;
1000: }
1001: if (newWindow) {
1002: caller = newWindow;
1003: }
1.193 raeburn 1004: }
1.243 raeburn 1005: writeHelp(caller);
1006: return;
1007: }
1008: function writeHelp(caller) {
1.430 albertel 1009: caller.document.writeln('$start_page<frame name="bannerframe" src="'+banner_link+'" /><frame name="bodyframe" src="$details_link" /> $end_page')
1.243 raeburn 1010: caller.document.close()
1011: caller.focus()
1.193 raeburn 1012: }
1.253 albertel 1013: // ]]>
1.219 albertel 1014: // END LON-CAPA Internal -->
1.436 albertel 1015: </script>
1.193 raeburn 1016: ENDTEMPLATE
1017: return $template;
1018: }
1019:
1.172 www 1020: sub help_open_bug {
1021: my ($topic, $text, $stayOnPage, $width, $height) = @_;
1.258 albertel 1022: unless ($env{'user.adv'}) { return ''; }
1.172 www 1023: unless ($Apache::lonnet::perlvar{'BugzillaHost'}) { return ''; }
1024: $text = "" if (not defined $text);
1025: $stayOnPage = 0 if (not defined $stayOnPage);
1.258 albertel 1026: if ($env{'browser.interface'} eq 'textual' ||
1027: $env{'environment.remote'} eq 'off' ) {
1.172 www 1028: $stayOnPage=1;
1029: }
1.184 albertel 1030: $width = 600 if (not defined $width);
1031: $height = 600 if (not defined $height);
1.172 www 1032:
1033: $topic=~s/\W+/\+/g;
1034: my $link='';
1035: my $template='';
1.379 albertel 1036: my $url=$Apache::lonnet::perlvar{'BugzillaHost'}.'enter_bug.cgi?product=LON-CAPA&bug_file_loc='.
1037: &escape($ENV{'REQUEST_URI'}).'&component='.$topic;
1.172 www 1038: if (!$stayOnPage)
1039: {
1040: $link = "javascript:void(open('$url', 'Bugzilla', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))";
1041: }
1042: else
1043: {
1044: $link = $url;
1045: }
1046: # Add the text
1047: if ($text ne "")
1048: {
1049: $template .=
1050: "<table bgcolor='#AA3333' cellspacing='1' cellpadding='1' border='0'><tr>".
1.436 albertel 1051: "<td bgcolor='#FF5555'><a target=\"_top\" href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";
1.172 www 1052: }
1053:
1054: # Add the graphic
1.179 matthew 1055: my $title = &mt('Report a Bug');
1.215 albertel 1056: my $bugicon=&lonhttpdurl("/adm/lonMisc/smallBug.gif");
1.172 www 1057: $template .= <<"ENDTEMPLATE";
1.436 albertel 1058: <a target="_top" href="$link" title="$title"><img src="$bugicon" border="0" alt="(Bug: $topic)" /></a>
1.172 www 1059: ENDTEMPLATE
1060: if ($text ne '') { $template.='</td></tr></table>' };
1061: return $template;
1062:
1063: }
1064:
1065: sub help_open_faq {
1066: my ($topic, $text, $stayOnPage, $width, $height) = @_;
1.258 albertel 1067: unless ($env{'user.adv'}) { return ''; }
1.172 www 1068: unless ($Apache::lonnet::perlvar{'FAQHost'}) { return ''; }
1069: $text = "" if (not defined $text);
1070: $stayOnPage = 0 if (not defined $stayOnPage);
1.258 albertel 1071: if ($env{'browser.interface'} eq 'textual' ||
1072: $env{'environment.remote'} eq 'off' ) {
1.172 www 1073: $stayOnPage=1;
1074: }
1075: $width = 350 if (not defined $width);
1076: $height = 400 if (not defined $height);
1077:
1078: $topic=~s/\W+/\+/g;
1079: my $link='';
1080: my $template='';
1081: my $url=$Apache::lonnet::perlvar{'FAQHost'}.'/fom/cache/'.$topic.'.html';
1082: if (!$stayOnPage)
1083: {
1084: $link = "javascript:void(open('$url', 'FAQ-O-Matic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))";
1085: }
1086: else
1087: {
1088: $link = $url;
1089: }
1090:
1091: # Add the text
1092: if ($text ne "")
1093: {
1094: $template .=
1.173 www 1095: "<table bgcolor='#337733' cellspacing='1' cellpadding='1' border='0'><tr>".
1.436 albertel 1096: "<td bgcolor='#448844'><a target=\"_top\" href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";
1.172 www 1097: }
1098:
1099: # Add the graphic
1.179 matthew 1100: my $title = &mt('View the FAQ');
1.215 albertel 1101: my $faqicon=&lonhttpdurl("/adm/lonMisc/smallFAQ.gif");
1.172 www 1102: $template .= <<"ENDTEMPLATE";
1.436 albertel 1103: <a target="_top" href="$link" title="$title"><img src="$faqicon" border="0" alt="(FAQ: $topic)" /></a>
1.172 www 1104: ENDTEMPLATE
1105: if ($text ne '') { $template.='</td></tr></table>' };
1106: return $template;
1107:
1.44 bowersj2 1108: }
1.37 matthew 1109:
1.180 matthew 1110: ###############################################################
1111: ###############################################################
1112:
1.45 matthew 1113: =pod
1114:
1.648 raeburn 1115: =item * &change_content_javascript():
1.256 matthew 1116:
1117: This and the next function allow you to create small sections of an
1118: otherwise static HTML page that you can update on the fly with
1119: Javascript, even in Netscape 4.
1120:
1121: The Javascript fragment returned by this function (no E<lt>scriptE<gt> tag)
1122: must be written to the HTML page once. It will prove the Javascript
1123: function "change(name, content)". Calling the change function with the
1124: name of the section
1125: you want to update, matching the name passed to C<changable_area>, and
1126: the new content you want to put in there, will put the content into
1127: that area.
1128:
1129: B<Note>: Netscape 4 only reserves enough space for the changable area
1130: to contain room for the original contents. You need to "make space"
1131: for whatever changes you wish to make, and be B<sure> to check your
1132: code in Netscape 4. This feature in Netscape 4 is B<not> powerful;
1133: it's adequate for updating a one-line status display, but little more.
1134: This script will set the space to 100% width, so you only need to
1135: worry about height in Netscape 4.
1136:
1137: Modern browsers are much less limiting, and if you can commit to the
1138: user not using Netscape 4, this feature may be used freely with
1139: pretty much any HTML.
1140:
1141: =cut
1142:
1143: sub change_content_javascript {
1144: # If we're on Netscape 4, we need to use Layer-based code
1.258 albertel 1145: if ($env{'browser.type'} eq 'netscape' &&
1146: $env{'browser.version'} =~ /^4\./) {
1.256 matthew 1147: return (<<NETSCAPE4);
1148: function change(name, content) {
1149: doc = document.layers[name+"___escape"].layers[0].document;
1150: doc.open();
1151: doc.write(content);
1152: doc.close();
1153: }
1154: NETSCAPE4
1155: } else {
1156: # Otherwise, we need to use semi-standards-compliant code
1157: # (technically, "innerHTML" isn't standard but the equivalent
1158: # is really scary, and every useful browser supports it
1159: return (<<DOMBASED);
1160: function change(name, content) {
1161: element = document.getElementById(name);
1162: element.innerHTML = content;
1163: }
1164: DOMBASED
1165: }
1166: }
1167:
1168: =pod
1169:
1.648 raeburn 1170: =item * &changable_area($name,$origContent):
1.256 matthew 1171:
1172: This provides a "changable area" that can be modified on the fly via
1173: the Javascript code provided in C<change_content_javascript>. $name is
1174: the name you will use to reference the area later; do not repeat the
1175: same name on a given HTML page more then once. $origContent is what
1176: the area will originally contain, which can be left blank.
1177:
1178: =cut
1179:
1180: sub changable_area {
1181: my ($name, $origContent) = @_;
1182:
1.258 albertel 1183: if ($env{'browser.type'} eq 'netscape' &&
1184: $env{'browser.version'} =~ /^4\./) {
1.256 matthew 1185: # If this is netscape 4, we need to use the Layer tag
1186: return "<ilayer width='100%' id='${name}___escape' overflow='none'><layer width='100%' id='$name' overflow='none'>$origContent</layer></ilayer>";
1187: } else {
1188: return "<span id='$name'>$origContent</span>";
1189: }
1190: }
1191:
1192: =pod
1193:
1.648 raeburn 1194: =item * &viewport_geometry_js
1.590 raeburn 1195:
1196: Provides javascript object (Geometry) which can provide information about the viewport geometry for the client browser.
1197:
1198: =cut
1199:
1200:
1201: sub viewport_geometry_js {
1202: return <<"GEOMETRY";
1203: var Geometry = {};
1204: function init_geometry() {
1205: if (Geometry.init) { return };
1206: Geometry.init=1;
1207: if (window.innerHeight) {
1208: Geometry.getViewportHeight = function() { return window.innerHeight; };
1209: Geometry.getViewportWidth = function() { return window.innerWidth; };
1210: Geometry.getHorizontalScroll = function() { return window.pageXOffset; };
1211: Geometry.getVerticalScroll = function() { return window.pageYOffset; };
1212: }
1213: else if (document.documentElement && document.documentElement.clientHeight) {
1214: Geometry.getViewportHeight =
1215: function() { return document.documentElement.clientHeight; };
1216: Geometry.getViewportWidth =
1217: function() { return document.documentElement.clientWidth; };
1218:
1219: Geometry.getHorizontalScroll =
1220: function() { return document.documentElement.scrollLeft; };
1221: Geometry.getVerticalScroll =
1222: function() { return document.documentElement.scrollTop; };
1223: }
1224: else if (document.body.clientHeight) {
1225: Geometry.getViewportHeight =
1226: function() { return document.body.clientHeight; };
1227: Geometry.getViewportWidth =
1228: function() { return document.body.clientWidth; };
1229: Geometry.getHorizontalScroll =
1230: function() { return document.body.scrollLeft; };
1231: Geometry.getVerticalScroll =
1232: function() { return document.body.scrollTop; };
1233: }
1234: }
1235:
1236: GEOMETRY
1237: }
1238:
1239: =pod
1240:
1.648 raeburn 1241: =item * &viewport_size_js()
1.590 raeburn 1242:
1243: 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.
1244:
1245: =cut
1246:
1247: sub viewport_size_js {
1248: my $geometry = &viewport_geometry_js();
1249: return <<"DIMS";
1250:
1251: $geometry
1252:
1253: function getViewportDims(width,height) {
1254: init_geometry();
1255: width.value = Geometry.getViewportWidth();
1256: height.value = Geometry.getViewportHeight();
1257: return;
1258: }
1259:
1260: DIMS
1261: }
1262:
1263: =pod
1264:
1.648 raeburn 1265: =item * &resize_textarea_js()
1.565 albertel 1266:
1267: emits the needed javascript to resize a textarea to be as big as possible
1268:
1269: creates a function resize_textrea that takes two IDs first should be
1270: the id of the element to resize, second should be the id of a div that
1271: surrounds everything that comes after the textarea, this routine needs
1272: to be attached to the <body> for the onload and onresize events.
1273:
1.648 raeburn 1274: =back
1.565 albertel 1275:
1276: =cut
1277:
1278: sub resize_textarea_js {
1.590 raeburn 1279: my $geometry = &viewport_geometry_js();
1.565 albertel 1280: return <<"RESIZE";
1281: <script type="text/javascript">
1.590 raeburn 1282: $geometry
1.565 albertel 1283:
1.588 albertel 1284: function getX(element) {
1285: var x = 0;
1286: while (element) {
1287: x += element.offsetLeft;
1288: element = element.offsetParent;
1289: }
1290: return x;
1291: }
1292: function getY(element) {
1293: var y = 0;
1294: while (element) {
1295: y += element.offsetTop;
1296: element = element.offsetParent;
1297: }
1298: return y;
1299: }
1300:
1301:
1.565 albertel 1302: function resize_textarea(textarea_id,bottom_id) {
1303: init_geometry();
1304: var textarea = document.getElementById(textarea_id);
1305: //alert(textarea);
1306:
1.588 albertel 1307: var textarea_top = getY(textarea);
1.565 albertel 1308: var textarea_height = textarea.offsetHeight;
1309: var bottom = document.getElementById(bottom_id);
1.588 albertel 1310: var bottom_top = getY(bottom);
1.565 albertel 1311: var bottom_height = bottom.offsetHeight;
1312: var window_height = Geometry.getViewportHeight();
1.588 albertel 1313: var fudge = 23;
1.565 albertel 1314: var new_height = window_height-fudge-textarea_top-bottom_height;
1315: if (new_height < 300) {
1316: new_height = 300;
1317: }
1318: textarea.style.height=new_height+'px';
1319: }
1320: </script>
1321: RESIZE
1322:
1323: }
1324:
1325: =pod
1326:
1.256 matthew 1327: =head1 Excel and CSV file utility routines
1328:
1329: =over 4
1330:
1331: =cut
1332:
1333: ###############################################################
1334: ###############################################################
1335:
1336: =pod
1337:
1.648 raeburn 1338: =item * &csv_translate($text)
1.37 matthew 1339:
1.185 www 1340: Translate $text to allow it to be output as a 'comma separated values'
1.37 matthew 1341: format.
1342:
1343: =cut
1344:
1.180 matthew 1345: ###############################################################
1346: ###############################################################
1.37 matthew 1347: sub csv_translate {
1348: my $text = shift;
1349: $text =~ s/\"/\"\"/g;
1.209 albertel 1350: $text =~ s/\n/ /g;
1.37 matthew 1351: return $text;
1352: }
1.180 matthew 1353:
1354: ###############################################################
1355: ###############################################################
1356:
1357: =pod
1358:
1.648 raeburn 1359: =item * &define_excel_formats()
1.180 matthew 1360:
1361: Define some commonly used Excel cell formats.
1362:
1363: Currently supported formats:
1364:
1365: =over 4
1366:
1367: =item header
1368:
1369: =item bold
1370:
1371: =item h1
1372:
1373: =item h2
1374:
1375: =item h3
1376:
1.256 matthew 1377: =item h4
1378:
1379: =item i
1380:
1.180 matthew 1381: =item date
1382:
1383: =back
1384:
1385: Inputs: $workbook
1386:
1387: Returns: $format, a hash reference.
1388:
1389: =cut
1390:
1391: ###############################################################
1392: ###############################################################
1393: sub define_excel_formats {
1394: my ($workbook) = @_;
1395: my $format;
1396: $format->{'header'} = $workbook->add_format(bold => 1,
1397: bottom => 1,
1398: align => 'center');
1399: $format->{'bold'} = $workbook->add_format(bold=>1);
1400: $format->{'h1'} = $workbook->add_format(bold=>1, size=>18);
1401: $format->{'h2'} = $workbook->add_format(bold=>1, size=>16);
1402: $format->{'h3'} = $workbook->add_format(bold=>1, size=>14);
1.255 matthew 1403: $format->{'h4'} = $workbook->add_format(bold=>1, size=>12);
1.246 matthew 1404: $format->{'i'} = $workbook->add_format(italic=>1);
1.180 matthew 1405: $format->{'date'} = $workbook->add_format(num_format=>
1.207 matthew 1406: 'mm/dd/yyyy hh:mm:ss');
1.180 matthew 1407: return $format;
1408: }
1409:
1410: ###############################################################
1411: ###############################################################
1.113 bowersj2 1412:
1413: =pod
1414:
1.648 raeburn 1415: =item * &create_workbook()
1.255 matthew 1416:
1417: Create an Excel worksheet. If it fails, output message on the
1418: request object and return undefs.
1419:
1420: Inputs: Apache request object
1421:
1422: Returns (undef) on failure,
1423: Excel worksheet object, scalar with filename, and formats
1424: from &Apache::loncommon::define_excel_formats on success
1425:
1426: =cut
1427:
1428: ###############################################################
1429: ###############################################################
1430: sub create_workbook {
1431: my ($r) = @_;
1432: #
1433: # Create the excel spreadsheet
1434: my $filename = '/prtspool/'.
1.258 albertel 1435: $env{'user.name'}.'_'.$env{'user.domain'}.'_'.
1.255 matthew 1436: time.'_'.rand(1000000000).'.xls';
1437: my $workbook = Spreadsheet::WriteExcel->new('/home/httpd'.$filename);
1438: if (! defined($workbook)) {
1439: $r->log_error("Error creating excel spreadsheet $filename: $!");
1440: $r->print('<p>'.&mt("Unable to create new Excel file. ".
1441: "This error has been logged. ".
1442: "Please alert your LON-CAPA administrator").
1443: '</p>');
1444: return (undef);
1445: }
1446: #
1447: $workbook->set_tempdir('/home/httpd/perl/tmp');
1448: #
1449: my $format = &Apache::loncommon::define_excel_formats($workbook);
1450: return ($workbook,$filename,$format);
1451: }
1452:
1453: ###############################################################
1454: ###############################################################
1455:
1456: =pod
1457:
1.648 raeburn 1458: =item * &create_text_file()
1.113 bowersj2 1459:
1.542 raeburn 1460: Create a file to write to and eventually make available to the user.
1.256 matthew 1461: If file creation fails, outputs an error message on the request object and
1462: return undefs.
1.113 bowersj2 1463:
1.256 matthew 1464: Inputs: Apache request object, and file suffix
1.113 bowersj2 1465:
1.256 matthew 1466: Returns (undef) on failure,
1467: Filehandle and filename on success.
1.113 bowersj2 1468:
1469: =cut
1470:
1.256 matthew 1471: ###############################################################
1472: ###############################################################
1473: sub create_text_file {
1474: my ($r,$suffix) = @_;
1475: if (! defined($suffix)) { $suffix = 'txt'; };
1476: my $fh;
1477: my $filename = '/prtspool/'.
1.258 albertel 1478: $env{'user.name'}.'_'.$env{'user.domain'}.'_'.
1.256 matthew 1479: time.'_'.rand(1000000000).'.'.$suffix;
1480: $fh = Apache::File->new('>/home/httpd'.$filename);
1481: if (! defined($fh)) {
1482: $r->log_error("Couldn't open $filename for output $!");
1483: $r->print("Problems occured in creating the output file. ".
1484: "This error has been logged. ".
1485: "Please alert your LON-CAPA administrator.");
1.113 bowersj2 1486: }
1.256 matthew 1487: return ($fh,$filename)
1.113 bowersj2 1488: }
1489:
1490:
1.256 matthew 1491: =pod
1.113 bowersj2 1492:
1493: =back
1494:
1495: =cut
1.37 matthew 1496:
1497: ###############################################################
1.33 matthew 1498: ## Home server <option> list generating code ##
1499: ###############################################################
1.35 matthew 1500:
1.169 www 1501: # ------------------------------------------
1502:
1503: sub domain_select {
1504: my ($name,$value,$multiple)=@_;
1505: my %domains=map {
1.514 albertel 1506: $_ => $_.' '. &Apache::lonnet::domain($_,'description')
1.512 albertel 1507: } &Apache::lonnet::all_domains();
1.169 www 1508: if ($multiple) {
1509: $domains{''}=&mt('Any domain');
1.550 albertel 1510: $domains{'select_form_order'} = [sort {lc($a) cmp lc($b) } (keys(%domains))];
1.287 albertel 1511: return &multiple_select_form($name,$value,4,\%domains);
1.169 www 1512: } else {
1.550 albertel 1513: $domains{'select_form_order'} = [sort {lc($a) cmp lc($b) } (keys(%domains))];
1.169 www 1514: return &select_form($name,$value,%domains);
1515: }
1516: }
1517:
1.282 albertel 1518: #-------------------------------------------
1519:
1520: =pod
1521:
1.519 raeburn 1522: =head1 Routines for form select boxes
1523:
1524: =over 4
1525:
1.648 raeburn 1526: =item * &multiple_select_form($name,$value,$size,$hash,$order)
1.282 albertel 1527:
1528: Returns a string containing a <select> element int multiple mode
1529:
1530:
1531: Args:
1532: $name - name of the <select> element
1.506 raeburn 1533: $value - scalar or array ref of values that should already be selected
1.282 albertel 1534: $size - number of rows long the select element is
1.283 albertel 1535: $hash - the elements should be 'option' => 'shown text'
1.282 albertel 1536: (shown text should already have been &mt())
1.506 raeburn 1537: $order - (optional) array ref of the order to show the elements in
1.283 albertel 1538:
1.282 albertel 1539: =cut
1540:
1541: #-------------------------------------------
1.169 www 1542: sub multiple_select_form {
1.284 albertel 1543: my ($name,$value,$size,$hash,$order)=@_;
1.169 www 1544: my %selected = map { $_ => 1 } ref($value)?@{$value}:($value);
1545: my $output='';
1.191 matthew 1546: if (! defined($size)) {
1547: $size = 4;
1.283 albertel 1548: if (scalar(keys(%$hash))<4) {
1549: $size = scalar(keys(%$hash));
1.191 matthew 1550: }
1551: }
1.169 www 1552: $output.="\n<select name='$name' size='$size' multiple='1'>";
1.501 banghart 1553: my @order;
1.506 raeburn 1554: if (ref($order) eq 'ARRAY') {
1555: @order = @{$order};
1556: } else {
1557: @order = sort(keys(%$hash));
1.501 banghart 1558: }
1559: if (exists($$hash{'select_form_order'})) {
1560: @order = @{$$hash{'select_form_order'}};
1561: }
1562:
1.284 albertel 1563: foreach my $key (@order) {
1.356 albertel 1564: $output.='<option value="'.&HTML::Entities::encode($key,'"<>&').'" ';
1.284 albertel 1565: $output.='selected="selected" ' if ($selected{$key});
1566: $output.='>'.$hash->{$key}."</option>\n";
1.169 www 1567: }
1568: $output.="</select>\n";
1569: return $output;
1570: }
1571:
1.88 www 1572: #-------------------------------------------
1573:
1574: =pod
1575:
1.648 raeburn 1576: =item * &select_form($defdom,$name,%hash)
1.88 www 1577:
1578: Returns a string containing a <select name='$name' size='1'> form to
1579: allow a user to select options from a hash option_name => displayed text.
1580: See lonrights.pm for an example invocation and use.
1581:
1582: =cut
1583:
1584: #-------------------------------------------
1585: sub select_form {
1586: my ($def,$name,%hash) = @_;
1587: my $selectform = "<select name=\"$name\" size=\"1\">\n";
1.128 albertel 1588: my @keys;
1589: if (exists($hash{'select_form_order'})) {
1590: @keys=@{$hash{'select_form_order'}};
1591: } else {
1592: @keys=sort(keys(%hash));
1593: }
1.356 albertel 1594: foreach my $key (@keys) {
1595: $selectform.=
1596: '<option value="'.&HTML::Entities::encode($key,'"<>&').'" '.
1597: ($key eq $def ? 'selected="selected" ' : '').
1598: ">".&mt($hash{$key})."</option>\n";
1.88 www 1599: }
1600: $selectform.="</select>";
1601: return $selectform;
1602: }
1603:
1.475 www 1604: # For display filters
1605:
1606: sub display_filter {
1607: if (!$env{'form.show'}) { $env{'form.show'}=10; }
1.477 www 1608: if (!$env{'form.displayfilter'}) { $env{'form.displayfilter'}='currentfolder'; }
1.475 www 1609: return '<nobr><label>'.&mt('Records [_1]',
1610: &Apache::lonmeta::selectbox('show',$env{'form.show'},undef,
1611: (&mt('all'),10,20,50,100,1000,10000))).
1.478 www 1612: '</label></nobr> <nobr>'.
1.475 www 1613: &mt('Filter [_1]',
1.477 www 1614: &select_form($env{'form.displayfilter'},
1615: 'displayfilter',
1616: ('currentfolder' => 'Current folder/page',
1617: 'containing' => 'Containing phrase',
1618: 'none' => 'None'))).
1.478 www 1619: '<input type="text" name="containingphrase" size="30" value="'.&HTML::Entities::encode($env{'form.containingphrase'}).'" /></nobr>';
1.475 www 1620: }
1621:
1.167 www 1622: sub gradeleveldescription {
1623: my $gradelevel=shift;
1624: my %gradelevels=(0 => 'Not specified',
1625: 1 => 'Grade 1',
1626: 2 => 'Grade 2',
1627: 3 => 'Grade 3',
1628: 4 => 'Grade 4',
1629: 5 => 'Grade 5',
1630: 6 => 'Grade 6',
1631: 7 => 'Grade 7',
1632: 8 => 'Grade 8',
1633: 9 => 'Grade 9',
1634: 10 => 'Grade 10',
1635: 11 => 'Grade 11',
1636: 12 => 'Grade 12',
1637: 13 => 'Grade 13',
1638: 14 => '100 Level',
1639: 15 => '200 Level',
1640: 16 => '300 Level',
1641: 17 => '400 Level',
1642: 18 => 'Graduate Level');
1643: return &mt($gradelevels{$gradelevel});
1644: }
1645:
1.163 www 1646: sub select_level_form {
1647: my ($deflevel,$name)=@_;
1648: unless ($deflevel) { $deflevel=0; }
1.167 www 1649: my $selectform = "<select name=\"$name\" size=\"1\">\n";
1650: for (my $i=0; $i<=18; $i++) {
1651: $selectform.="<option value=\"$i\" ".
1.253 albertel 1652: ($i==$deflevel ? 'selected="selected" ' : '').
1.167 www 1653: ">".&gradeleveldescription($i)."</option>\n";
1654: }
1655: $selectform.="</select>";
1656: return $selectform;
1.163 www 1657: }
1.167 www 1658:
1.35 matthew 1659: #-------------------------------------------
1660:
1.45 matthew 1661: =pod
1662:
1.648 raeburn 1663: =item * &select_dom_form($defdom,$name,$includeempty,$showdomdesc)
1.35 matthew 1664:
1665: Returns a string containing a <select name='$name' size='1'> form to
1666: allow a user to select the domain to preform an operation in.
1667: See loncreateuser.pm for an example invocation and use.
1668:
1.90 www 1669: If the $includeempty flag is set, it also includes an empty choice ("no domain
1670: selected");
1671:
1.563 raeburn 1672: If the $showdomdesc flag is set, the domain name is followed by the domain description.
1673:
1.35 matthew 1674: =cut
1675:
1676: #-------------------------------------------
1.34 matthew 1677: sub select_dom_form {
1.563 raeburn 1678: my ($defdom,$name,$includeempty,$showdomdesc) = @_;
1.550 albertel 1679: my @domains = sort {lc($a) cmp lc($b)} (&Apache::lonnet::all_domains());
1.90 www 1680: if ($includeempty) { @domains=('',@domains); }
1.34 matthew 1681: my $selectdomain = "<select name=\"$name\" size=\"1\">\n";
1.356 albertel 1682: foreach my $dom (@domains) {
1683: $selectdomain.="<option value=\"$dom\" ".
1.563 raeburn 1684: ($dom eq $defdom ? 'selected="selected" ' : '').'>'.$dom;
1685: if ($showdomdesc) {
1686: if ($dom ne '') {
1687: my $domdesc = &Apache::lonnet::domain($dom,'description');
1688: if ($domdesc ne '') {
1689: $selectdomain .= ' ('.$domdesc.')';
1690: }
1691: }
1692: }
1693: $selectdomain .= "</option>\n";
1.34 matthew 1694: }
1695: $selectdomain.="</select>";
1696: return $selectdomain;
1697: }
1698:
1.35 matthew 1699: #-------------------------------------------
1700:
1.45 matthew 1701: =pod
1702:
1.648 raeburn 1703: =item * &home_server_form_item($domain,$name,$defaultflag)
1.35 matthew 1704:
1.586 raeburn 1705: input: 4 arguments (two required, two optional) -
1706: $domain - domain of new user
1707: $name - name of form element
1708: $default - Value of 'default' causes a default item to be first
1709: option, and selected by default.
1710: $hide - Value of 'hide' causes hiding of the name of the server,
1711: if 1 server found, or default, if 0 found.
1.594 raeburn 1712: output: returns 2 items:
1.586 raeburn 1713: (a) form element which contains either:
1714: (i) <select name="$name">
1715: <option value="$hostid1">$hostid $servers{$hostid}</option>
1716: <option value="$hostid2">$hostid $servers{$hostid}</option>
1717: </select>
1718: form item if there are multiple library servers in $domain, or
1719: (ii) an <input type="hidden" name="$name" value="$hostid" /> form item
1720: if there is only one library server in $domain.
1721:
1722: (b) number of library servers found.
1723:
1724: See loncreateuser.pm for example of use.
1.35 matthew 1725:
1726: =cut
1727:
1728: #-------------------------------------------
1.586 raeburn 1729: sub home_server_form_item {
1730: my ($domain,$name,$default,$hide) = @_;
1.513 albertel 1731: my %servers = &Apache::lonnet::get_servers($domain,'library');
1.586 raeburn 1732: my $result;
1733: my $numlib = keys(%servers);
1734: if ($numlib > 1) {
1735: $result .= '<select name="'.$name.'" />'."\n";
1736: if ($default) {
1737: $result .= '<option value="default" selected>'.&mt('default').
1738: '</option>'."\n";
1739: }
1740: foreach my $hostid (sort(keys(%servers))) {
1741: $result.= '<option value="'.$hostid.'">'.
1742: $hostid.' '.$servers{$hostid}."</option>\n";
1743: }
1744: $result .= '</select>'."\n";
1745: } elsif ($numlib == 1) {
1746: my $hostid;
1747: foreach my $item (keys(%servers)) {
1748: $hostid = $item;
1749: }
1750: $result .= '<input type="hidden" name="'.$name.'" value="'.
1751: $hostid.'" />';
1752: if (!$hide) {
1753: $result .= $hostid.' '.$servers{$hostid};
1754: }
1755: $result .= "\n";
1756: } elsif ($default) {
1757: $result .= '<input type="hidden" name="'.$name.
1758: '" value="default" />';
1759: if (!$hide) {
1760: $result .= &mt('default');
1761: }
1762: $result .= "\n";
1.33 matthew 1763: }
1.586 raeburn 1764: return ($result,$numlib);
1.33 matthew 1765: }
1.112 bowersj2 1766:
1767: =pod
1768:
1.534 albertel 1769: =back
1770:
1.112 bowersj2 1771: =cut
1.87 matthew 1772:
1773: ###############################################################
1.112 bowersj2 1774: ## Decoding User Agent ##
1.87 matthew 1775: ###############################################################
1776:
1777: =pod
1778:
1.112 bowersj2 1779: =head1 Decoding the User Agent
1780:
1781: =over 4
1782:
1783: =item * &decode_user_agent()
1.87 matthew 1784:
1785: Inputs: $r
1786:
1787: Outputs:
1788:
1789: =over 4
1790:
1.112 bowersj2 1791: =item * $httpbrowser
1.87 matthew 1792:
1.112 bowersj2 1793: =item * $clientbrowser
1.87 matthew 1794:
1.112 bowersj2 1795: =item * $clientversion
1.87 matthew 1796:
1.112 bowersj2 1797: =item * $clientmathml
1.87 matthew 1798:
1.112 bowersj2 1799: =item * $clientunicode
1.87 matthew 1800:
1.112 bowersj2 1801: =item * $clientos
1.87 matthew 1802:
1803: =back
1804:
1.157 matthew 1805: =back
1806:
1.87 matthew 1807: =cut
1808:
1809: ###############################################################
1810: ###############################################################
1811: sub decode_user_agent {
1.247 albertel 1812: my ($r)=@_;
1.87 matthew 1813: my @browsertype=split(/\&/,$Apache::lonnet::perlvar{"lonBrowsDet"});
1814: my %mathcap=split(/\&/,$$Apache::lonnet::perlvar{"lonMathML"});
1815: my $httpbrowser=$ENV{"HTTP_USER_AGENT"};
1.247 albertel 1816: if (!$httpbrowser && $r) { $httpbrowser=$r->header_in('User-Agent'); }
1.87 matthew 1817: my $clientbrowser='unknown';
1818: my $clientversion='0';
1819: my $clientmathml='';
1820: my $clientunicode='0';
1821: for (my $i=0;$i<=$#browsertype;$i++) {
1822: my ($bname,$match,$notmatch,$vreg,$minv,$univ)=split(/\:/,$browsertype[$i]);
1823: if (($httpbrowser=~/$match/i) && ($httpbrowser!~/$notmatch/i)) {
1824: $clientbrowser=$bname;
1825: $httpbrowser=~/$vreg/i;
1826: $clientversion=$1;
1827: $clientmathml=($clientversion>=$minv);
1828: $clientunicode=($clientversion>=$univ);
1829: }
1830: }
1831: my $clientos='unknown';
1832: if (($httpbrowser=~/linux/i) ||
1833: ($httpbrowser=~/unix/i) ||
1834: ($httpbrowser=~/ux/i) ||
1835: ($httpbrowser=~/solaris/i)) { $clientos='unix'; }
1836: if (($httpbrowser=~/vax/i) ||
1837: ($httpbrowser=~/vms/i)) { $clientos='vms'; }
1838: if ($httpbrowser=~/next/i) { $clientos='next'; }
1839: if (($httpbrowser=~/mac/i) ||
1840: ($httpbrowser=~/powerpc/i)) { $clientos='mac'; }
1841: if ($httpbrowser=~/win/i) { $clientos='win'; }
1842: if ($httpbrowser=~/embed/i) { $clientos='pda'; }
1843: return ($httpbrowser,$clientbrowser,$clientversion,$clientmathml,
1844: $clientunicode,$clientos,);
1845: }
1846:
1.32 matthew 1847: ###############################################################
1848: ## Authentication changing form generation subroutines ##
1849: ###############################################################
1850: ##
1851: ## All of the authform_xxxxxxx subroutines take their inputs in a
1852: ## hash, and have reasonable default values.
1853: ##
1854: ## formname = the name given in the <form> tag.
1.35 matthew 1855: #-------------------------------------------
1856:
1.45 matthew 1857: =pod
1858:
1.112 bowersj2 1859: =head1 Authentication Routines
1860:
1861: =over 4
1862:
1.648 raeburn 1863: =item * &authform_xxxxxx()
1.35 matthew 1864:
1865: The authform_xxxxxx subroutines provide javascript and html forms which
1866: handle some of the conveniences required for authentication forms.
1867: This is not an optimal method, but it works.
1868:
1869: =over 4
1870:
1.112 bowersj2 1871: =item * authform_header
1.35 matthew 1872:
1.112 bowersj2 1873: =item * authform_authorwarning
1.35 matthew 1874:
1.112 bowersj2 1875: =item * authform_nochange
1.35 matthew 1876:
1.112 bowersj2 1877: =item * authform_kerberos
1.35 matthew 1878:
1.112 bowersj2 1879: =item * authform_internal
1.35 matthew 1880:
1.112 bowersj2 1881: =item * authform_filesystem
1.35 matthew 1882:
1883: =back
1884:
1.648 raeburn 1885: See loncreateuser.pm for invocation and use examples.
1.157 matthew 1886:
1.35 matthew 1887: =cut
1888:
1889: #-------------------------------------------
1.32 matthew 1890: sub authform_header{
1891: my %in = (
1892: formname => 'cu',
1.80 albertel 1893: kerb_def_dom => '',
1.32 matthew 1894: @_,
1895: );
1896: $in{'formname'} = 'document.' . $in{'formname'};
1897: my $result='';
1.80 albertel 1898:
1899: #---------------------------------------------- Code for upper case translation
1900: my $Javascript_toUpperCase;
1901: unless ($in{kerb_def_dom}) {
1902: $Javascript_toUpperCase =<<"END";
1903: switch (choice) {
1904: case 'krb': currentform.elements[choicearg].value =
1905: currentform.elements[choicearg].value.toUpperCase();
1906: break;
1907: default:
1908: }
1909: END
1910: } else {
1911: $Javascript_toUpperCase = "";
1912: }
1913:
1.165 raeburn 1914: my $radioval = "'nochange'";
1.591 raeburn 1915: if (defined($in{'curr_authtype'})) {
1916: if ($in{'curr_authtype'} ne '') {
1917: $radioval = "'".$in{'curr_authtype'}."arg'";
1918: }
1.174 matthew 1919: }
1.165 raeburn 1920: my $argfield = 'null';
1.591 raeburn 1921: if (defined($in{'mode'})) {
1.165 raeburn 1922: if ($in{'mode'} eq 'modifycourse') {
1.591 raeburn 1923: if (defined($in{'curr_autharg'})) {
1924: if ($in{'curr_autharg'} ne '') {
1.165 raeburn 1925: $argfield = "'$in{'curr_autharg'}'";
1926: }
1927: }
1928: }
1929: }
1930:
1.32 matthew 1931: $result.=<<"END";
1932: var current = new Object();
1.165 raeburn 1933: current.radiovalue = $radioval;
1934: current.argfield = $argfield;
1.32 matthew 1935:
1936: function changed_radio(choice,currentform) {
1937: var choicearg = choice + 'arg';
1938: // If a radio button in changed, we need to change the argfield
1939: if (current.radiovalue != choice) {
1940: current.radiovalue = choice;
1941: if (current.argfield != null) {
1942: currentform.elements[current.argfield].value = '';
1943: }
1944: if (choice == 'nochange') {
1945: current.argfield = null;
1946: } else {
1947: current.argfield = choicearg;
1948: switch(choice) {
1949: case 'krb':
1950: currentform.elements[current.argfield].value =
1951: "$in{'kerb_def_dom'}";
1952: break;
1953: default:
1954: break;
1955: }
1956: }
1957: }
1958: return;
1959: }
1.22 www 1960:
1.32 matthew 1961: function changed_text(choice,currentform) {
1962: var choicearg = choice + 'arg';
1963: if (currentform.elements[choicearg].value !='') {
1.80 albertel 1964: $Javascript_toUpperCase
1.32 matthew 1965: // clear old field
1966: if ((current.argfield != choicearg) && (current.argfield != null)) {
1967: currentform.elements[current.argfield].value = '';
1968: }
1969: current.argfield = choicearg;
1970: }
1971: set_auth_radio_buttons(choice,currentform);
1972: return;
1.20 www 1973: }
1.32 matthew 1974:
1975: function set_auth_radio_buttons(newvalue,currentform) {
1976: var i=0;
1977: while (i < currentform.login.length) {
1978: if (currentform.login[i].value == newvalue) { break; }
1979: i++;
1980: }
1981: if (i == currentform.login.length) {
1982: return;
1983: }
1984: current.radiovalue = newvalue;
1985: currentform.login[i].checked = true;
1986: return;
1987: }
1988: END
1989: return $result;
1990: }
1991:
1992: sub authform_authorwarning{
1993: my $result='';
1.144 matthew 1994: $result='<i>'.
1995: &mt('As a general rule, only authors or co-authors should be '.
1996: 'filesystem authenticated '.
1997: '(which allows access to the server filesystem).')."</i>\n";
1.32 matthew 1998: return $result;
1999: }
2000:
2001: sub authform_nochange{
2002: my %in = (
2003: formname => 'document.cu',
2004: kerb_def_dom => 'MSU.EDU',
2005: @_,
2006: );
1.586 raeburn 2007: my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'});
2008: my $result;
2009: if (keys(%can_assign) == 0) {
2010: $result = &mt('Under you current role you are not permitted to change login settings for this user');
2011: } else {
2012: $result = '<label>'.&mt('[_1] Do not change login data',
2013: '<input type="radio" name="login" value="nochange" '.
2014: 'checked="checked" onclick="'.
1.281 albertel 2015: "javascript:changed_radio('nochange',$in{'formname'});".'" />').
2016: '</label>';
1.586 raeburn 2017: }
1.32 matthew 2018: return $result;
2019: }
2020:
1.591 raeburn 2021: sub authform_kerberos {
1.32 matthew 2022: my %in = (
2023: formname => 'document.cu',
2024: kerb_def_dom => 'MSU.EDU',
1.80 albertel 2025: kerb_def_auth => 'krb4',
1.32 matthew 2026: @_,
2027: );
1.586 raeburn 2028: my ($check4,$check5,$krbcheck,$krbarg,$krbver,$result,$authtype,
2029: $autharg,$jscall);
2030: my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'});
1.80 albertel 2031: if ($in{'kerb_def_auth'} eq 'krb5') {
1.586 raeburn 2032: $check5 = ' checked="on"';
1.80 albertel 2033: } else {
1.586 raeburn 2034: $check4 = ' checked="on"';
1.80 albertel 2035: }
1.165 raeburn 2036: $krbarg = $in{'kerb_def_dom'};
1.591 raeburn 2037: if (defined($in{'curr_authtype'})) {
2038: if ($in{'curr_authtype'} eq 'krb') {
1.586 raeburn 2039: $krbcheck = ' checked="on"';
1.623 raeburn 2040: if (defined($in{'mode'})) {
2041: if ($in{'mode'} eq 'modifyuser') {
2042: $krbcheck = '';
2043: }
2044: }
1.591 raeburn 2045: if (defined($in{'curr_kerb_ver'})) {
2046: if ($in{'curr_krb_ver'} eq '5') {
2047: $check5 = ' checked="on"';
2048: $check4 = '';
2049: } else {
2050: $check4 = ' checked="on"';
2051: $check5 = '';
2052: }
1.586 raeburn 2053: }
1.591 raeburn 2054: if (defined($in{'curr_autharg'})) {
1.165 raeburn 2055: $krbarg = $in{'curr_autharg'};
2056: }
1.586 raeburn 2057: if (!$can_assign{'krb4'} && !$can_assign{'krb5'}) {
1.591 raeburn 2058: if (defined($in{'curr_autharg'})) {
1.586 raeburn 2059: $result =
2060: &mt('Currently Kerberos authenticated with domain [_1] Version [_2].',
2061: $in{'curr_autharg'},$krbver);
2062: } else {
2063: $result =
2064: &mt('Currently Kerberos authenticated, Version [_1].',$krbver);
2065: }
2066: return $result;
2067: }
2068: }
2069: } else {
2070: if ($authnum == 1) {
2071: $authtype = '<input type="hidden" name="login" value="krb">';
1.165 raeburn 2072: }
2073: }
1.586 raeburn 2074: if (!$can_assign{'krb4'} && !$can_assign{'krb5'}) {
2075: return;
1.587 raeburn 2076: } elsif ($authtype eq '') {
1.591 raeburn 2077: if (defined($in{'mode'})) {
1.587 raeburn 2078: if ($in{'mode'} eq 'modifycourse') {
2079: if ($authnum == 1) {
2080: $authtype = '<input type="hidden" name="login" value="krb">';
2081: }
2082: }
2083: }
1.586 raeburn 2084: }
2085: $jscall = "javascript:changed_radio('krb',$in{'formname'});";
2086: if ($authtype eq '') {
2087: $authtype = '<input type="radio" name="login" value="krb" '.
2088: 'onclick="'.$jscall.'" onchange="'.$jscall.'"'.
2089: $krbcheck.' />';
2090: }
2091: if (($can_assign{'krb4'} && $can_assign{'krb5'}) ||
2092: ($can_assign{'krb4'} && !$can_assign{'krb5'} &&
2093: $in{'curr_authtype'} eq 'krb5') ||
2094: (!$can_assign{'krb4'} && $can_assign{'krb5'} &&
2095: $in{'curr_authtype'} eq 'krb4')) {
2096: $result .= &mt
1.144 matthew 2097: ('[_1] Kerberos authenticated with domain [_2] '.
1.281 albertel 2098: '[_3] Version 4 [_4] Version 5 [_5]',
1.586 raeburn 2099: '<label>'.$authtype,
1.281 albertel 2100: '</label><input type="text" size="10" name="krbarg" '.
1.165 raeburn 2101: 'value="'.$krbarg.'" '.
1.144 matthew 2102: 'onchange="'.$jscall.'" />',
1.281 albertel 2103: '<label><input type="radio" name="krbver" value="4" '.$check4.' />',
2104: '</label><label><input type="radio" name="krbver" value="5" '.$check5.' />',
2105: '</label>');
1.586 raeburn 2106: } elsif ($can_assign{'krb4'}) {
2107: $result .= &mt
2108: ('[_1] Kerberos authenticated with domain [_2] '.
2109: '[_3] Version 4 [_4]',
2110: '<label>'.$authtype,
2111: '</label><input type="text" size="10" name="krbarg" '.
2112: 'value="'.$krbarg.'" '.
2113: 'onchange="'.$jscall.'" />',
2114: '<label><input type="hidden" name="krbver" value="4" />',
2115: '</label>');
2116: } elsif ($can_assign{'krb5'}) {
2117: $result .= &mt
2118: ('[_1] Kerberos authenticated with domain [_2] '.
2119: '[_3] Version 5 [_4]',
2120: '<label>'.$authtype,
2121: '</label><input type="text" size="10" name="krbarg" '.
2122: 'value="'.$krbarg.'" '.
2123: 'onchange="'.$jscall.'" />',
2124: '<label><input type="hidden" name="krbver" value="5" />',
2125: '</label>');
2126: }
1.32 matthew 2127: return $result;
2128: }
2129:
2130: sub authform_internal{
1.586 raeburn 2131: my %in = (
1.32 matthew 2132: formname => 'document.cu',
2133: kerb_def_dom => 'MSU.EDU',
2134: @_,
2135: );
1.586 raeburn 2136: my ($intcheck,$intarg,$result,$authtype,$autharg,$jscall);
2137: my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'});
1.591 raeburn 2138: if (defined($in{'curr_authtype'})) {
2139: if ($in{'curr_authtype'} eq 'int') {
1.586 raeburn 2140: if ($can_assign{'int'}) {
2141: $intcheck = 'checked="on" ';
1.623 raeburn 2142: if (defined($in{'mode'})) {
2143: if ($in{'mode'} eq 'modifyuser') {
2144: $intcheck = '';
2145: }
2146: }
1.591 raeburn 2147: if (defined($in{'curr_autharg'})) {
1.586 raeburn 2148: $intarg = $in{'curr_autharg'};
2149: }
2150: } else {
2151: $result = &mt('Currently internally authenticated.');
2152: return $result;
1.165 raeburn 2153: }
2154: }
1.586 raeburn 2155: } else {
2156: if ($authnum == 1) {
2157: $authtype = '<input type="hidden" name="login" value="int">';
2158: }
2159: }
2160: if (!$can_assign{'int'}) {
2161: return;
1.587 raeburn 2162: } elsif ($authtype eq '') {
1.591 raeburn 2163: if (defined($in{'mode'})) {
1.587 raeburn 2164: if ($in{'mode'} eq 'modifycourse') {
2165: if ($authnum == 1) {
2166: $authtype = '<input type="hidden" name="login" value="int">';
2167: }
2168: }
2169: }
1.165 raeburn 2170: }
1.586 raeburn 2171: $jscall = "javascript:changed_radio('int',$in{'formname'});";
2172: if ($authtype eq '') {
2173: $authtype = '<input type="radio" name="login" value="int" '.$intcheck.
2174: ' onchange="'.$jscall.'" onclick="'.$jscall.'" />';
2175: }
1.605 bisitz 2176: $autharg = '<input type="password" size="10" name="intarg" value="'.
1.586 raeburn 2177: $intarg.'" onchange="'.$jscall.'" />';
2178: $result = &mt
1.144 matthew 2179: ('[_1] Internally authenticated (with initial password [_2])',
1.586 raeburn 2180: '<label>'.$authtype,'</label>'.$autharg);
1.620 www 2181: $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 2182: return $result;
2183: }
2184:
2185: sub authform_local{
2186: my %in = (
2187: formname => 'document.cu',
2188: kerb_def_dom => 'MSU.EDU',
2189: @_,
2190: );
1.586 raeburn 2191: my ($loccheck,$locarg,$result,$authtype,$autharg,$jscall);
2192: my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'});
1.591 raeburn 2193: if (defined($in{'curr_authtype'})) {
2194: if ($in{'curr_authtype'} eq 'loc') {
1.586 raeburn 2195: if ($can_assign{'loc'}) {
2196: $loccheck = 'checked="on" ';
1.623 raeburn 2197: if (defined($in{'mode'})) {
2198: if ($in{'mode'} eq 'modifyuser') {
2199: $loccheck = '';
2200: }
2201: }
1.591 raeburn 2202: if (defined($in{'curr_autharg'})) {
1.586 raeburn 2203: $locarg = $in{'curr_autharg'};
2204: }
2205: } else {
2206: $result = &mt('Currently using local (institutional) authentication.');
2207: return $result;
1.165 raeburn 2208: }
2209: }
1.586 raeburn 2210: } else {
2211: if ($authnum == 1) {
2212: $authtype = '<input type="hidden" name="login" value="loc">';
2213: }
2214: }
2215: if (!$can_assign{'loc'}) {
2216: return;
1.587 raeburn 2217: } elsif ($authtype eq '') {
1.591 raeburn 2218: if (defined($in{'mode'})) {
1.587 raeburn 2219: if ($in{'mode'} eq 'modifycourse') {
2220: if ($authnum == 1) {
2221: $authtype = '<input type="hidden" name="login" value="loc">';
2222: }
2223: }
2224: }
1.165 raeburn 2225: }
1.586 raeburn 2226: $jscall = "javascript:changed_radio('loc',$in{'formname'});";
2227: if ($authtype eq '') {
2228: $authtype = '<input type="radio" name="login" value="loc" '.
2229: $loccheck.' onchange="'.$jscall.'" onclick="'.
2230: $jscall.'" />';
2231: }
2232: $autharg = '<input type="text" size="10" name="locarg" value="'.
2233: $locarg.'" onchange="'.$jscall.'" />';
2234: $result = &mt('[_1] Local Authentication with argument [_2]',
2235: '<label>'.$authtype,'</label>'.$autharg);
1.32 matthew 2236: return $result;
2237: }
2238:
2239: sub authform_filesystem{
2240: my %in = (
2241: formname => 'document.cu',
2242: kerb_def_dom => 'MSU.EDU',
2243: @_,
2244: );
1.586 raeburn 2245: my ($fsyscheck,$result,$authtype,$autharg,$jscall);
2246: my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'});
1.591 raeburn 2247: if (defined($in{'curr_authtype'})) {
2248: if ($in{'curr_authtype'} eq 'fsys') {
1.586 raeburn 2249: if ($can_assign{'fsys'}) {
2250: $fsyscheck = 'checked="on" ';
1.623 raeburn 2251: if (defined($in{'mode'})) {
2252: if ($in{'mode'} eq 'modifyuser') {
2253: $fsyscheck = '';
2254: }
2255: }
1.586 raeburn 2256: } else {
2257: $result = &mt('Currently Filesystem Authenticated.');
2258: return $result;
2259: }
2260: }
2261: } else {
2262: if ($authnum == 1) {
2263: $authtype = '<input type="hidden" name="login" value="fsys">';
2264: }
2265: }
2266: if (!$can_assign{'fsys'}) {
2267: return;
1.587 raeburn 2268: } elsif ($authtype eq '') {
1.591 raeburn 2269: if (defined($in{'mode'})) {
1.587 raeburn 2270: if ($in{'mode'} eq 'modifycourse') {
2271: if ($authnum == 1) {
2272: $authtype = '<input type="hidden" name="login" value="fsys">';
2273: }
2274: }
2275: }
1.586 raeburn 2276: }
2277: $jscall = "javascript:changed_radio('fsys',$in{'formname'});";
2278: if ($authtype eq '') {
2279: $authtype = '<input type="radio" name="login" value="fsys" '.
2280: $fsyscheck.' onchange="'.$jscall.'" onclick="'.
2281: $jscall.'" />';
2282: }
2283: $autharg = '<input type="text" size="10" name="fsysarg" value=""'.
2284: ' onchange="'.$jscall.'" />';
2285: $result = &mt
1.144 matthew 2286: ('[_1] Filesystem Authenticated (with initial password [_2])',
1.281 albertel 2287: '<label><input type="radio" name="login" value="fsys" '.
1.586 raeburn 2288: $fsyscheck.'onchange="'.$jscall.'" onclick="'.$jscall.'" />',
1.605 bisitz 2289: '</label><input type="password" size="10" name="fsysarg" value="" '.
1.144 matthew 2290: 'onchange="'.$jscall.'" />');
1.32 matthew 2291: return $result;
2292: }
2293:
1.586 raeburn 2294: sub get_assignable_auth {
2295: my ($dom) = @_;
2296: if ($dom eq '') {
2297: $dom = $env{'request.role.domain'};
2298: }
2299: my %can_assign = (
2300: krb4 => 1,
2301: krb5 => 1,
2302: int => 1,
2303: loc => 1,
2304: );
2305: my %domconfig = &Apache::lonnet::get_dom('configuration',['usercreation'],$dom);
2306: if (ref($domconfig{'usercreation'}) eq 'HASH') {
2307: if (ref($domconfig{'usercreation'}{'authtypes'}) eq 'HASH') {
2308: my $authhash = $domconfig{'usercreation'}{'authtypes'};
2309: my $context;
2310: if ($env{'request.role'} =~ /^au/) {
2311: $context = 'author';
2312: } elsif ($env{'request.role'} =~ /^dc/) {
2313: $context = 'domain';
2314: } elsif ($env{'request.course.id'}) {
2315: $context = 'course';
2316: }
2317: if ($context) {
2318: if (ref($authhash->{$context}) eq 'HASH') {
2319: %can_assign = %{$authhash->{$context}};
2320: }
2321: }
2322: }
2323: }
2324: my $authnum = 0;
2325: foreach my $key (keys(%can_assign)) {
2326: if ($can_assign{$key}) {
2327: $authnum ++;
2328: }
2329: }
2330: if ($can_assign{'krb4'} && $can_assign{'krb5'}) {
2331: $authnum --;
2332: }
2333: return ($authnum,%can_assign);
2334: }
2335:
1.80 albertel 2336: ###############################################################
2337: ## Get Kerberos Defaults for Domain ##
2338: ###############################################################
2339: ##
2340: ## Returns default kerberos version and an associated argument
2341: ## as listed in file domain.tab. If not listed, provides
2342: ## appropriate default domain and kerberos version.
2343: ##
2344: #-------------------------------------------
2345:
2346: =pod
2347:
1.648 raeburn 2348: =item * &get_kerberos_defaults()
1.80 albertel 2349:
2350: get_kerberos_defaults($target_domain) returns the default kerberos
1.641 raeburn 2351: version and domain. If not found, it defaults to version 4 and the
2352: domain of the server.
1.80 albertel 2353:
1.648 raeburn 2354: =over 4
2355:
1.80 albertel 2356: ($def_version, $def_krb_domain) = &get_kerberos_defaults($target_domain);
2357:
1.648 raeburn 2358: =back
2359:
2360: =back
2361:
1.80 albertel 2362: =cut
2363:
2364: #-------------------------------------------
2365: sub get_kerberos_defaults {
2366: my $domain=shift;
1.641 raeburn 2367: my ($krbdef,$krbdefdom);
2368: my %domdefaults = &Apache::lonnet::get_domain_defaults($domain);
2369: if (($domdefaults{'auth_def'} =~/^krb(4|5)$/) && ($domdefaults{'auth_arg_def'} ne '')) {
2370: $krbdef = $domdefaults{'auth_def'};
2371: $krbdefdom = $domdefaults{'auth_arg_def'};
2372: } else {
1.80 albertel 2373: $ENV{'SERVER_NAME'}=~/(\w+\.\w+)$/;
2374: my $krbdefdom=$1;
2375: $krbdefdom=~tr/a-z/A-Z/;
2376: $krbdef = "krb4";
2377: }
2378: return ($krbdef,$krbdefdom);
2379: }
1.112 bowersj2 2380:
1.32 matthew 2381:
1.46 matthew 2382: ###############################################################
2383: ## Thesaurus Functions ##
2384: ###############################################################
1.20 www 2385:
1.46 matthew 2386: =pod
1.20 www 2387:
1.112 bowersj2 2388: =head1 Thesaurus Functions
2389:
2390: =over 4
2391:
1.648 raeburn 2392: =item * &initialize_keywords()
1.46 matthew 2393:
2394: Initializes the package variable %Keywords if it is empty. Uses the
2395: package variable $thesaurus_db_file.
2396:
2397: =cut
2398:
2399: ###################################################
2400:
2401: sub initialize_keywords {
2402: return 1 if (scalar keys(%Keywords));
2403: # If we are here, %Keywords is empty, so fill it up
2404: # Make sure the file we need exists...
2405: if (! -e $thesaurus_db_file) {
2406: &Apache::lonnet::logthis("Attempt to access $thesaurus_db_file".
2407: " failed because it does not exist");
2408: return 0;
2409: }
2410: # Set up the hash as a database
2411: my %thesaurus_db;
2412: if (! tie(%thesaurus_db,'GDBM_File',
1.53 albertel 2413: $thesaurus_db_file,&GDBM_READER(),0640)){
1.46 matthew 2414: &Apache::lonnet::logthis("Could not tie \%thesaurus_db to ".
2415: $thesaurus_db_file);
2416: return 0;
2417: }
2418: # Get the average number of appearances of a word.
2419: my $avecount = $thesaurus_db{'average.count'};
2420: # Put keywords (those that appear > average) into %Keywords
2421: while (my ($word,$data)=each (%thesaurus_db)) {
2422: my ($count,undef) = split /:/,$data;
2423: $Keywords{$word}++ if ($count > $avecount);
2424: }
2425: untie %thesaurus_db;
2426: # Remove special values from %Keywords.
1.356 albertel 2427: foreach my $value ('total.count','average.count') {
2428: delete($Keywords{$value}) if (exists($Keywords{$value}));
1.586 raeburn 2429: }
1.46 matthew 2430: return 1;
2431: }
2432:
2433: ###################################################
2434:
2435: =pod
2436:
1.648 raeburn 2437: =item * &keyword($word)
1.46 matthew 2438:
2439: Returns true if $word is a keyword. A keyword is a word that appears more
2440: than the average number of times in the thesaurus database. Calls
2441: &initialize_keywords
2442:
2443: =cut
2444:
2445: ###################################################
1.20 www 2446:
2447: sub keyword {
1.46 matthew 2448: return if (!&initialize_keywords());
2449: my $word=lc(shift());
2450: $word=~s/\W//g;
2451: return exists($Keywords{$word});
1.20 www 2452: }
1.46 matthew 2453:
2454: ###############################################################
2455:
2456: =pod
1.20 www 2457:
1.648 raeburn 2458: =item * &get_related_words()
1.46 matthew 2459:
1.160 matthew 2460: Look up a word in the thesaurus. Takes a scalar argument and returns
1.46 matthew 2461: an array of words. If the keyword is not in the thesaurus, an empty array
2462: will be returned. The order of the words returned is determined by the
2463: database which holds them.
2464:
2465: Uses global $thesaurus_db_file.
2466:
2467: =cut
2468:
2469: ###############################################################
2470: sub get_related_words {
2471: my $keyword = shift;
2472: my %thesaurus_db;
2473: if (! -e $thesaurus_db_file) {
2474: &Apache::lonnet::logthis("Attempt to access $thesaurus_db_file ".
2475: "failed because the file does not exist");
2476: return ();
2477: }
2478: if (! tie(%thesaurus_db,'GDBM_File',
1.53 albertel 2479: $thesaurus_db_file,&GDBM_READER(),0640)){
1.46 matthew 2480: return ();
2481: }
2482: my @Words=();
1.429 www 2483: my $count=0;
1.46 matthew 2484: if (exists($thesaurus_db{$keyword})) {
1.356 albertel 2485: # The first element is the number of times
2486: # the word appears. We do not need it now.
1.429 www 2487: my (undef,@RelatedWords) = (split(/:/,$thesaurus_db{$keyword}));
2488: my (undef,$mostfrequentcount)=split(/\,/,$RelatedWords[0]);
2489: my $threshold=$mostfrequentcount/10;
2490: foreach my $possibleword (@RelatedWords) {
2491: my ($word,$wordcount)=split(/\,/,$possibleword);
2492: if ($wordcount>$threshold) {
2493: push(@Words,$word);
2494: $count++;
2495: if ($count>10) { last; }
2496: }
1.20 www 2497: }
2498: }
1.46 matthew 2499: untie %thesaurus_db;
2500: return @Words;
1.14 harris41 2501: }
1.46 matthew 2502:
1.112 bowersj2 2503: =pod
2504:
2505: =back
2506:
2507: =cut
1.61 www 2508:
2509: # -------------------------------------------------------------- Plaintext name
1.81 albertel 2510: =pod
2511:
1.112 bowersj2 2512: =head1 User Name Functions
2513:
2514: =over 4
2515:
1.648 raeburn 2516: =item * &plainname($uname,$udom,$first)
1.81 albertel 2517:
1.112 bowersj2 2518: Takes a users logon name and returns it as a string in
1.226 albertel 2519: "first middle last generation" form
2520: if $first is set to 'lastname' then it returns it as
2521: 'lastname generation, firstname middlename' if their is a lastname
1.81 albertel 2522:
2523: =cut
1.61 www 2524:
1.295 www 2525:
1.81 albertel 2526: ###############################################################
1.61 www 2527: sub plainname {
1.226 albertel 2528: my ($uname,$udom,$first)=@_;
1.537 albertel 2529: return if (!defined($uname) || !defined($udom));
1.295 www 2530: my %names=&getnames($uname,$udom);
1.226 albertel 2531: my $name=&Apache::lonnet::format_name($names{'firstname'},
2532: $names{'middlename'},
2533: $names{'lastname'},
2534: $names{'generation'},$first);
2535: $name=~s/^\s+//;
1.62 www 2536: $name=~s/\s+$//;
2537: $name=~s/\s+/ /g;
1.353 albertel 2538: if ($name !~ /\S/) { $name=$uname.':'.$udom; }
1.62 www 2539: return $name;
1.61 www 2540: }
1.66 www 2541:
2542: # -------------------------------------------------------------------- Nickname
1.81 albertel 2543: =pod
2544:
1.648 raeburn 2545: =item * &nickname($uname,$udom)
1.81 albertel 2546:
2547: Gets a users name and returns it as a string as
2548:
2549: ""nickname""
1.66 www 2550:
1.81 albertel 2551: if the user has a nickname or
2552:
2553: "first middle last generation"
2554:
2555: if the user does not
2556:
2557: =cut
1.66 www 2558:
2559: sub nickname {
2560: my ($uname,$udom)=@_;
1.537 albertel 2561: return if (!defined($uname) || !defined($udom));
1.295 www 2562: my %names=&getnames($uname,$udom);
1.68 albertel 2563: my $name=$names{'nickname'};
1.66 www 2564: if ($name) {
2565: $name='"'.$name.'"';
2566: } else {
2567: $name=$names{'firstname'}.' '.$names{'middlename'}.' '.
2568: $names{'lastname'}.' '.$names{'generation'};
2569: $name=~s/\s+$//;
2570: $name=~s/\s+/ /g;
2571: }
2572: return $name;
2573: }
2574:
1.295 www 2575: sub getnames {
2576: my ($uname,$udom)=@_;
1.537 albertel 2577: return if (!defined($uname) || !defined($udom));
1.433 albertel 2578: if ($udom eq 'public' && $uname eq 'public') {
2579: return ('lastname' => &mt('Public'));
2580: }
1.295 www 2581: my $id=$uname.':'.$udom;
2582: my ($names,$cached)=&Apache::lonnet::is_cached_new('namescache',$id);
2583: if ($cached) {
2584: return %{$names};
2585: } else {
2586: my %loadnames=&Apache::lonnet::get('environment',
2587: ['firstname','middlename','lastname','generation','nickname'],
2588: $udom,$uname);
2589: &Apache::lonnet::do_cache_new('namescache',$id,\%loadnames);
2590: return %loadnames;
2591: }
2592: }
1.61 www 2593:
1.542 raeburn 2594: # -------------------------------------------------------------------- getemails
1.648 raeburn 2595:
1.542 raeburn 2596: =pod
2597:
1.648 raeburn 2598: =item * &getemails($uname,$udom)
1.542 raeburn 2599:
2600: Gets a user's email information and returns it as a hash with keys:
2601: notification, critnotification, permanentemail
2602:
2603: For notification and critnotification, values are comma-separated lists
1.648 raeburn 2604: of e-mail addresses; for permanentemail, value is a single e-mail address.
1.542 raeburn 2605:
1.648 raeburn 2606:
1.542 raeburn 2607: =cut
2608:
1.648 raeburn 2609:
1.466 albertel 2610: sub getemails {
2611: my ($uname,$udom)=@_;
2612: if ($udom eq 'public' && $uname eq 'public') {
2613: return;
2614: }
1.467 www 2615: if (!$udom) { $udom=$env{'user.domain'}; }
2616: if (!$uname) { $uname=$env{'user.name'}; }
1.466 albertel 2617: my $id=$uname.':'.$udom;
2618: my ($names,$cached)=&Apache::lonnet::is_cached_new('emailscache',$id);
2619: if ($cached) {
2620: return %{$names};
2621: } else {
2622: my %loadnames=&Apache::lonnet::get('environment',
2623: ['notification','critnotification',
2624: 'permanentemail'],
2625: $udom,$uname);
2626: &Apache::lonnet::do_cache_new('emailscache',$id,\%loadnames);
2627: return %loadnames;
2628: }
2629: }
2630:
1.551 albertel 2631: sub flush_email_cache {
2632: my ($uname,$udom)=@_;
2633: if (!$udom) { $udom =$env{'user.domain'}; }
2634: if (!$uname) { $uname=$env{'user.name'}; }
2635: return if ($udom eq 'public' && $uname eq 'public');
2636: my $id=$uname.':'.$udom;
2637: &Apache::lonnet::devalidate_cache_new('emailscache',$id);
2638: }
2639:
1.61 www 2640: # ------------------------------------------------------------------ Screenname
1.81 albertel 2641:
2642: =pod
2643:
1.648 raeburn 2644: =item * &screenname($uname,$udom)
1.81 albertel 2645:
2646: Gets a users screenname and returns it as a string
2647:
2648: =cut
1.61 www 2649:
2650: sub screenname {
2651: my ($uname,$udom)=@_;
1.258 albertel 2652: if ($uname eq $env{'user.name'} &&
2653: $udom eq $env{'user.domain'}) {return $env{'environment.screenname'};}
1.212 albertel 2654: my %names=&Apache::lonnet::get('environment',['screenname'],$udom,$uname);
1.68 albertel 2655: return $names{'screenname'};
1.62 www 2656: }
2657:
1.212 albertel 2658:
1.62 www 2659: # ------------------------------------------------------------- Message Wrapper
2660:
2661: sub messagewrapper {
1.369 www 2662: my ($link,$username,$domain,$subject,$text)=@_;
1.62 www 2663: return
1.441 albertel 2664: '<a href="/adm/email?compose=individual&'.
2665: 'recname='.$username.'&recdom='.$domain.
2666: '&subject='.&escape($subject).'&text='.&escape($text).'" '.
1.200 matthew 2667: 'title="'.&mt('Send message').'">'.$link.'</a>';
1.74 www 2668: }
2669: # --------------------------------------------------------------- Notes Wrapper
2670:
2671: sub noteswrapper {
2672: my ($link,$un,$do)=@_;
2673: return
2674: "<a href='/adm/email?recordftf=retrieve&recname=$un&recdom=$do'>$link</a>";
1.62 www 2675: }
2676: # ------------------------------------------------------------- Aboutme Wrapper
2677:
2678: sub aboutmewrapper {
1.166 www 2679: my ($link,$username,$domain,$target)=@_;
1.447 raeburn 2680: if (!defined($username) && !defined($domain)) {
2681: return;
2682: }
1.205 www 2683: return '<a href="/adm/'.$domain.'/'.$username.'/aboutme"'.
1.454 banghart 2684: ($target?' target="$target"':'').' title="'.&mt("View this user's personal page").'">'.$link.'</a>';
1.62 www 2685: }
2686:
2687: # ------------------------------------------------------------ Syllabus Wrapper
2688:
2689:
2690: sub syllabuswrapper {
1.109 matthew 2691: my ($linktext,$coursedir,$domain,$fontcolor)=@_;
2692: if ($fontcolor) {
2693: $linktext='<font color="'.$fontcolor.'">'.$linktext.'</font>';
2694: }
1.208 matthew 2695: return qq{<a href="/public/$domain/$coursedir/syllabus">$linktext</a>};
1.61 www 2696: }
1.14 harris41 2697:
1.208 matthew 2698: sub track_student_link {
1.268 albertel 2699: my ($linktext,$sname,$sdom,$target,$start) = @_;
2700: my $link ="/adm/trackstudent?";
1.208 matthew 2701: my $title = 'View recent activity';
2702: if (defined($sname) && $sname !~ /^\s*$/ &&
2703: defined($sdom) && $sdom !~ /^\s*$/) {
1.268 albertel 2704: $link .= "selected_student=$sname:$sdom";
1.208 matthew 2705: $title .= ' of this student';
1.268 albertel 2706: }
1.208 matthew 2707: if (defined($target) && $target !~ /^\s*$/) {
2708: $target = qq{target="$target"};
2709: } else {
2710: $target = '';
2711: }
1.268 albertel 2712: if ($start) { $link.='&start='.$start; }
1.554 albertel 2713: $title = &mt($title);
2714: $linktext = &mt($linktext);
1.448 albertel 2715: return qq{<a href="$link" title="$title" $target>$linktext</a>}.
2716: &help_open_topic('View_recent_activity');
1.208 matthew 2717: }
2718:
1.508 www 2719: # ===================================================== Display a student photo
2720:
2721:
1.509 albertel 2722: sub student_image_tag {
1.508 www 2723: my ($domain,$user)=@_;
2724: my $imgsrc=&Apache::lonnet::studentphoto($domain,$user,'jpg');
2725: if (($imgsrc) && ($imgsrc ne '/adm/lonKaputt/lonlogo_broken.gif')) {
2726: return '<img src="'.$imgsrc.'" align="right" />';
2727: } else {
2728: return '';
2729: }
2730: }
2731:
1.112 bowersj2 2732: =pod
2733:
2734: =back
2735:
2736: =head1 Access .tab File Data
2737:
2738: =over 4
2739:
1.648 raeburn 2740: =item * &languageids()
1.112 bowersj2 2741:
2742: returns list of all language ids
2743:
2744: =cut
2745:
1.14 harris41 2746: sub languageids {
1.16 harris41 2747: return sort(keys(%language));
1.14 harris41 2748: }
2749:
1.112 bowersj2 2750: =pod
2751:
1.648 raeburn 2752: =item * &languagedescription()
1.112 bowersj2 2753:
2754: returns description of a specified language id
2755:
2756: =cut
2757:
1.14 harris41 2758: sub languagedescription {
1.125 www 2759: my $code=shift;
2760: return ($supported_language{$code}?'* ':'').
2761: $language{$code}.
1.126 www 2762: ($supported_language{$code}?' ('.&mt('interface available').')':'');
1.145 www 2763: }
2764:
2765: sub plainlanguagedescription {
2766: my $code=shift;
2767: return $language{$code};
2768: }
2769:
2770: sub supportedlanguagecode {
2771: my $code=shift;
2772: return $supported_language{$code};
1.97 www 2773: }
2774:
1.112 bowersj2 2775: =pod
2776:
1.648 raeburn 2777: =item * ©rightids()
1.112 bowersj2 2778:
2779: returns list of all copyrights
2780:
2781: =cut
2782:
2783: sub copyrightids {
2784: return sort(keys(%cprtag));
2785: }
2786:
2787: =pod
2788:
1.648 raeburn 2789: =item * ©rightdescription()
1.112 bowersj2 2790:
2791: returns description of a specified copyright id
2792:
2793: =cut
2794:
2795: sub copyrightdescription {
1.166 www 2796: return &mt($cprtag{shift(@_)});
1.112 bowersj2 2797: }
1.197 matthew 2798:
2799: =pod
2800:
1.648 raeburn 2801: =item * &source_copyrightids()
1.192 taceyjo1 2802:
2803: returns list of all source copyrights
2804:
2805: =cut
2806:
2807: sub source_copyrightids {
2808: return sort(keys(%scprtag));
2809: }
2810:
2811: =pod
2812:
1.648 raeburn 2813: =item * &source_copyrightdescription()
1.192 taceyjo1 2814:
2815: returns description of a specified source copyright id
2816:
2817: =cut
2818:
2819: sub source_copyrightdescription {
2820: return &mt($scprtag{shift(@_)});
2821: }
1.112 bowersj2 2822:
2823: =pod
2824:
1.648 raeburn 2825: =item * &filecategories()
1.112 bowersj2 2826:
2827: returns list of all file categories
2828:
2829: =cut
2830:
2831: sub filecategories {
2832: return sort(keys(%category_extensions));
2833: }
2834:
2835: =pod
2836:
1.648 raeburn 2837: =item * &filecategorytypes()
1.112 bowersj2 2838:
2839: returns list of file types belonging to a given file
2840: category
2841:
2842: =cut
2843:
2844: sub filecategorytypes {
1.356 albertel 2845: my ($cat) = @_;
2846: return @{$category_extensions{lc($cat)}};
1.112 bowersj2 2847: }
2848:
2849: =pod
2850:
1.648 raeburn 2851: =item * &fileembstyle()
1.112 bowersj2 2852:
2853: returns embedding style for a specified file type
2854:
2855: =cut
2856:
2857: sub fileembstyle {
2858: return $fe{lc(shift(@_))};
1.169 www 2859: }
2860:
1.351 www 2861: sub filemimetype {
2862: return $fm{lc(shift(@_))};
2863: }
2864:
1.169 www 2865:
2866: sub filecategoryselect {
2867: my ($name,$value)=@_;
1.189 matthew 2868: return &select_form($value,$name,
1.169 www 2869: '' => &mt('Any category'),
2870: map { $_,$_ } sort(keys(%category_extensions)));
1.112 bowersj2 2871: }
2872:
2873: =pod
2874:
1.648 raeburn 2875: =item * &filedescription()
1.112 bowersj2 2876:
2877: returns description for a specified file type
2878:
2879: =cut
2880:
2881: sub filedescription {
1.188 matthew 2882: my $file_description = $fd{lc(shift())};
2883: $file_description =~ s:([\[\]]):~$1:g;
2884: return &mt($file_description);
1.112 bowersj2 2885: }
2886:
2887: =pod
2888:
1.648 raeburn 2889: =item * &filedescriptionex()
1.112 bowersj2 2890:
2891: returns description for a specified file type with
2892: extra formatting
2893:
2894: =cut
2895:
2896: sub filedescriptionex {
2897: my $ex=shift;
1.188 matthew 2898: my $file_description = $fd{lc($ex)};
2899: $file_description =~ s:([\[\]]):~$1:g;
2900: return '.'.$ex.' '.&mt($file_description);
1.112 bowersj2 2901: }
2902:
2903: # End of .tab access
2904: =pod
2905:
2906: =back
2907:
2908: =cut
2909:
2910: # ------------------------------------------------------------------ File Types
2911: sub fileextensions {
2912: return sort(keys(%fe));
2913: }
2914:
1.97 www 2915: # ----------------------------------------------------------- Display Languages
2916: # returns a hash with all desired display languages
2917: #
2918:
2919: sub display_languages {
2920: my %languages=();
1.356 albertel 2921: foreach my $lang (&preferred_languages()) {
2922: $languages{$lang}=1;
1.97 www 2923: }
2924: &get_unprocessed_cgi($ENV{'QUERY_STRING'},['displaylanguage']);
1.258 albertel 2925: if ($env{'form.displaylanguage'}) {
1.356 albertel 2926: foreach my $lang (split(/\s*(\,|\;|\:)\s*/,$env{'form.displaylanguage'})) {
2927: $languages{$lang}=1;
1.97 www 2928: }
2929: }
2930: return %languages;
1.14 harris41 2931: }
2932:
1.117 www 2933: sub preferred_languages {
2934: my @languages=();
1.654 www 2935: if (($env{'request.role.adv'}) && ($env{'form.languages'})) {
2936: @languages=(@languages,split(/\s*(\,|\;|\:)\s*/,$env{'form.languages'}));
2937: }
1.258 albertel 2938: if ($env{'course.'.$env{'request.course.id'}.'.languages'}) {
1.117 www 2939: @languages=(@languages,split(/\s*(\,|\;|\:)\s*/,
1.258 albertel 2940: $env{'course.'.$env{'request.course.id'}.'.languages'}));
1.177 www 2941: }
1.654 www 2942:
1.258 albertel 2943: if ($env{'environment.languages'}) {
1.459 albertel 2944: @languages=(@languages,
2945: split(/\s*(\,|\;|\:)\s*/,$env{'environment.languages'}));
1.118 www 2946: }
1.583 albertel 2947: my $browser=$ENV{'HTTP_ACCEPT_LANGUAGE'};
1.162 www 2948: if ($browser) {
1.583 albertel 2949: my @browser =
2950: map { (split(/\s*;\s*/,$_))[0] } (split(/\s*,\s*/,$browser));
2951: push(@languages,@browser);
1.162 www 2952: }
1.641 raeburn 2953:
2954: foreach my $domtype ($env{'user.domain'},$env{'request.role.domain'},
2955: $Apache::lonnet::perlvar{'lonDefDomain'}) {
2956: if ($domtype ne '') {
2957: my %domdefs = &Apache::lonnet::get_domain_defaults($domtype);
2958: if ($domdefs{'lang_def'} ne '') {
2959: push(@languages,$domdefs{'lang_def'});
2960: }
2961: }
1.118 www 2962: }
2963: # turn "en-ca" into "en-ca,en"
2964: my @genlanguages;
1.356 albertel 2965: foreach my $lang (@languages) {
2966: unless ($lang=~/\w/) { next; }
1.583 albertel 2967: push(@genlanguages,$lang);
1.356 albertel 2968: if ($lang=~/(\-|\_)/) {
2969: push(@genlanguages,(split(/(\-|\_)/,$lang))[0]);
1.118 www 2970: }
2971: }
1.583 albertel 2972: #uniqueify the languages list
2973: my %count;
2974: @genlanguages = map { $count{$_}++ == 0 ? $_ : () } @genlanguages;
1.118 www 2975: return @genlanguages;
1.117 www 2976: }
2977:
1.582 albertel 2978: sub languages {
2979: my ($possible_langs) = @_;
2980: my @preferred_langs = &preferred_languages();
2981: if (!ref($possible_langs)) {
2982: if( wantarray ) {
2983: return @preferred_langs;
2984: } else {
2985: return $preferred_langs[0];
2986: }
2987: }
2988: my %possibilities = map { $_ => 1 } (@$possible_langs);
2989: my @preferred_possibilities;
2990: foreach my $preferred_lang (@preferred_langs) {
2991: if (exists($possibilities{$preferred_lang})) {
2992: push(@preferred_possibilities, $preferred_lang);
2993: }
2994: }
2995: if( wantarray ) {
2996: return @preferred_possibilities;
2997: }
2998: return $preferred_possibilities[0];
2999: }
3000:
1.112 bowersj2 3001: ###############################################################
3002: ## Student Answer Attempts ##
3003: ###############################################################
3004:
3005: =pod
3006:
3007: =head1 Alternate Problem Views
3008:
3009: =over 4
3010:
1.648 raeburn 3011: =item * &get_previous_attempt($symb, $username, $domain, $course,
1.112 bowersj2 3012: $getattempt, $regexp, $gradesub)
3013:
3014: Return string with previous attempt on problem. Arguments:
3015:
3016: =over 4
3017:
3018: =item * $symb: Problem, including path
3019:
3020: =item * $username: username of the desired student
3021:
3022: =item * $domain: domain of the desired student
1.14 harris41 3023:
1.112 bowersj2 3024: =item * $course: Course ID
1.14 harris41 3025:
1.112 bowersj2 3026: =item * $getattempt: Leave blank for all attempts, otherwise put
3027: something
1.14 harris41 3028:
1.112 bowersj2 3029: =item * $regexp: if string matches this regexp, the string will be
3030: sent to $gradesub
1.14 harris41 3031:
1.112 bowersj2 3032: =item * $gradesub: routine that processes the string if it matches $regexp
1.14 harris41 3033:
1.112 bowersj2 3034: =back
1.14 harris41 3035:
1.112 bowersj2 3036: The output string is a table containing all desired attempts, if any.
1.16 harris41 3037:
1.112 bowersj2 3038: =cut
1.1 albertel 3039:
3040: sub get_previous_attempt {
1.43 ng 3041: my ($symb,$username,$domain,$course,$getattempt,$regexp,$gradesub)=@_;
1.1 albertel 3042: my $prevattempts='';
1.43 ng 3043: no strict 'refs';
1.1 albertel 3044: if ($symb) {
1.3 albertel 3045: my (%returnhash)=
3046: &Apache::lonnet::restore($symb,$course,$domain,$username);
1.1 albertel 3047: if ($returnhash{'version'}) {
3048: my %lasthash=();
3049: my $version;
3050: for ($version=1;$version<=$returnhash{'version'};$version++) {
1.356 albertel 3051: foreach my $key (sort(split(/\:/,$returnhash{$version.':keys'}))) {
3052: $lasthash{$key}=$returnhash{$version.':'.$key};
1.19 harris41 3053: }
1.1 albertel 3054: }
1.596 albertel 3055: $prevattempts=&start_data_table().&start_data_table_header_row();
3056: $prevattempts.='<th>'.&mt('History').'</th>';
1.356 albertel 3057: foreach my $key (sort(keys(%lasthash))) {
3058: my ($ign,@parts) = split(/\./,$key);
1.41 ng 3059: if ($#parts > 0) {
1.31 albertel 3060: my $data=$parts[-1];
3061: pop(@parts);
1.596 albertel 3062: $prevattempts.='<th>'.&mt('Part ').join('.',@parts).'<br />'.$data.' </th>';
1.31 albertel 3063: } else {
1.41 ng 3064: if ($#parts == 0) {
3065: $prevattempts.='<th>'.$parts[0].'</th>';
3066: } else {
3067: $prevattempts.='<th>'.$ign.'</th>';
3068: }
1.31 albertel 3069: }
1.16 harris41 3070: }
1.596 albertel 3071: $prevattempts.=&end_data_table_header_row();
1.40 ng 3072: if ($getattempt eq '') {
3073: for ($version=1;$version<=$returnhash{'version'};$version++) {
1.596 albertel 3074: $prevattempts.=&start_data_table_row().
3075: '<td>'.&mt('Transaction [_1]',$version).'</td>';
1.356 albertel 3076: foreach my $key (sort(keys(%lasthash))) {
1.581 albertel 3077: my $value = &format_previous_attempt_value($key,
3078: $returnhash{$version.':'.$key});
3079: $prevattempts.='<td>'.$value.' </td>';
1.40 ng 3080: }
1.596 albertel 3081: $prevattempts.=&end_data_table_row();
1.40 ng 3082: }
1.1 albertel 3083: }
1.596 albertel 3084: $prevattempts.=&start_data_table_row().'<td>'.&mt('Current').'</td>';
1.356 albertel 3085: foreach my $key (sort(keys(%lasthash))) {
1.581 albertel 3086: my $value = &format_previous_attempt_value($key,$lasthash{$key});
1.356 albertel 3087: if ($key =~/$regexp$/ && (defined &$gradesub)) {$value = &$gradesub($value)}
1.40 ng 3088: $prevattempts.='<td>'.$value.' </td>';
1.16 harris41 3089: }
1.596 albertel 3090: $prevattempts.= &end_data_table_row().&end_data_table();
1.1 albertel 3091: } else {
1.596 albertel 3092: $prevattempts=
3093: &start_data_table().&start_data_table_row().
3094: '<td>'.&mt('Nothing submitted - no attempts.').'</td>'.
3095: &end_data_table_row().&end_data_table();
1.1 albertel 3096: }
3097: } else {
1.596 albertel 3098: $prevattempts=
3099: &start_data_table().&start_data_table_row().
3100: '<td>'.&mt('No data.').'</td>'.
3101: &end_data_table_row().&end_data_table();
1.1 albertel 3102: }
1.10 albertel 3103: }
3104:
1.581 albertel 3105: sub format_previous_attempt_value {
3106: my ($key,$value) = @_;
3107: if ($key =~ /timestamp/) {
3108: $value = &Apache::lonlocal::locallocaltime($value);
3109: } elsif (ref($value) eq 'ARRAY') {
3110: $value = '('.join(', ', @{ $value }).')';
3111: } else {
3112: $value = &unescape($value);
3113: }
3114: return $value;
3115: }
3116:
3117:
1.107 albertel 3118: sub relative_to_absolute {
3119: my ($url,$output)=@_;
3120: my $parser=HTML::TokeParser->new(\$output);
3121: my $token;
3122: my $thisdir=$url;
3123: my @rlinks=();
3124: while ($token=$parser->get_token) {
3125: if ($token->[0] eq 'S') {
3126: if ($token->[1] eq 'a') {
3127: if ($token->[2]->{'href'}) {
3128: $rlinks[$#rlinks+1]=$token->[2]->{'href'};
3129: }
3130: } elsif ($token->[1] eq 'img' || $token->[1] eq 'embed' ) {
3131: $rlinks[$#rlinks+1]=$token->[2]->{'src'};
3132: } elsif ($token->[1] eq 'base') {
3133: $thisdir=$token->[2]->{'href'};
3134: }
3135: }
3136: }
3137: $thisdir=~s-/[^/]*$--;
1.356 albertel 3138: foreach my $link (@rlinks) {
3139: unless (($link=~/^http:\/\//i) ||
3140: ($link=~/^\//) ||
3141: ($link=~/^javascript:/i) ||
3142: ($link=~/^mailto:/i) ||
3143: ($link=~/^\#/)) {
3144: my $newlocation=&Apache::lonnet::hreflocation($thisdir,$link);
3145: $output=~s/(\"|\'|\=\s*)\Q$link\E(\"|\'|\s|\>)/$1$newlocation$2/;
1.107 albertel 3146: }
3147: }
3148: # -------------------------------------------------- Deal with Applet codebases
3149: $output=~s/(\<applet[^\>]+)(codebase\=[^\S\>]+)*([^\>]*)\>/$1.($2?$2:' codebase="'.$thisdir.'"').$3.'>'/gei;
3150: return $output;
3151: }
3152:
1.112 bowersj2 3153: =pod
3154:
1.648 raeburn 3155: =item * &get_student_view()
1.112 bowersj2 3156:
3157: show a snapshot of what student was looking at
3158:
3159: =cut
3160:
1.10 albertel 3161: sub get_student_view {
1.186 albertel 3162: my ($symb,$username,$domain,$courseid,$target,$moreenv) = @_;
1.114 www 3163: my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb);
1.186 albertel 3164: my (%form);
1.10 albertel 3165: my @elements=('symb','courseid','domain','username');
3166: foreach my $element (@elements) {
1.186 albertel 3167: $form{'grade_'.$element}=eval '$'.$element #'
1.10 albertel 3168: }
1.186 albertel 3169: if (defined($moreenv)) {
3170: %form=(%form,%{$moreenv});
3171: }
1.236 albertel 3172: if (defined($target)) { $form{'grade_target'} = $target; }
1.107 albertel 3173: $feedurl=&Apache::lonnet::clutter($feedurl);
1.650 www 3174: my ($userview,$response)=&Apache::lonnet::ssi_body($feedurl,%form);
1.11 albertel 3175: $userview=~s/\<body[^\>]*\>//gi;
3176: $userview=~s/\<\/body\>//gi;
3177: $userview=~s/\<html\>//gi;
3178: $userview=~s/\<\/html\>//gi;
3179: $userview=~s/\<head\>//gi;
3180: $userview=~s/\<\/head\>//gi;
3181: $userview=~s/action\s*\=/would_be_action\=/gi;
1.107 albertel 3182: $userview=&relative_to_absolute($feedurl,$userview);
1.650 www 3183: if (wantarray) {
3184: return ($userview,$response);
3185: } else {
3186: return $userview;
3187: }
3188: }
3189:
3190: sub get_student_view_with_retries {
3191: my ($symb,$retries,$username,$domain,$courseid,$target,$moreenv) = @_;
3192:
3193: my $ok = 0; # True if we got a good response.
3194: my $content;
3195: my $response;
3196:
3197: # Try to get the student_view done. within the retries count:
3198:
3199: do {
3200: ($content, $response) = &get_student_view($symb,$username,$domain,$courseid,$target,$moreenv);
3201: $ok = $response->is_success;
3202: if (!$ok) {
3203: &Apache::lonnet::logthis("Failed get_student_view_with_retries on $symb: ".$response->is_success.', '.$response->code.', '.$response->message);
3204: }
3205: $retries--;
3206: } while (!$ok && ($retries > 0));
3207:
3208: if (!$ok) {
3209: $content = ''; # On error return an empty content.
3210: }
1.651 www 3211: if (wantarray) {
3212: return ($content, $response);
3213: } else {
3214: return $content;
3215: }
1.11 albertel 3216: }
3217:
1.112 bowersj2 3218: =pod
3219:
1.648 raeburn 3220: =item * &get_student_answers()
1.112 bowersj2 3221:
3222: show a snapshot of how student was answering problem
3223:
3224: =cut
3225:
1.11 albertel 3226: sub get_student_answers {
1.100 sakharuk 3227: my ($symb,$username,$domain,$courseid,%form) = @_;
1.114 www 3228: my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb);
1.186 albertel 3229: my (%moreenv);
1.11 albertel 3230: my @elements=('symb','courseid','domain','username');
3231: foreach my $element (@elements) {
1.186 albertel 3232: $moreenv{'grade_'.$element}=eval '$'.$element #'
1.10 albertel 3233: }
1.186 albertel 3234: $moreenv{'grade_target'}='answer';
3235: %moreenv=(%form,%moreenv);
1.497 raeburn 3236: $feedurl = &Apache::lonnet::clutter($feedurl);
3237: my $userview=&Apache::lonnet::ssi($feedurl,%moreenv);
1.10 albertel 3238: return $userview;
1.1 albertel 3239: }
1.116 albertel 3240:
3241: =pod
3242:
3243: =item * &submlink()
3244:
1.242 albertel 3245: Inputs: $text $uname $udom $symb $target
1.116 albertel 3246:
3247: Returns: A link to grades.pm such as to see the SUBM view of a student
3248:
3249: =cut
3250:
3251: ###############################################
3252: sub submlink {
1.242 albertel 3253: my ($text,$uname,$udom,$symb,$target)=@_;
1.116 albertel 3254: if (!($uname && $udom)) {
3255: (my $cursymb, my $courseid,$udom,$uname)=
1.463 albertel 3256: &Apache::lonnet::whichuser($symb);
1.116 albertel 3257: if (!$symb) { $symb=$cursymb; }
3258: }
1.254 matthew 3259: if (!$symb) { $symb=&Apache::lonnet::symbread(); }
1.369 www 3260: $symb=&escape($symb);
1.242 albertel 3261: if ($target) { $target="target=\"$target\""; }
3262: return '<a href="/adm/grades?&command=submission&'.
3263: 'symb='.$symb.'&student='.$uname.
3264: '&userdom='.$udom.'" '.$target.'>'.$text.'</a>';
3265: }
3266: ##############################################
3267:
3268: =pod
3269:
3270: =item * &pgrdlink()
3271:
3272: Inputs: $text $uname $udom $symb $target
3273:
3274: Returns: A link to grades.pm such as to see the PGRD view of a student
3275:
3276: =cut
3277:
3278: ###############################################
3279: sub pgrdlink {
3280: my $link=&submlink(@_);
3281: $link=~s/(&command=submission)/$1&showgrading=yes/;
3282: return $link;
3283: }
3284: ##############################################
3285:
3286: =pod
3287:
3288: =item * &pprmlink()
3289:
3290: Inputs: $text $uname $udom $symb $target
3291:
3292: Returns: A link to parmset.pm such as to see the PPRM view of a
1.283 albertel 3293: student and a specific resource
1.242 albertel 3294:
3295: =cut
3296:
3297: ###############################################
3298: sub pprmlink {
3299: my ($text,$uname,$udom,$symb,$target)=@_;
3300: if (!($uname && $udom)) {
3301: (my $cursymb, my $courseid,$udom,$uname)=
1.463 albertel 3302: &Apache::lonnet::whichuser($symb);
1.242 albertel 3303: if (!$symb) { $symb=$cursymb; }
3304: }
1.254 matthew 3305: if (!$symb) { $symb=&Apache::lonnet::symbread(); }
1.369 www 3306: $symb=&escape($symb);
1.242 albertel 3307: if ($target) { $target="target=\"$target\""; }
1.595 albertel 3308: return '<a href="/adm/parmset?command=set&'.
3309: 'symb='.$symb.'&uname='.$uname.
3310: '&udom='.$udom.'" '.$target.'>'.$text.'</a>';
1.116 albertel 3311: }
3312: ##############################################
1.37 matthew 3313:
1.112 bowersj2 3314: =pod
3315:
3316: =back
3317:
3318: =cut
3319:
1.37 matthew 3320: ###############################################
1.51 www 3321:
3322:
3323: sub timehash {
3324: my @ltime=localtime(shift);
3325: return ( 'seconds' => $ltime[0],
3326: 'minutes' => $ltime[1],
3327: 'hours' => $ltime[2],
3328: 'day' => $ltime[3],
3329: 'month' => $ltime[4]+1,
3330: 'year' => $ltime[5]+1900,
3331: 'weekday' => $ltime[6],
3332: 'dayyear' => $ltime[7]+1,
3333: 'dlsav' => $ltime[8] );
3334: }
3335:
1.370 www 3336: sub utc_string {
3337: my ($date)=@_;
1.371 www 3338: return strftime("%Y%m%dT%H%M%SZ",gmtime($date));
1.370 www 3339: }
3340:
1.51 www 3341: sub maketime {
3342: my %th=@_;
3343: return POSIX::mktime(
3344: ($th{'seconds'},$th{'minutes'},$th{'hours'},
1.210 www 3345: $th{'day'},$th{'month'}-1,$th{'year'}-1900,0,0,-1));
1.70 www 3346: }
3347:
3348: #########################################
1.51 www 3349:
3350: sub findallcourses {
1.482 raeburn 3351: my ($roles,$uname,$udom) = @_;
1.355 albertel 3352: my %roles;
3353: if (ref($roles)) { %roles = map { $_ => 1 } @{$roles}; }
1.348 albertel 3354: my %courses;
1.51 www 3355: my $now=time;
1.482 raeburn 3356: if (!defined($uname)) {
3357: $uname = $env{'user.name'};
3358: }
3359: if (!defined($udom)) {
3360: $udom = $env{'user.domain'};
3361: }
3362: if (($uname ne $env{'user.name'}) || ($udom ne $env{'user.domain'})) {
3363: my %roleshash = &Apache::lonnet::dump('roles',$udom,$uname);
3364: if (!%roles) {
3365: %roles = (
3366: cc => 1,
3367: in => 1,
3368: ep => 1,
3369: ta => 1,
3370: cr => 1,
3371: st => 1,
3372: );
3373: }
3374: foreach my $entry (keys(%roleshash)) {
3375: my ($trole,$tend,$tstart) = split(/_/,$roleshash{$entry});
3376: if ($trole =~ /^cr/) {
3377: next if (!exists($roles{$trole}) && !exists($roles{'cr'}));
3378: } else {
3379: next if (!exists($roles{$trole}));
3380: }
3381: if ($tend) {
3382: next if ($tend < $now);
3383: }
3384: if ($tstart) {
3385: next if ($tstart > $now);
3386: }
3387: my ($cdom,$cnum,$sec,$cnumpart,$secpart,$role,$realsec);
3388: (undef,$cdom,$cnumpart,$secpart) = split(/\//,$entry);
3389: if ($secpart eq '') {
3390: ($cnum,$role) = split(/_/,$cnumpart);
3391: $sec = 'none';
3392: $realsec = '';
3393: } else {
3394: $cnum = $cnumpart;
3395: ($sec,$role) = split(/_/,$secpart);
3396: $realsec = $sec;
1.490 raeburn 3397: }
1.482 raeburn 3398: $courses{$cdom.'_'.$cnum}{$sec} = $trole.'/'.$cdom.'/'.$cnum.'/'.$realsec;
3399: }
3400: } else {
3401: foreach my $key (keys(%env)) {
1.483 albertel 3402: if ( $key=~m{^user\.role\.(\w+)\./($match_domain)/($match_courseid)/?(\w*)$} ||
3403: $key=~m{^user\.role\.(cr/$match_domain/$match_username/\w+)\./($match_domain)/($match_courseid)/?(\w*)$}) {
1.482 raeburn 3404: my ($role,$cdom,$cnum,$sec) = ($1,$2,$3,$4);
3405: next if ($role eq 'ca' || $role eq 'aa');
3406: next if (%roles && !exists($roles{$role}));
3407: my ($starttime,$endtime)=split(/\./,$env{$key});
3408: my $active=1;
3409: if ($starttime) {
3410: if ($now<$starttime) { $active=0; }
3411: }
3412: if ($endtime) {
3413: if ($now>$endtime) { $active=0; }
3414: }
3415: if ($active) {
3416: if ($sec eq '') {
3417: $sec = 'none';
3418: }
3419: $courses{$cdom.'_'.$cnum}{$sec} =
3420: $role.'/'.$cdom.'/'.$cnum.'/'.$sec;
1.474 raeburn 3421: }
3422: }
1.51 www 3423: }
3424: }
1.474 raeburn 3425: return %courses;
1.51 www 3426: }
1.37 matthew 3427:
1.54 www 3428: ###############################################
1.474 raeburn 3429:
3430: sub blockcheck {
1.482 raeburn 3431: my ($setters,$activity,$uname,$udom) = @_;
1.490 raeburn 3432:
3433: if (!defined($udom)) {
3434: $udom = $env{'user.domain'};
3435: }
3436: if (!defined($uname)) {
3437: $uname = $env{'user.name'};
3438: }
3439:
3440: # If uname and udom are for a course, check for blocks in the course.
3441:
3442: if (&Apache::lonnet::is_course($udom,$uname)) {
3443: my %records = &Apache::lonnet::dump('comm_block',$udom,$uname);
1.502 raeburn 3444: my ($startblock,$endblock)=&get_blocks($setters,$activity,$udom,$uname);
1.490 raeburn 3445: return ($startblock,$endblock);
3446: }
1.474 raeburn 3447:
1.502 raeburn 3448: my $startblock = 0;
3449: my $endblock = 0;
1.482 raeburn 3450: my %live_courses = &findallcourses(undef,$uname,$udom);
1.474 raeburn 3451:
1.490 raeburn 3452: # If uname is for a user, and activity is course-specific, i.e.,
3453: # boards, chat or groups, check for blocking in current course only.
1.474 raeburn 3454:
1.490 raeburn 3455: if (($activity eq 'boards' || $activity eq 'chat' ||
3456: $activity eq 'groups') && ($env{'request.course.id'})) {
3457: foreach my $key (keys(%live_courses)) {
3458: if ($key ne $env{'request.course.id'}) {
3459: delete($live_courses{$key});
3460: }
3461: }
3462: }
3463:
3464: my $otheruser = 0;
3465: my %own_courses;
3466: if ((($uname ne $env{'user.name'})) || ($udom ne $env{'user.domain'})) {
3467: # Resource belongs to user other than current user.
3468: $otheruser = 1;
3469: # Gather courses for current user
3470: %own_courses =
3471: &findallcourses(undef,$env{'user.name'},$env{'user.domain'});
3472: }
3473:
3474: # Gather active course roles - course coordinator, instructor,
3475: # exam proctor, ta, student, or custom role.
1.474 raeburn 3476:
3477: foreach my $course (keys(%live_courses)) {
1.482 raeburn 3478: my ($cdom,$cnum);
3479: if ((defined($env{'course.'.$course.'.domain'})) && (defined($env{'course.'.$course.'.num'}))) {
3480: $cdom = $env{'course.'.$course.'.domain'};
3481: $cnum = $env{'course.'.$course.'.num'};
3482: } else {
1.490 raeburn 3483: ($cdom,$cnum) = split(/_/,$course);
1.482 raeburn 3484: }
3485: my $no_ownblock = 0;
3486: my $no_userblock = 0;
1.533 raeburn 3487: if ($otheruser && $activity ne 'com') {
1.490 raeburn 3488: # Check if current user has 'evb' priv for this
3489: if (defined($own_courses{$course})) {
3490: foreach my $sec (keys(%{$own_courses{$course}})) {
3491: my $checkrole = 'cm./'.$cdom.'/'.$cnum;
3492: if ($sec ne 'none') {
3493: $checkrole .= '/'.$sec;
3494: }
3495: if (&Apache::lonnet::allowed('evb',undef,undef,$checkrole)) {
3496: $no_ownblock = 1;
3497: last;
3498: }
3499: }
3500: }
3501: # if they have 'evb' priv and are currently not playing student
3502: next if (($no_ownblock) &&
3503: ($env{'request.role'} !~ m{^st\./$cdom/$cnum}));
3504: }
1.474 raeburn 3505: foreach my $sec (keys(%{$live_courses{$course}})) {
1.482 raeburn 3506: my $checkrole = 'cm./'.$cdom.'/'.$cnum;
1.474 raeburn 3507: if ($sec ne 'none') {
1.482 raeburn 3508: $checkrole .= '/'.$sec;
1.474 raeburn 3509: }
1.490 raeburn 3510: if ($otheruser) {
3511: # Resource belongs to user other than current user.
3512: # Assemble privs for that user, and check for 'evb' priv.
1.482 raeburn 3513: my ($trole,$tdom,$tnum,$tsec);
3514: my $entry = $live_courses{$course}{$sec};
3515: if ($entry =~ /^cr/) {
3516: ($trole,$tdom,$tnum,$tsec) =
3517: ($entry =~ m|^(cr/$match_domain/$match_username/\w+)\./($match_domain)/($match_username)/?(\w*)$|);
3518: } else {
3519: ($trole,$tdom,$tnum,$tsec) = split(/\//,$entry);
3520: }
3521: my ($spec,$area,$trest,%allroles,%userroles);
3522: $area = '/'.$tdom.'/'.$tnum;
3523: $trest = $tnum;
3524: if ($tsec ne '') {
3525: $area .= '/'.$tsec;
3526: $trest .= '/'.$tsec;
3527: }
3528: $spec = $trole.'.'.$area;
3529: if ($trole =~ /^cr/) {
3530: &Apache::lonnet::custom_roleprivs(\%allroles,$trole,
3531: $tdom,$spec,$trest,$area);
3532: } else {
3533: &Apache::lonnet::standard_roleprivs(\%allroles,$trole,
3534: $tdom,$spec,$trest,$area);
3535: }
3536: my ($author,$adv) = &Apache::lonnet::set_userprivs(\%userroles,\%allroles);
1.486 raeburn 3537: if ($userroles{'user.priv.'.$checkrole} =~ /evb\&([^\:]*)/) {
3538: if ($1) {
3539: $no_userblock = 1;
3540: last;
3541: }
3542: }
1.490 raeburn 3543: } else {
3544: # Resource belongs to current user
3545: # Check for 'evb' priv via lonnet::allowed().
1.482 raeburn 3546: if (&Apache::lonnet::allowed('evb',undef,undef,$checkrole)) {
3547: $no_ownblock = 1;
3548: last;
3549: }
1.474 raeburn 3550: }
3551: }
3552: # if they have the evb priv and are currently not playing student
1.482 raeburn 3553: next if (($no_ownblock) &&
1.491 albertel 3554: ($env{'request.role'} !~ m{^st\./\Q$cdom\E/\Q$cnum\E}));
1.482 raeburn 3555: next if ($no_userblock);
1.474 raeburn 3556:
1.490 raeburn 3557: # Retrieve blocking times and identity of blocker for course
3558: # of specified user, unless user has 'evb' privilege.
1.502 raeburn 3559:
3560: my ($start,$end)=&get_blocks($setters,$activity,$cdom,$cnum);
3561: if (($start != 0) &&
3562: (($startblock == 0) || ($startblock > $start))) {
3563: $startblock = $start;
3564: }
3565: if (($end != 0) &&
3566: (($endblock == 0) || ($endblock < $end))) {
3567: $endblock = $end;
3568: }
1.490 raeburn 3569: }
3570: return ($startblock,$endblock);
3571: }
3572:
3573: sub get_blocks {
3574: my ($setters,$activity,$cdom,$cnum) = @_;
3575: my $startblock = 0;
3576: my $endblock = 0;
3577: my $course = $cdom.'_'.$cnum;
3578: $setters->{$course} = {};
3579: $setters->{$course}{'staff'} = [];
3580: $setters->{$course}{'times'} = [];
3581: my %records = &Apache::lonnet::dump('comm_block',$cdom,$cnum);
3582: foreach my $record (keys(%records)) {
3583: my ($start,$end) = ($record =~ m/^(\d+)____(\d+)$/);
3584: if ($start <= time && $end >= time) {
3585: my ($staff_name,$staff_dom,$title,$blocks) =
3586: &parse_block_record($records{$record});
3587: if ($blocks->{$activity} eq 'on') {
3588: push(@{$$setters{$course}{'staff'}},[$staff_name,$staff_dom]);
3589: push(@{$$setters{$course}{'times'}}, [$start,$end]);
1.491 albertel 3590: if ( ($startblock == 0) || ($startblock > $start) ) {
3591: $startblock = $start;
1.490 raeburn 3592: }
1.491 albertel 3593: if ( ($endblock == 0) || ($endblock < $end) ) {
3594: $endblock = $end;
1.474 raeburn 3595: }
3596: }
3597: }
3598: }
3599: return ($startblock,$endblock);
3600: }
3601:
3602: sub parse_block_record {
3603: my ($record) = @_;
3604: my ($setuname,$setudom,$title,$blocks);
3605: if (ref($record) eq 'HASH') {
3606: ($setuname,$setudom) = split(/:/,$record->{'setter'});
3607: $title = &unescape($record->{'event'});
3608: $blocks = $record->{'blocks'};
3609: } else {
3610: my @data = split(/:/,$record,3);
3611: if (scalar(@data) eq 2) {
3612: $title = $data[1];
3613: ($setuname,$setudom) = split(/@/,$data[0]);
3614: } else {
3615: ($setuname,$setudom,$title) = @data;
3616: }
3617: $blocks = { 'com' => 'on' };
3618: }
3619: return ($setuname,$setudom,$title,$blocks);
3620: }
3621:
3622: sub build_block_table {
3623: my ($startblock,$endblock,$setters) = @_;
3624: my %lt = &Apache::lonlocal::texthash(
3625: 'cacb' => 'Currently active communication blocks',
3626: 'cour' => 'Course',
3627: 'dura' => 'Duration',
3628: 'blse' => 'Block set by'
3629: );
3630: my $output;
1.476 raeburn 3631: $output = '<br />'.$lt{'cacb'}.':<br />';
1.474 raeburn 3632: $output .= &start_data_table();
3633: $output .= '
3634: <tr>
3635: <th>'.$lt{'cour'}.'</th>
3636: <th>'.$lt{'dura'}.'</th>
3637: <th>'.$lt{'blse'}.'</th>
3638: </tr>
3639: ';
3640: foreach my $course (keys(%{$setters})) {
3641: my %courseinfo=&Apache::lonnet::coursedescription($course);
3642: for (my $i=0; $i<@{$$setters{$course}{staff}}; $i++) {
3643: my ($uname,$udom) = @{$$setters{$course}{staff}[$i]};
1.490 raeburn 3644: my $fullname = &plainname($uname,$udom);
3645: if (defined($env{'user.name'}) && defined($env{'user.domain'})
3646: && $env{'user.name'} ne 'public'
3647: && $env{'user.domain'} ne 'public') {
3648: $fullname = &aboutmewrapper($fullname,$uname,$udom);
3649: }
1.474 raeburn 3650: my ($openblock,$closeblock) = @{$$setters{$course}{times}[$i]};
3651: $openblock = &Apache::lonlocal::locallocaltime($openblock);
3652: $closeblock= &Apache::lonlocal::locallocaltime($closeblock);
3653: $output .= &Apache::loncommon::start_data_table_row().
3654: '<td>'.$courseinfo{'description'}.'</td>'.
3655: '<td>'.$openblock.' to '.$closeblock.'</td>'.
1.490 raeburn 3656: '<td>'.$fullname.'</td>'.
1.474 raeburn 3657: &Apache::loncommon::end_data_table_row();
3658: }
3659: }
3660: $output .= &end_data_table();
3661: }
3662:
1.490 raeburn 3663: sub blocking_status {
3664: my ($activity,$uname,$udom) = @_;
3665: my %setters;
3666: my ($blocked,$output,$ownitem,$is_course);
3667: my ($startblock,$endblock)=&blockcheck(\%setters,$activity,$uname,$udom);
3668: if ($startblock && $endblock) {
3669: $blocked = 1;
3670: if (wantarray) {
3671: my $category;
3672: if ($activity eq 'boards') {
3673: $category = 'Discussion posts in this course';
3674: } elsif ($activity eq 'blogs') {
3675: $category = 'Blogs';
3676: } elsif ($activity eq 'port') {
3677: if (defined($uname) && defined($udom)) {
3678: if ($uname eq $env{'user.name'} &&
3679: $udom eq $env{'user.domain'}) {
3680: $ownitem = 1;
3681: }
3682: }
3683: $is_course = &Apache::lonnet::is_course($udom,$uname);
3684: if ($ownitem) {
3685: $category = 'Your portfolio files';
3686: } elsif ($is_course) {
3687: my $coursedesc;
3688: foreach my $course (keys(%setters)) {
3689: my %courseinfo =
3690: &Apache::lonnet::coursedescription($course);
3691: $coursedesc = $courseinfo{'description'};
3692: }
3693: $category = "Group files in the course '$coursedesc'";
3694: } else {
3695: $category = 'Portfolio files belonging to ';
3696: if ($env{'user.name'} eq 'public' &&
3697: $env{'user.domain'} eq 'public') {
3698: $category .= &plainname($uname,$udom);
3699: } else {
3700: $category .= &aboutmewrapper(&plainname($uname,$udom),$uname,$udom);
3701: }
3702: }
3703: } elsif ($activity eq 'groups') {
3704: $category = 'Groups in this course';
3705: }
3706: my $showstart = &Apache::lonlocal::locallocaltime($startblock);
3707: my $showend = &Apache::lonlocal::locallocaltime($endblock);
3708: $output = '<br />'.&mt('[_1] will be inaccessible between [_2] and [_3] because communication is being blocked.',$category,$showstart,$showend).'<br />';
3709: if (!($activity eq 'port' && !($ownitem) && !($is_course))) {
3710: $output .= &build_block_table($startblock,$endblock,\%setters);
3711: }
3712: }
3713: }
3714: if (wantarray) {
3715: return ($blocked,$output);
3716: } else {
3717: return $blocked;
3718: }
3719: }
3720:
1.60 matthew 3721: ###############################################
3722:
3723: =pod
3724:
1.112 bowersj2 3725: =head1 Domain Template Functions
3726:
3727: =over 4
3728:
3729: =item * &determinedomain()
1.60 matthew 3730:
3731: Inputs: $domain (usually will be undef)
3732:
1.63 www 3733: Returns: Determines which domain should be used for designs
1.60 matthew 3734:
3735: =cut
1.54 www 3736:
1.60 matthew 3737: ###############################################
1.63 www 3738: sub determinedomain {
3739: my $domain=shift;
1.531 albertel 3740: if (! $domain) {
1.60 matthew 3741: # Determine domain if we have not been given one
3742: $domain = $Apache::lonnet::perlvar{'lonDefDomain'};
1.258 albertel 3743: if ($env{'user.domain'}) { $domain=$env{'user.domain'}; }
3744: if ($env{'request.role.domain'}) {
3745: $domain=$env{'request.role.domain'};
1.60 matthew 3746: }
3747: }
1.63 www 3748: return $domain;
3749: }
3750: ###############################################
1.517 raeburn 3751:
1.518 albertel 3752: sub devalidate_domconfig_cache {
3753: my ($udom)=@_;
3754: &Apache::lonnet::devalidate_cache_new('domainconfig',$udom);
3755: }
3756:
3757: # ---------------------- Get domain configuration for a domain
3758: sub get_domainconf {
3759: my ($udom) = @_;
3760: my $cachetime=1800;
3761: my ($result,$cached)=&Apache::lonnet::is_cached_new('domainconfig',$udom);
3762: if (defined($cached)) { return %{$result}; }
3763:
3764: my %domconfig = &Apache::lonnet::get_dom('configuration',
3765: ['login','rolecolors'],$udom);
1.632 raeburn 3766: my (%designhash,%legacy);
1.518 albertel 3767: if (keys(%domconfig) > 0) {
3768: if (ref($domconfig{'login'}) eq 'HASH') {
1.632 raeburn 3769: if (keys(%{$domconfig{'login'}})) {
3770: foreach my $key (keys(%{$domconfig{'login'}})) {
3771: $designhash{$udom.'.login.'.$key}=$domconfig{'login'}{$key};
3772: }
3773: } else {
3774: $legacy{'login'} = 1;
1.518 albertel 3775: }
1.632 raeburn 3776: } else {
3777: $legacy{'login'} = 1;
1.518 albertel 3778: }
3779: if (ref($domconfig{'rolecolors'}) eq 'HASH') {
1.632 raeburn 3780: if (keys(%{$domconfig{'rolecolors'}})) {
3781: foreach my $role (keys(%{$domconfig{'rolecolors'}})) {
3782: if (ref($domconfig{'rolecolors'}{$role}) eq 'HASH') {
3783: foreach my $item (keys(%{$domconfig{'rolecolors'}{$role}})) {
3784: $designhash{$udom.'.'.$role.'.'.$item}=$domconfig{'rolecolors'}{$role}{$item};
3785: }
1.518 albertel 3786: }
3787: }
1.632 raeburn 3788: } else {
3789: $legacy{'rolecolors'} = 1;
1.518 albertel 3790: }
1.632 raeburn 3791: } else {
3792: $legacy{'rolecolors'} = 1;
1.518 albertel 3793: }
1.632 raeburn 3794: if (keys(%legacy) > 0) {
3795: my %legacyhash = &get_legacy_domconf($udom);
3796: foreach my $item (keys(%legacyhash)) {
3797: if ($item =~ /^\Q$udom\E\.login/) {
3798: if ($legacy{'login'}) {
3799: $designhash{$item} = $legacyhash{$item};
3800: }
3801: } else {
3802: if ($legacy{'rolecolors'}) {
3803: $designhash{$item} = $legacyhash{$item};
3804: }
1.518 albertel 3805: }
3806: }
3807: }
1.632 raeburn 3808: } else {
3809: %designhash = &get_legacy_domconf($udom);
1.518 albertel 3810: }
3811: &Apache::lonnet::do_cache_new('domainconfig',$udom,\%designhash,
3812: $cachetime);
3813: return %designhash;
3814: }
3815:
1.632 raeburn 3816: sub get_legacy_domconf {
3817: my ($udom) = @_;
3818: my %legacyhash;
3819: my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors';
3820: my $designfile = $designdir.'/'.$udom.'.tab';
3821: if (-e $designfile) {
3822: if ( open (my $fh,"<$designfile") ) {
3823: while (my $line = <$fh>) {
3824: next if ($line =~ /^\#/);
3825: chomp($line);
3826: my ($key,$val)=(split(/\=/,$line));
3827: if ($val) { $legacyhash{$udom.'.'.$key}=$val; }
3828: }
3829: close($fh);
3830: }
3831: }
3832: if (-e '/home/httpd/html/adm/lonDomLogos/'.$udom.'.gif') {
3833: $legacyhash{$udom.'.login.domlogo'} = "/adm/lonDomLogos/$udom.gif";
3834: }
3835: return %legacyhash;
3836: }
3837:
1.63 www 3838: =pod
3839:
1.112 bowersj2 3840: =item * &domainlogo()
1.63 www 3841:
3842: Inputs: $domain (usually will be undef)
3843:
3844: Returns: A link to a domain logo, if the domain logo exists.
3845: If the domain logo does not exist, a description of the domain.
3846:
3847: =cut
1.112 bowersj2 3848:
1.63 www 3849: ###############################################
3850: sub domainlogo {
1.517 raeburn 3851: my $domain = &determinedomain(shift);
1.518 albertel 3852: my %designhash = &get_domainconf($domain);
1.517 raeburn 3853: # See if there is a logo
3854: if ($designhash{$domain.'.login.domlogo'} ne '') {
1.519 raeburn 3855: my $imgsrc = $designhash{$domain.'.login.domlogo'};
1.538 albertel 3856: if ($imgsrc =~ m{^/(adm|res)/}) {
3857: if ($imgsrc =~ m{^/res/}) {
3858: my $local_name = &Apache::lonnet::filelocation('',$imgsrc);
3859: &Apache::lonnet::repcopy($local_name);
3860: }
3861: $imgsrc = &lonhttpdurl($imgsrc);
1.519 raeburn 3862: }
3863: return '<img src="'.$imgsrc.'" alt="'.$domain.'" />';
1.514 albertel 3864: } elsif (defined(&Apache::lonnet::domain($domain,'description'))) {
3865: return &Apache::lonnet::domain($domain,'description');
1.59 www 3866: } else {
1.60 matthew 3867: return '';
1.59 www 3868: }
3869: }
1.63 www 3870: ##############################################
3871:
3872: =pod
3873:
1.112 bowersj2 3874: =item * &designparm()
1.63 www 3875:
3876: Inputs: $which parameter; $domain (usually will be undef)
3877:
3878: Returns: value of designparamter $which
3879:
3880: =cut
1.112 bowersj2 3881:
1.397 albertel 3882:
1.400 albertel 3883: ##############################################
1.397 albertel 3884: sub designparm {
3885: my ($which,$domain)=@_;
1.258 albertel 3886: if ($env{'browser.blackwhite'} eq 'on') {
1.635 raeburn 3887: if ($which=~/\.(font|alink|vlink|link|textcol)$/) {
1.110 www 3888: return '#000000';
3889: }
1.635 raeburn 3890: if ($which=~/\.(pgbg|sidebg|bgcol)$/) {
1.110 www 3891: return '#FFFFFF';
3892: }
3893: if ($which=~/\.tabbg$/) {
3894: return '#CCCCCC';
3895: }
3896: }
1.397 albertel 3897: if (exists($env{'environment.color.'.$which})) {
1.258 albertel 3898: return $env{'environment.color.'.$which};
1.96 www 3899: }
1.63 www 3900: $domain=&determinedomain($domain);
1.518 albertel 3901: my %domdesign = &get_domainconf($domain);
1.520 raeburn 3902: my $output;
1.517 raeburn 3903: if ($domdesign{$domain.'.'.$which} ne '') {
1.520 raeburn 3904: $output = $domdesign{$domain.'.'.$which};
1.63 www 3905: } else {
1.520 raeburn 3906: $output = $defaultdesign{$which};
3907: }
3908: if (($which =~ /^(student|coordinator|author|admin)\.img$/) ||
1.635 raeburn 3909: ($which =~ /login\.(img|logo|domlogo|login)/)) {
1.538 albertel 3910: if ($output =~ m{^/(adm|res)/}) {
3911: if ($output =~ m{^/res/}) {
3912: my $local_name = &Apache::lonnet::filelocation('',$output);
3913: &Apache::lonnet::repcopy($local_name);
3914: }
1.520 raeburn 3915: $output = &lonhttpdurl($output);
3916: }
1.63 www 3917: }
1.520 raeburn 3918: return $output;
1.63 www 3919: }
1.59 www 3920:
1.60 matthew 3921: ###############################################
3922: ###############################################
3923:
3924: =pod
3925:
1.112 bowersj2 3926: =back
3927:
1.549 albertel 3928: =head1 HTML Helpers
1.112 bowersj2 3929:
3930: =over 4
3931:
3932: =item * &bodytag()
1.60 matthew 3933:
3934: Returns a uniform header for LON-CAPA web pages.
3935:
3936: Inputs:
3937:
1.112 bowersj2 3938: =over 4
3939:
3940: =item * $title, A title to be displayed on the page.
3941:
3942: =item * $function, the current role (can be undef).
3943:
3944: =item * $addentries, extra parameters for the <body> tag.
3945:
3946: =item * $bodyonly, if defined, only return the <body> tag.
3947:
3948: =item * $domain, if defined, force a given domain.
3949:
3950: =item * $forcereg, if page should register as content page (relevant for
1.86 www 3951: text interface only)
1.60 matthew 3952:
1.326 albertel 3953: =item * $customtitle, alternate text to use instead of $title
3954: in the title box that appears, this text
3955: is not auto translated like the $title is
1.309 albertel 3956:
3957: =item * $notopbar, if true, keep the 'what is this' info but remove the
3958: navigational links
1.317 albertel 3959:
1.338 albertel 3960: =item * $bgcolor, used to override the bgcolor on a webpage to a specific value
3961:
3962: =item * $notitle, if true keep the nav controls, but remove the title bar
3963:
1.361 albertel 3964: =item * $no_inline_link, if true and in remote mode, don't show the
3965: 'Switch To Inline Menu' link
3966:
1.460 albertel 3967: =item * $args, optional argument valid values are
3968: no_auto_mt_title -> prevents &mt()ing the title arg
1.562 albertel 3969: inherit_jsmath -> when creating popup window in a page,
3970: should it have jsmath forced on by the
3971: current page
1.460 albertel 3972:
1.112 bowersj2 3973: =back
3974:
1.60 matthew 3975: Returns: A uniform header for LON-CAPA web pages.
3976: If $bodyonly is nonzero, a string containing a <body> tag will be returned.
3977: If $bodyonly is undef or zero, an html string containing a <body> tag and
3978: other decorations will be returned.
3979:
3980: =cut
3981:
1.54 www 3982: sub bodytag {
1.309 albertel 3983: my ($title,$function,$addentries,$bodyonly,$domain,$forcereg,$customtitle,
1.460 albertel 3984: $notopbar,$bgcolor,$notitle,$no_inline_link,$args)=@_;
1.339 albertel 3985:
1.460 albertel 3986: if (!$args->{'no_auto_mt_title'}) { $title = &mt($title); }
1.339 albertel 3987:
1.183 matthew 3988: $function = &get_users_function() if (!$function);
1.339 albertel 3989: my $img = &designparm($function.'.img',$domain);
3990: my $font = &designparm($function.'.font',$domain);
3991: my $pgbg = $bgcolor || &designparm($function.'.pgbg',$domain);
3992:
3993: my %design = ( 'style' => 'margin-top: 0px',
1.535 albertel 3994: 'bgcolor' => $pgbg,
1.339 albertel 3995: 'text' => $font,
3996: 'alink' => &designparm($function.'.alink',$domain),
3997: 'vlink' => &designparm($function.'.vlink',$domain),
3998: 'link' => &designparm($function.'.link',$domain),);
1.438 albertel 3999: @design{keys(%$addentries)} = @$addentries{keys(%$addentries)};
1.339 albertel 4000:
1.63 www 4001: # role and realm
1.378 raeburn 4002: my ($role,$realm) = split(/\./,$env{'request.role'},2);
4003: if ($role eq 'ca') {
1.479 albertel 4004: my ($rdom,$rname) = ($realm =~ m{^/($match_domain)/($match_username)$});
1.500 albertel 4005: $realm = &plainname($rname,$rdom);
1.378 raeburn 4006: }
1.55 www 4007: # realm
1.258 albertel 4008: if ($env{'request.course.id'}) {
1.378 raeburn 4009: if ($env{'request.role'} !~ /^cr/) {
4010: $role = &Apache::lonnet::plaintext($role,&course_type());
4011: }
1.359 albertel 4012: $realm = $env{'course.'.$env{'request.course.id'}.'.description'};
1.378 raeburn 4013: } else {
4014: $role = &Apache::lonnet::plaintext($role);
1.54 www 4015: }
1.433 albertel 4016:
1.359 albertel 4017: if (!$realm) { $realm=' '; }
1.55 www 4018: # Set messages
1.60 matthew 4019: my $messages=&domainlogo($domain);
1.330 albertel 4020:
1.438 albertel 4021: my $extra_body_attr = &make_attr_string($forcereg,\%design);
1.329 albertel 4022:
1.101 www 4023: # construct main body tag
1.359 albertel 4024: my $bodytag = "<body $extra_body_attr>".
1.562 albertel 4025: &Apache::lontexconvert::init_math_support($args->{'inherit_jsmath'});
1.252 albertel 4026:
1.530 albertel 4027: if ($bodyonly) {
1.60 matthew 4028: return $bodytag;
1.258 albertel 4029: } elsif ($env{'browser.interface'} eq 'textual') {
1.95 www 4030: # Accessibility
1.224 raeburn 4031:
1.337 albertel 4032: $bodytag.=&Apache::lonmenu::menubuttons($forcereg,$forcereg);
1.338 albertel 4033: if (!$notitle) {
1.337 albertel 4034: $bodytag.='<h1>LON-CAPA: '.$title.'</h1>';
4035: }
4036: return $bodytag;
1.359 albertel 4037: }
4038:
1.410 albertel 4039: my $name = &plainname($env{'user.name'},$env{'user.domain'});
1.433 albertel 4040: if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
4041: undef($role);
1.434 albertel 4042: } else {
4043: $name = &aboutmewrapper($name,$env{'user.name'},$env{'user.domain'});
1.433 albertel 4044: }
1.359 albertel 4045:
4046: my $roleinfo=(<<ENDROLE);
4047: <td class="LC_title_bar_who">
4048: <div class="LC_title_bar_name">
1.410 albertel 4049: $name
1.361 albertel 4050:
1.359 albertel 4051: </div>
4052: <div class="LC_title_bar_role">
1.361 albertel 4053: $role
1.359 albertel 4054: </div>
4055: <div class="LC_title_bar_realm">
1.361 albertel 4056: $realm
1.359 albertel 4057: </div>
1.206 albertel 4058: </td>
4059: ENDROLE
1.235 raeburn 4060:
1.359 albertel 4061: my $titleinfo = '<span class="LC_title_bar_title">'.$title.'</span>';
4062: if ($customtitle) {
4063: $titleinfo = $customtitle;
4064: }
4065: #
4066: # Extra info if you are the DC
4067: my $dc_info = '';
4068: if ($env{'user.adv'} && exists($env{'user.role.dc./'.
4069: $env{'course.'.$env{'request.course.id'}.
4070: '.domain'}.'/'})) {
4071: my $cid = $env{'request.course.id'};
4072: $dc_info.= $cid.' '.$env{'course.'.$cid.'.internal.coursecode'};
1.380 www 4073: $dc_info =~ s/\s+$//;
1.359 albertel 4074: $dc_info = '('.$dc_info.')';
4075: }
4076:
1.644 www 4077: if (($env{'environment.remote'} eq 'off') || ($args->{'suppress_header_logos'})) {
1.359 albertel 4078: # No Remote
1.258 albertel 4079: if ($env{'request.state'} eq 'construct') {
1.359 albertel 4080: $forcereg=1;
4081: }
4082:
4083: if (!$customtitle && $env{'request.state'} eq 'construct') {
4084: # this is for resources; directories have customtitle, and crumbs
4085: # and select recent are created in lonpubdir.pm
1.229 albertel 4086: my ($uname,$thisdisfn)=
1.258 albertel 4087: ($env{'request.filename'} =~ m|^/home/([^/]+)/public_html/(.*)|);
1.229 albertel 4088: my $formaction='/priv/'.$uname.'/'.$thisdisfn;
4089: $formaction=~s/\/+/\//g;
4090:
1.359 albertel 4091: my $parentpath = '';
4092: my $lastitem = '';
4093: if ($thisdisfn =~ m-(.+/)([^/]*)$-) {
4094: $parentpath = $1;
4095: $lastitem = $2;
4096: } else {
4097: $lastitem = $thisdisfn;
4098: }
4099: $titleinfo =
1.640 bisitz 4100: &Apache::loncommon::help_open_menu('','',3,'Authoring')
4101: .'<b>'.&mt('Construction Space').'</b>: '
4102: .'<form name="dirs" method="post" action="'.$formaction
1.359 albertel 4103: .'" target="_top"><tt><b>'
4104: .&Apache::lonhtmlcommon::crumbs($uname.'/'.$parentpath,'_top','/priv','','+1',1)."<font size=\"+1\">$lastitem</font></b></tt><br />"
4105: .&Apache::lonhtmlcommon::select_recent('construct','recent','this.form.action=this.form.recent.value;this.form.submit()')
4106: .'</form>'
4107: .&Apache::lonmenu::constspaceform();
1.235 raeburn 4108: }
1.359 albertel 4109:
1.337 albertel 4110: my $titletable;
1.338 albertel 4111: if (!$notitle) {
1.337 albertel 4112: $titletable =
1.359 albertel 4113: '<table id="LC_title_bar">'.
4114: "<tr><td> $titleinfo $dc_info</td>".$roleinfo.
4115: '</tr></table>';
1.337 albertel 4116: }
1.359 albertel 4117: if ($notopbar) {
4118: $bodytag .= $titletable;
4119: } else {
4120: if ($env{'request.state'} eq 'construct') {
1.337 albertel 4121: $bodytag .= &Apache::lonmenu::menubuttons($forcereg,$forcereg,
4122: $titletable);
1.272 raeburn 4123: } else {
1.336 albertel 4124: $bodytag .= &Apache::lonmenu::menubuttons($forcereg,$forcereg).
1.359 albertel 4125: $titletable;
1.272 raeburn 4126: }
1.235 raeburn 4127: }
4128: return $bodytag;
1.94 www 4129: }
1.95 www 4130:
1.93 www 4131: #
1.95 www 4132: # Top frame rendering, Remote is up
1.93 www 4133: #
1.359 albertel 4134:
1.517 raeburn 4135: my $imgsrc = $img;
4136: if ($img =~ /^\/adm/) {
1.575 albertel 4137: $imgsrc = &lonhttpdurl($img);
1.517 raeburn 4138: }
4139: my $upperleft='<img src="'.$imgsrc.'" alt="'.$function.'" />';
1.359 albertel 4140:
1.305 www 4141: # Explicit link to get inline menu
1.361 albertel 4142: my $menu= ($no_inline_link?''
4143: :'<br /><a href="/adm/remote?action=collapse">'.&mt('Switch to Inline Menu Mode').'</a>');
1.245 matthew 4144: #
1.338 albertel 4145: if ($notitle) {
1.337 albertel 4146: return $bodytag;
4147: }
1.94 www 4148: return(<<ENDBODY);
1.60 matthew 4149: $bodytag
1.359 albertel 4150: <table id="LC_title_bar" class="LC_with_remote">
1.368 albertel 4151: <tr><td class="LC_title_bar_role_logo">$upperleft</td>
1.359 albertel 4152: <td class="LC_title_bar_domain_logo">$messages </td>
1.54 www 4153: </tr>
1.359 albertel 4154: <tr><td>$titleinfo $dc_info $menu</td>
4155: $roleinfo
1.368 albertel 4156: </tr>
1.356 albertel 4157: </table>
1.54 www 4158: ENDBODY
1.182 matthew 4159: }
4160:
1.330 albertel 4161: sub make_attr_string {
4162: my ($register,$attr_ref) = @_;
4163:
4164: if ($attr_ref && !ref($attr_ref)) {
4165: die("addentries Must be a hash ref ".
4166: join(':',caller(1))." ".
4167: join(':',caller(0))." ");
4168: }
4169:
4170: if ($register) {
1.339 albertel 4171: my ($on_load,$on_unload);
4172: foreach my $key (keys(%{$attr_ref})) {
4173: if (lc($key) eq 'onload') {
4174: $on_load.=$attr_ref->{$key}.';';
4175: delete($attr_ref->{$key});
4176:
4177: } elsif (lc($key) eq 'onunload') {
4178: $on_unload.=$attr_ref->{$key}.';';
4179: delete($attr_ref->{$key});
4180: }
4181: }
4182: $attr_ref->{'onload'} =
4183: &Apache::lonmenu::loadevents(). $on_load;
4184: $attr_ref->{'onunload'}=
4185: &Apache::lonmenu::unloadevents().$on_unload;
4186: }
4187:
4188: # Accessibility font enhance
4189: if ($env{'browser.fontenhance'} eq 'on') {
4190: my $style;
4191: foreach my $key (keys(%{$attr_ref})) {
4192: if (lc($key) eq 'style') {
4193: $style.=$attr_ref->{$key}.';';
4194: delete($attr_ref->{$key});
4195: }
4196: }
4197: $attr_ref->{'style'}=$style.'; font-size: x-large;';
1.330 albertel 4198: }
1.339 albertel 4199:
4200: if ($env{'browser.blackwhite'} eq 'on') {
4201: delete($attr_ref->{'font'});
4202: delete($attr_ref->{'link'});
4203: delete($attr_ref->{'alink'});
4204: delete($attr_ref->{'vlink'});
4205: delete($attr_ref->{'bgcolor'});
4206: delete($attr_ref->{'background'});
4207: }
4208:
1.330 albertel 4209: my $attr_string;
4210: foreach my $attr (keys(%$attr_ref)) {
4211: $attr_string .= " $attr=\"".$attr_ref->{$attr}.'" ';
4212: }
4213: return $attr_string;
4214: }
4215:
4216:
1.182 matthew 4217: ###############################################
1.251 albertel 4218: ###############################################
4219:
4220: =pod
4221:
4222: =item * &endbodytag()
4223:
4224: Returns a uniform footer for LON-CAPA web pages.
4225:
1.635 raeburn 4226: Inputs: 1 - optional reference to an args hash
4227: If in the hash, key for noredirectlink has a value which evaluates to true,
4228: a 'Continue' link is not displayed if the page contains an
4229: internal redirect in the <head></head> section,
4230: i.e., $env{'internal.head.redirect'} exists
1.251 albertel 4231:
4232: =cut
4233:
4234: sub endbodytag {
1.635 raeburn 4235: my ($args) = @_;
1.251 albertel 4236: my $endbodytag='</body>';
1.269 albertel 4237: $endbodytag=&Apache::lontexconvert::jsMath_process()."\n".$endbodytag;
1.315 albertel 4238: if ( exists( $env{'internal.head.redirect'} ) ) {
1.635 raeburn 4239: if (!(ref($args) eq 'HASH' && $args->{'noredirectlink'})) {
4240: $endbodytag=
4241: "<br /><a href=\"$env{'internal.head.redirect'}\">".
4242: &mt('Continue').'</a>'.
4243: $endbodytag;
4244: }
1.315 albertel 4245: }
1.251 albertel 4246: return $endbodytag;
4247: }
4248:
1.352 albertel 4249: =pod
4250:
4251: =item * &standard_css()
4252:
4253: Returns a style sheet
4254:
4255: Inputs: (all optional)
4256: domain -> force to color decorate a page for a specific
4257: domain
4258: function -> force usage of a specific rolish color scheme
4259: bgcolor -> override the default page bgcolor
4260:
4261: =cut
4262:
1.343 albertel 4263: sub standard_css {
1.345 albertel 4264: my ($function,$domain,$bgcolor) = @_;
1.352 albertel 4265: $function = &get_users_function() if (!$function);
4266: my $img = &designparm($function.'.img', $domain);
4267: my $tabbg = &designparm($function.'.tabbg', $domain);
4268: my $font = &designparm($function.'.font', $domain);
1.345 albertel 4269: my $sidebg = &designparm($function.'.sidebg',$domain);
1.382 albertel 4270: my $pgbg_or_bgcolor =
4271: $bgcolor ||
1.352 albertel 4272: &designparm($function.'.pgbg', $domain);
1.382 albertel 4273: my $pgbg = &designparm($function.'.pgbg', $domain);
1.352 albertel 4274: my $alink = &designparm($function.'.alink', $domain);
4275: my $vlink = &designparm($function.'.vlink', $domain);
4276: my $link = &designparm($function.'.link', $domain);
4277:
1.602 albertel 4278: my $sans = 'Verdana,Arial,Helvetica,sans-serif';
1.395 albertel 4279: my $mono = 'monospace';
1.352 albertel 4280: my $data_table_head = $tabbg;
4281: my $data_table_light = '#EEEEEE';
1.470 banghart 4282: my $data_table_dark = '#DDDDDD';
4283: my $data_table_darker = '#CCCCCC';
1.349 albertel 4284: my $data_table_highlight = '#FFFF00';
1.352 albertel 4285: my $mail_new = '#FFBB77';
4286: my $mail_new_hover = '#DD9955';
4287: my $mail_read = '#BBBB77';
4288: my $mail_read_hover = '#999944';
4289: my $mail_replied = '#AAAA88';
4290: my $mail_replied_hover = '#888855';
4291: my $mail_other = '#99BBBB';
4292: my $mail_other_hover = '#669999';
1.391 albertel 4293: my $table_header = '#DDDDDD';
1.489 raeburn 4294: my $feedback_link_bg = '#BBBBBB';
1.392 albertel 4295:
1.608 albertel 4296: my $border = ($env{'browser.type'} eq 'explorer' ||
4297: $env{'browser.type'} eq 'safari' ) ? '0px 2px 0px 2px'
4298: : '0px 3px 0px 4px';
1.448 albertel 4299:
1.523 albertel 4300:
1.343 albertel 4301: return <<END;
1.345 albertel 4302: h1, h2, h3, th { font-family: $sans }
1.343 albertel 4303: a:focus { color: red; background: yellow }
1.510 albertel 4304: table.thinborder,
1.523 albertel 4305:
1.510 albertel 4306: table.thinborder tr th {
4307: border-style: solid;
4308: border-width: 1px;
4309: background: $tabbg;
4310: }
1.523 albertel 4311: table.thinborder tr td {
1.510 albertel 4312: border-style: solid;
4313: border-width: 1px
4314: }
1.426 albertel 4315:
1.343 albertel 4316: form, .inline { display: inline; }
4317: .center { text-align: center; }
1.593 albertel 4318: .LC_filename {font-family: $mono; white-space:pre;}
1.350 albertel 4319: .LC_error {
4320: color: red;
4321: font-size: larger;
4322: }
1.457 albertel 4323: .LC_warning,
4324: .LC_diff_removed {
1.394 albertel 4325: color: red;
4326: }
1.532 albertel 4327:
4328: .LC_info,
1.457 albertel 4329: .LC_success,
4330: .LC_diff_added {
1.350 albertel 4331: color: green;
4332: }
1.543 albertel 4333: .LC_unknown {
4334: color: yellow;
4335: }
4336:
1.440 albertel 4337: .LC_icon {
4338: border: 0px;
4339: }
1.539 albertel 4340: .LC_indexer_icon {
4341: border: 0px;
4342: height: 22px;
4343: }
1.543 albertel 4344: .LC_docs_spacer {
4345: width: 25px;
4346: height: 1px;
4347: border: 0px;
4348: }
1.346 albertel 4349:
1.532 albertel 4350: .LC_internal_info {
4351: color: #999;
4352: }
4353:
1.458 albertel 4354: table.LC_pastsubmission {
4355: border: 1px solid black;
4356: margin: 2px;
4357: }
4358:
1.606 albertel 4359: table#LC_top_nav, table#LC_menubuttons,table#LC_nav_location {
1.345 albertel 4360: width: 100%;
4361: background: $pgbg;
1.392 albertel 4362: border: 2px;
1.402 albertel 4363: border-collapse: separate;
1.403 albertel 4364: padding: 0px;
1.345 albertel 4365: }
1.392 albertel 4366:
1.606 albertel 4367: table#LC_title_bar, table.LC_breadcrumbs,
1.393 albertel 4368: table#LC_title_bar.LC_with_remote {
1.359 albertel 4369: width: 100%;
1.392 albertel 4370: border-color: $pgbg;
4371: border-style: solid;
4372: border-width: $border;
4373:
1.379 albertel 4374: background: $pgbg;
4375: font-family: $sans;
1.392 albertel 4376: border-collapse: collapse;
1.403 albertel 4377: padding: 0px;
1.359 albertel 4378: }
1.392 albertel 4379:
1.409 albertel 4380: table.LC_docs_path {
4381: width: 100%;
4382: border: 0;
4383: background: $pgbg;
4384: font-family: $sans;
4385: border-collapse: collapse;
4386: padding: 0px;
4387: }
4388:
1.359 albertel 4389: table#LC_title_bar td {
4390: background: $tabbg;
4391: }
4392: table#LC_title_bar td.LC_title_bar_who {
4393: background: $tabbg;
4394: color: $font;
1.427 albertel 4395: font: small $sans;
1.359 albertel 4396: text-align: right;
4397: }
1.469 banghart 4398: span.LC_metadata {
4399: font-family: $sans;
4400: }
1.359 albertel 4401: span.LC_title_bar_title {
1.416 albertel 4402: font: bold x-large $sans;
1.359 albertel 4403: }
4404: table#LC_title_bar td.LC_title_bar_domain_logo {
4405: background: $sidebg;
4406: text-align: right;
1.368 albertel 4407: padding: 0px;
4408: }
4409: table#LC_title_bar td.LC_title_bar_role_logo {
4410: background: $sidebg;
4411: padding: 0px;
1.359 albertel 4412: }
4413:
1.346 albertel 4414: table#LC_menubuttons_mainmenu {
1.526 www 4415: width: 100%;
1.346 albertel 4416: border: 0px;
4417: border-spacing: 1px;
1.372 albertel 4418: padding: 0px 1px;
1.346 albertel 4419: margin: 0px;
4420: border-collapse: separate;
4421: }
4422: table#LC_menubuttons img, table#LC_menubuttons_mainmenu img {
4423: border: 0px;
4424: }
1.345 albertel 4425: table#LC_top_nav td {
4426: background: $tabbg;
1.392 albertel 4427: border: 0px;
1.407 albertel 4428: font-size: small;
1.345 albertel 4429: }
4430: table#LC_top_nav td a, div#LC_top_nav a {
4431: color: $font;
4432: font-family: $sans;
4433: }
1.364 albertel 4434: table#LC_top_nav td.LC_top_nav_logo {
4435: background: $tabbg;
1.432 albertel 4436: text-align: left;
1.408 albertel 4437: white-space: nowrap;
1.432 albertel 4438: width: 31px;
1.408 albertel 4439: }
4440: table#LC_top_nav td.LC_top_nav_logo img {
1.432 albertel 4441: border: 0px;
1.408 albertel 4442: vertical-align: bottom;
1.364 albertel 4443: }
1.432 albertel 4444: table#LC_top_nav td.LC_top_nav_exit,
4445: table#LC_top_nav td.LC_top_nav_help {
4446: width: 2.0em;
4447: }
1.442 albertel 4448: table#LC_top_nav td.LC_top_nav_login {
4449: width: 4.0em;
4450: text-align: center;
4451: }
1.409 albertel 4452: table.LC_breadcrumbs td, table.LC_docs_path td {
1.357 albertel 4453: background: $tabbg;
4454: color: $font;
4455: font-family: $sans;
1.358 albertel 4456: font-size: smaller;
1.357 albertel 4457: }
1.411 albertel 4458: table.LC_breadcrumbs td.LC_breadcrumbs_component,
1.409 albertel 4459: table.LC_docs_path td.LC_docs_path_component {
1.357 albertel 4460: background: $tabbg;
4461: color: $font;
4462: font-family: $sans;
4463: font-size: larger;
4464: text-align: right;
4465: }
1.383 albertel 4466: td.LC_table_cell_checkbox {
4467: text-align: center;
4468: }
4469:
1.522 albertel 4470: table#LC_mainmenu td.LC_mainmenu_column {
4471: vertical-align: top;
4472: }
4473:
1.346 albertel 4474: .LC_menubuttons_inline_text {
4475: color: $font;
4476: font-family: $sans;
4477: font-size: smaller;
4478: }
4479:
1.526 www 4480: .LC_menubuttons_link {
4481: text-decoration: none;
4482: }
4483:
1.522 albertel 4484: .LC_menubuttons_category {
1.521 www 4485: color: $font;
1.526 www 4486: background: $pgbg;
1.521 www 4487: font-family: $sans;
4488: font-size: larger;
4489: font-weight: bold;
4490: }
4491:
1.346 albertel 4492: td.LC_menubuttons_text {
1.526 www 4493: width: 90%;
1.346 albertel 4494: color: $font;
4495: font-family: $sans;
4496: }
1.526 www 4497:
1.346 albertel 4498: td.LC_menubuttons_img {
4499: }
1.526 www 4500:
1.346 albertel 4501: .LC_current_location {
4502: font-family: $sans;
4503: background: $tabbg;
4504: }
4505: .LC_new_mail {
4506: font-family: $sans;
1.634 www 4507: background: $tabbg;
1.346 albertel 4508: font-weight: bold;
4509: }
1.347 albertel 4510:
1.526 www 4511: .LC_rolesmenu_is {
4512: font-family: $sans;
4513: }
4514:
4515: .LC_rolesmenu_selected {
4516: font-family: $sans;
4517: }
4518:
4519: .LC_rolesmenu_future {
4520: font-family: $sans;
4521: }
4522:
4523:
4524: .LC_rolesmenu_will {
4525: font-family: $sans;
4526: }
4527:
4528: .LC_rolesmenu_will_not {
4529: font-family: $sans;
4530: }
4531:
4532: .LC_rolesmenu_expired {
4533: font-family: $sans;
4534: }
4535:
4536: .LC_rolesinfo {
4537: font-family: $sans;
4538: }
4539:
1.527 www 4540: .LC_dropadd_labeltext {
4541: font-family: $sans;
4542: text-align: right;
4543: }
4544:
4545: .LC_preferences_labeltext {
4546: font-family: $sans;
4547: text-align: right;
4548: }
4549:
1.440 albertel 4550: table.LC_aboutme_port {
4551: border: 0px;
4552: border-collapse: collapse;
4553: border-spacing: 0px;
4554: }
1.349 albertel 4555: table.LC_data_table, table.LC_mail_list {
1.347 albertel 4556: border: 1px solid #000000;
1.402 albertel 4557: border-collapse: separate;
1.426 albertel 4558: border-spacing: 1px;
1.610 albertel 4559: background: $pgbg;
1.347 albertel 4560: }
1.422 albertel 4561: .LC_data_table_dense {
4562: font-size: small;
4563: }
1.507 raeburn 4564: table.LC_nested_outer {
4565: border: 1px solid #000000;
1.589 raeburn 4566: border-collapse: collapse;
1.507 raeburn 4567: border-spacing: 0px;
4568: width: 100%;
4569: }
4570: table.LC_nested {
4571: border: 0px;
1.589 raeburn 4572: border-collapse: collapse;
1.507 raeburn 4573: border-spacing: 0px;
4574: width: 100%;
4575: }
1.523 albertel 4576: table.LC_data_table tr th, table.LC_calendar tr th, table.LC_mail_list tr th,
4577: table.LC_prior_tries tr th {
1.349 albertel 4578: font-weight: bold;
4579: background-color: $data_table_head;
1.421 albertel 4580: font-size: smaller;
1.347 albertel 4581: }
1.610 albertel 4582: table.LC_data_table tr.LC_odd_row > td,
1.440 albertel 4583: table.LC_aboutme_port tr td {
1.349 albertel 4584: background-color: $data_table_light;
1.425 albertel 4585: padding: 2px;
1.347 albertel 4586: }
1.610 albertel 4587: table.LC_data_table tr.LC_even_row > td,
1.440 albertel 4588: table.LC_aboutme_port tr.LC_even_row td {
1.349 albertel 4589: background-color: $data_table_dark;
1.347 albertel 4590: }
1.425 albertel 4591: table.LC_data_table tr.LC_data_table_highlight td {
4592: background-color: $data_table_darker;
4593: }
1.639 raeburn 4594: table.LC_data_table tr td.LC_leftcol_header {
4595: background-color: $data_table_head;
4596: font-weight: bold;
4597: }
1.451 albertel 4598: table.LC_data_table tr.LC_empty_row td,
1.507 raeburn 4599: table.LC_nested tr.LC_empty_row td {
1.347 albertel 4600: background-color: #FFFFFF;
1.421 albertel 4601: font-weight: bold;
4602: font-style: italic;
4603: text-align: center;
4604: padding: 8px;
1.347 albertel 4605: }
1.507 raeburn 4606: table.LC_nested tr.LC_empty_row td {
1.465 albertel 4607: padding: 4ex
4608: }
1.507 raeburn 4609: table.LC_nested_outer tr th {
4610: font-weight: bold;
4611: background-color: $data_table_head;
4612: font-size: smaller;
4613: border-bottom: 1px solid #000000;
4614: }
4615: table.LC_nested_outer tr td.LC_subheader {
4616: background-color: $data_table_head;
4617: font-weight: bold;
4618: font-size: small;
4619: border-bottom: 1px solid #000000;
4620: text-align: right;
1.451 albertel 4621: }
1.507 raeburn 4622: table.LC_nested tr.LC_info_row td {
1.451 albertel 4623: background-color: #CCC;
4624: font-weight: bold;
4625: font-size: small;
1.507 raeburn 4626: text-align: center;
4627: }
1.589 raeburn 4628: table.LC_nested tr.LC_info_row td.LC_left_item,
4629: table.LC_nested_outer tr th.LC_left_item {
1.507 raeburn 4630: text-align: left;
1.451 albertel 4631: }
1.507 raeburn 4632: table.LC_nested td {
1.451 albertel 4633: background-color: #FFF;
4634: font-size: small;
1.507 raeburn 4635: }
4636: table.LC_nested_outer tr th.LC_right_item,
4637: table.LC_nested tr.LC_info_row td.LC_right_item,
4638: table.LC_nested tr.LC_odd_row td.LC_right_item,
4639: table.LC_nested tr td.LC_right_item {
1.451 albertel 4640: text-align: right;
4641: }
4642:
1.507 raeburn 4643: table.LC_nested tr.LC_odd_row td {
1.451 albertel 4644: background-color: #EEE;
4645: }
4646:
1.473 raeburn 4647: table.LC_createuser {
4648: }
4649:
4650: table.LC_createuser tr.LC_section_row td {
4651: font-size: smaller;
4652: }
4653:
4654: table.LC_createuser tr.LC_info_row td {
4655: background-color: #CCC;
4656: font-weight: bold;
4657: text-align: center;
4658: }
4659:
1.349 albertel 4660: table.LC_calendar {
4661: border: 1px solid #000000;
4662: border-collapse: collapse;
4663: }
4664: table.LC_calendar_pickdate {
4665: font-size: xx-small;
4666: }
4667: table.LC_calendar tr td {
4668: border: 1px solid #000000;
4669: vertical-align: top;
4670: }
4671: table.LC_calendar tr td.LC_calendar_day_empty {
4672: background-color: $data_table_dark;
4673: }
4674: table.LC_calendar tr td.LC_calendar_day_current {
4675: background-color: $data_table_highlight;
4676: }
4677:
4678: table.LC_mail_list tr.LC_mail_new {
4679: background-color: $mail_new;
4680: }
4681: table.LC_mail_list tr.LC_mail_new:hover {
4682: background-color: $mail_new_hover;
4683: }
4684: table.LC_mail_list tr.LC_mail_read {
4685: background-color: $mail_read;
4686: }
4687: table.LC_mail_list tr.LC_mail_read:hover {
4688: background-color: $mail_read_hover;
4689: }
4690: table.LC_mail_list tr.LC_mail_replied {
4691: background-color: $mail_replied;
4692: }
4693: table.LC_mail_list tr.LC_mail_replied:hover {
4694: background-color: $mail_replied_hover;
4695: }
4696: table.LC_mail_list tr.LC_mail_other {
4697: background-color: $mail_other;
4698: }
4699: table.LC_mail_list tr.LC_mail_other:hover {
4700: background-color: $mail_other_hover;
4701: }
1.494 raeburn 4702: table.LC_mail_list tr.LC_mail_even {
4703: }
4704: table.LC_mail_list tr.LC_mail_odd {
4705: }
4706:
1.385 albertel 4707:
1.386 albertel 4708: table#LC_portfolio_actions {
4709: width: auto;
4710: background: $pgbg;
4711: border: 0px;
4712: border-spacing: 2px 2px;
4713: padding: 0px;
4714: margin: 0px;
4715: border-collapse: separate;
4716: }
4717: table#LC_portfolio_actions td.LC_label {
4718: background: $tabbg;
4719: text-align: right;
4720: }
4721: table#LC_portfolio_actions td.LC_value {
4722: background: $tabbg;
4723: }
1.385 albertel 4724:
1.391 albertel 4725: table#LC_cstr_controls {
4726: width: 100%;
4727: border-collapse: collapse;
4728: }
4729: table#LC_cstr_controls tr td {
4730: border: 4px solid $pgbg;
4731: padding: 4px;
4732: text-align: center;
4733: background: $tabbg;
4734: }
4735: table#LC_cstr_controls tr th {
4736: border: 4px solid $pgbg;
4737: background: $table_header;
4738: text-align: center;
4739: font-family: $sans;
4740: font-size: smaller;
4741: }
4742:
1.389 albertel 4743: table#LC_browser {
4744:
4745: }
4746: table#LC_browser tr th {
1.391 albertel 4747: background: $table_header;
1.389 albertel 4748: }
1.390 albertel 4749: table#LC_browser tr td {
4750: padding: 2px;
4751: }
1.389 albertel 4752: table#LC_browser tr.LC_browser_file,
4753: table#LC_browser tr.LC_browser_file_published {
4754: background: #CCFF88;
4755: }
4756: table#LC_browser tr.LC_browser_file_locked,
4757: table#LC_browser tr.LC_browser_file_unpublished {
4758: background: #FFAA99;
1.387 albertel 4759: }
1.389 albertel 4760: table#LC_browser tr.LC_browser_file_obsolete {
4761: background: #AAAAAA;
1.387 albertel 4762: }
1.455 albertel 4763: table#LC_browser tr.LC_browser_file_modified,
4764: table#LC_browser tr.LC_browser_file_metamodified {
1.389 albertel 4765: background: #FFFF77;
1.387 albertel 4766: }
1.389 albertel 4767: table#LC_browser tr.LC_browser_folder {
4768: background: #CCCCFF;
1.387 albertel 4769: }
1.388 albertel 4770: span.LC_current_location {
4771: font-size: x-large;
4772: background: $pgbg;
4773: }
1.387 albertel 4774:
1.395 albertel 4775: span.LC_parm_menu_item {
4776: font-size: larger;
4777: font-family: $sans;
4778: }
4779: span.LC_parm_scope_all {
4780: color: red;
4781: }
4782: span.LC_parm_scope_folder {
4783: color: green;
4784: }
4785: span.LC_parm_scope_resource {
4786: color: orange;
4787: }
4788: span.LC_parm_part {
4789: color: blue;
4790: }
4791: span.LC_parm_folder, span.LC_parm_symb {
4792: font-size: x-small;
4793: font-family: $mono;
4794: color: #AAAAAA;
4795: }
4796:
1.396 albertel 4797: td.LC_parm_overview_level_menu, td.LC_parm_overview_map_menu,
4798: td.LC_parm_overview_parm_selectors, td.LC_parm_overview_parm_restrictions {
4799: border: 1px solid black;
4800: border-collapse: collapse;
4801: }
4802: table.LC_parm_overview_restrictions td {
4803: border-width: 1px 4px 1px 4px;
4804: border-style: solid;
4805: border-color: $pgbg;
4806: text-align: center;
4807: }
4808: table.LC_parm_overview_restrictions th {
4809: background: $tabbg;
4810: border-width: 1px 4px 1px 4px;
4811: border-style: solid;
4812: border-color: $pgbg;
4813: }
1.398 albertel 4814: table#LC_helpmenu {
4815: border: 0px;
4816: height: 55px;
4817: border-spacing: 0px;
4818: }
4819:
4820: table#LC_helpmenu fieldset legend {
4821: font-size: larger;
4822: font-weight: bold;
4823: }
1.397 albertel 4824: table#LC_helpmenu_links {
4825: width: 100%;
4826: border: 1px solid black;
4827: background: $pgbg;
4828: padding: 0px;
4829: border-spacing: 1px;
4830: }
4831: table#LC_helpmenu_links tr td {
4832: padding: 1px;
4833: background: $tabbg;
1.399 albertel 4834: text-align: center;
4835: font-weight: bold;
1.397 albertel 4836: }
1.396 albertel 4837:
1.397 albertel 4838: table#LC_helpmenu_links a:link, table#LC_helpmenu_links a:visited,
4839: table#LC_helpmenu_links a:active {
4840: text-decoration: none;
4841: color: $font;
4842: }
4843: table#LC_helpmenu_links a:hover {
4844: text-decoration: underline;
4845: color: $vlink;
4846: }
1.396 albertel 4847:
1.417 albertel 4848: .LC_chrt_popup_exists {
4849: border: 1px solid #339933;
4850: margin: -1px;
4851: }
4852: .LC_chrt_popup_up {
4853: border: 1px solid yellow;
4854: margin: -1px;
4855: }
4856: .LC_chrt_popup {
4857: border: 1px solid #8888FF;
4858: background: #CCCCFF;
4859: }
1.421 albertel 4860: table.LC_pick_box {
4861: border-collapse: separate;
4862: background: white;
4863: border: 1px solid black;
4864: border-spacing: 1px;
4865: }
4866: table.LC_pick_box td.LC_pick_box_title {
4867: background: $tabbg;
4868: font-weight: bold;
4869: text-align: right;
4870: width: 184px;
4871: padding: 8px;
4872: }
1.645 raeburn 4873: table.LC_pick_box td.LC_selfenroll_pick_box_title {
4874: background: $tabbg;
4875: font-weight: bold;
4876: text-align: right;
4877: width: 350px;
4878: padding: 8px;
4879: }
4880:
1.579 raeburn 4881: table.LC_pick_box td.LC_pick_box_value {
4882: text-align: left;
4883: padding: 8px;
4884: }
4885: table.LC_pick_box td.LC_pick_box_select {
4886: text-align: left;
4887: padding: 8px;
4888: }
1.424 albertel 4889: table.LC_pick_box td.LC_pick_box_separator {
1.421 albertel 4890: padding: 0px;
4891: height: 1px;
4892: background: black;
4893: }
4894: table.LC_pick_box td.LC_pick_box_submit {
4895: text-align: right;
4896: }
1.579 raeburn 4897: table.LC_pick_box td.LC_evenrow_value {
4898: text-align: left;
4899: padding: 8px;
4900: background-color: $data_table_light;
4901: }
4902: table.LC_pick_box td.LC_oddrow_value {
4903: text-align: left;
4904: padding: 8px;
4905: background-color: $data_table_light;
4906: }
4907: table.LC_helpform_receipt {
4908: width: 620px;
4909: border-collapse: separate;
4910: background: white;
4911: border: 1px solid black;
4912: border-spacing: 1px;
4913: }
4914: table.LC_helpform_receipt td.LC_pick_box_title {
4915: background: $tabbg;
4916: font-weight: bold;
4917: text-align: right;
4918: width: 184px;
4919: padding: 8px;
4920: }
4921: table.LC_helpform_receipt td.LC_evenrow_value {
4922: text-align: left;
4923: padding: 8px;
4924: background-color: $data_table_light;
4925: }
4926: table.LC_helpform_receipt td.LC_oddrow_value {
4927: text-align: left;
4928: padding: 8px;
4929: background-color: $data_table_light;
4930: }
4931: table.LC_helpform_receipt td.LC_pick_box_separator {
4932: padding: 0px;
4933: height: 1px;
4934: background: black;
4935: }
4936: span.LC_helpform_receipt_cat {
4937: font-weight: bold;
4938: }
1.424 albertel 4939: table.LC_group_priv_box {
4940: background: white;
4941: border: 1px solid black;
4942: border-spacing: 1px;
4943: }
4944: table.LC_group_priv_box td.LC_pick_box_title {
4945: background: $tabbg;
4946: font-weight: bold;
4947: text-align: right;
4948: width: 184px;
4949: }
4950: table.LC_group_priv_box td.LC_groups_fixed {
4951: background: $data_table_light;
4952: text-align: center;
4953: }
4954: table.LC_group_priv_box td.LC_groups_optional {
4955: background: $data_table_dark;
4956: text-align: center;
4957: }
4958: table.LC_group_priv_box td.LC_groups_functionality {
4959: background: $data_table_darker;
4960: text-align: center;
4961: font-weight: bold;
4962: }
4963: table.LC_group_priv td {
4964: text-align: left;
4965: padding: 0px;
4966: }
4967:
1.421 albertel 4968: table.LC_notify_front_page {
4969: background: white;
4970: border: 1px solid black;
4971: padding: 8px;
4972: }
4973: table.LC_notify_front_page td {
4974: padding: 8px;
4975: }
1.424 albertel 4976: .LC_navbuttons {
4977: margin: 2ex 0ex 2ex 0ex;
4978: }
1.423 albertel 4979: .LC_topic_bar {
4980: font-family: $sans;
4981: font-weight: bold;
4982: width: 100%;
4983: background: $tabbg;
4984: vertical-align: middle;
4985: margin: 2ex 0ex 2ex 0ex;
4986: }
4987: .LC_topic_bar span {
4988: vertical-align: middle;
4989: }
4990: .LC_topic_bar img {
4991: vertical-align: bottom;
4992: }
4993: table.LC_course_group_status {
4994: margin: 20px;
4995: }
4996: table.LC_status_selector td {
4997: vertical-align: top;
4998: text-align: center;
1.424 albertel 4999: padding: 4px;
5000: }
5001: table.LC_descriptive_input td.LC_description {
5002: vertical-align: top;
5003: text-align: right;
5004: font-weight: bold;
1.423 albertel 5005: }
1.599 albertel 5006: div.LC_feedback_link {
1.616 albertel 5007: clear: both;
1.599 albertel 5008: background: white;
5009: width: 100%;
1.489 raeburn 5010: }
5011: span.LC_feedback_link {
1.599 albertel 5012: background: $feedback_link_bg;
5013: font-size: larger;
5014: }
5015: span.LC_message_link {
5016: background: $feedback_link_bg;
5017: font-size: larger;
5018: position: absolute;
5019: right: 1em;
1.489 raeburn 5020: }
1.421 albertel 5021:
1.515 albertel 5022: table.LC_prior_tries {
1.524 albertel 5023: border: 1px solid #000000;
5024: border-collapse: separate;
5025: border-spacing: 1px;
1.515 albertel 5026: }
1.523 albertel 5027:
1.515 albertel 5028: table.LC_prior_tries td {
1.524 albertel 5029: padding: 2px;
1.515 albertel 5030: }
1.523 albertel 5031:
5032: .LC_answer_correct {
5033: background: #AAFFAA;
5034: color: black;
5035: }
5036: .LC_answer_charged_try {
5037: background: #FFAAAA ! important;
5038: color: black;
5039: }
5040: .LC_answer_not_charged_try,
5041: .LC_answer_no_grade,
5042: .LC_answer_late {
5043: background: #FFFFAA;
5044: color: black;
5045: }
5046: .LC_answer_previous {
5047: background: #AAAAFF;
5048: color: black;
5049: }
5050: .LC_answer_no_message {
5051: background: #FFFFFF;
5052: color: black;
5053: }
5054: .LC_answer_unknown {
5055: background: orange;
5056: color: black;
5057: }
5058:
5059:
1.529 albertel 5060: span.LC_prior_numerical,
5061: span.LC_prior_string,
5062: span.LC_prior_custom,
5063: span.LC_prior_reaction,
5064: span.LC_prior_math {
1.523 albertel 5065: font-family: monospace;
5066: white-space: pre;
5067: }
5068:
1.525 albertel 5069: span.LC_prior_string {
5070: font-family: monospace;
5071: white-space: pre;
5072: }
5073:
1.523 albertel 5074: table.LC_prior_option {
5075: width: 100%;
5076: border-collapse: collapse;
5077: }
1.528 albertel 5078: table.LC_prior_rank, table.LC_prior_match {
5079: border-collapse: collapse;
5080: }
5081: table.LC_prior_option tr td,
5082: table.LC_prior_rank tr td,
5083: table.LC_prior_match tr td {
1.524 albertel 5084: border: 1px solid #000000;
1.515 albertel 5085: }
5086:
1.519 raeburn 5087: span.LC_nobreak {
1.544 albertel 5088: white-space: nowrap;
1.519 raeburn 5089: }
5090:
1.576 raeburn 5091: span.LC_cusr_emph {
5092: font-style: italic;
5093: }
5094:
1.633 raeburn 5095: span.LC_cusr_subheading {
5096: font-weight: normal;
5097: font-size: 85%;
5098: }
5099:
1.545 albertel 5100: table.LC_docs_documents {
5101: background: #BBBBBB;
1.547 albertel 5102: border-width: 0px;
1.545 albertel 5103: border-collapse: collapse;
5104: }
5105:
5106: table.LC_docs_documents td.LC_docs_document {
5107: border: 2px solid black;
5108: padding: 4px;
5109: }
5110:
5111: .LC_docs_course_commands div {
5112: float: left;
5113: border: 4px solid #AAAAAA;
5114: padding: 4px;
5115: background: #DDDDCC;
5116: }
5117:
5118: .LC_docs_entry_move {
5119: border: 0px;
5120: border-collapse: collapse;
1.544 albertel 5121: }
5122:
1.545 albertel 5123: .LC_docs_entry_move td {
5124: border: 2px solid #BBBBBB;
5125: background: #DDDDDD;
5126: }
5127:
5128: .LC_docs_editor td.LC_docs_entry_commands {
5129: background: #DDDDDD;
5130: font-size: x-small;
5131: }
1.544 albertel 5132: .LC_docs_copy {
1.545 albertel 5133: color: #000099;
1.544 albertel 5134: }
5135: .LC_docs_cut {
1.545 albertel 5136: color: #550044;
1.544 albertel 5137: }
5138: .LC_docs_rename {
1.545 albertel 5139: color: #009900;
1.544 albertel 5140: }
5141: .LC_docs_remove {
1.545 albertel 5142: color: #990000;
5143: }
5144:
1.547 albertel 5145: .LC_docs_reinit_warn,
5146: .LC_docs_ext_edit {
5147: font-size: x-small;
5148: }
5149:
1.545 albertel 5150: .LC_docs_editor td.LC_docs_entry_title,
5151: .LC_docs_editor td.LC_docs_entry_icon {
5152: background: #FFFFBB;
5153: }
5154: .LC_docs_editor td.LC_docs_entry_parameter {
5155: background: #BBBBFF;
5156: font-size: x-small;
5157: white-space: nowrap;
5158: }
5159:
5160: table.LC_docs_adddocs td,
5161: table.LC_docs_adddocs th {
5162: border: 1px solid #BBBBBB;
5163: padding: 4px;
5164: background: #DDDDDD;
1.543 albertel 5165: }
5166:
1.584 albertel 5167: table.LC_sty_begin {
5168: background: #BBFFBB;
5169: }
5170: table.LC_sty_end {
5171: background: #FFBBBB;
5172: }
5173:
1.589 raeburn 5174: table.LC_double_column {
5175: border-width: 0px;
5176: border-collapse: collapse;
5177: width: 100%;
5178: padding: 2px;
5179: }
5180:
5181: table.LC_double_column tr td.LC_left_col {
1.590 raeburn 5182: top: 2px;
1.589 raeburn 5183: left: 2px;
5184: width: 47%;
5185: vertical-align: top;
5186: }
5187:
5188: table.LC_double_column tr td.LC_right_col {
5189: top: 2px;
5190: right: 2px;
5191: width: 47%;
5192: vertical-align: top;
5193: }
5194:
1.594 raeburn 5195: span.LC_role_level {
5196: font-weight: bold;
5197: }
5198:
1.591 raeburn 5199: div.LC_left_float {
5200: float: left;
5201: padding-right: 5%;
1.597 albertel 5202: padding-bottom: 4px;
1.591 raeburn 5203: }
5204:
5205: div.LC_clear_float_header {
1.597 albertel 5206: padding-bottom: 2px;
1.591 raeburn 5207: }
5208:
5209: div.LC_clear_float_footer {
1.597 albertel 5210: padding-top: 10px;
1.591 raeburn 5211: clear: both;
5212: }
5213:
1.597 albertel 5214:
1.601 albertel 5215: div.LC_grade_select_mode {
1.604 albertel 5216: font-family: $sans;
1.601 albertel 5217: }
5218: div.LC_grade_select_mode div div {
5219: margin: 5px;
5220: }
5221: div.LC_grade_select_mode_selector {
5222: margin: 5px;
5223: float: left;
5224: }
5225: div.LC_grade_select_mode_selector_header {
5226: font: bold medium $sans;
5227: }
5228: div.LC_grade_select_mode_type {
5229: clear: left;
5230: }
5231:
1.597 albertel 5232: div.LC_grade_show_user {
5233: margin-top: 20px;
5234: border: 1px solid black;
5235: }
5236: div.LC_grade_user_name {
5237: background: #DDDDEE;
5238: border-bottom: 1px solid black;
5239: font: bold large $sans;
5240: }
5241: div.LC_grade_show_user_odd_row div.LC_grade_user_name {
5242: background: #DDEEDD;
5243: }
5244:
5245: div.LC_grade_show_problem,
5246: div.LC_grade_submissions,
5247: div.LC_grade_message_center,
5248: div.LC_grade_info_links,
5249: div.LC_grade_assign {
5250: margin: 5px;
5251: width: 99%;
5252: background: #FFFFFF;
5253: }
5254: div.LC_grade_show_problem_header,
5255: div.LC_grade_submissions_header,
5256: div.LC_grade_message_center_header,
5257: div.LC_grade_assign_header {
5258: font: bold large $sans;
5259: }
5260: div.LC_grade_show_problem_problem,
5261: div.LC_grade_submissions_body,
5262: div.LC_grade_message_center_body,
5263: div.LC_grade_assign_body {
5264: border: 1px solid black;
5265: width: 99%;
5266: background: #FFFFFF;
5267: }
1.598 albertel 5268: span.LC_grade_check_note {
5269: font: normal medium $sans;
5270: display: inline;
5271: position: absolute;
5272: right: 1em;
5273: }
1.597 albertel 5274:
1.613 albertel 5275: table.LC_scantron_action {
5276: width: 100%;
5277: }
5278: table.LC_scantron_action tr th {
5279: font: normal bold $sans;
5280: }
1.600 albertel 5281:
1.614 albertel 5282: div.LC_edit_problem_header,
5283: div.LC_edit_problem_footer {
1.600 albertel 5284: font: normal medium $sans;
1.602 albertel 5285: margin: 2px;
1.600 albertel 5286: }
5287: div.LC_edit_problem_header,
1.602 albertel 5288: div.LC_edit_problem_header div,
1.614 albertel 5289: div.LC_edit_problem_footer,
5290: div.LC_edit_problem_footer div,
1.602 albertel 5291: div.LC_edit_problem_editxml_header,
5292: div.LC_edit_problem_editxml_header div {
1.600 albertel 5293: margin-top: 5px;
5294: }
1.602 albertel 5295: div.LC_edit_problem_header_edit_row {
5296: background: $tabbg;
5297: padding: 3px;
5298: margin-bottom: 5px;
5299: }
1.600 albertel 5300: div.LC_edit_problem_header_title {
1.602 albertel 5301: font: larger bold $sans;
5302: background: $tabbg;
5303: padding: 3px;
5304: }
5305: table.LC_edit_problem_header_title {
5306: font: larger bold $sans;
5307: width: 100%;
5308: border-color: $pgbg;
5309: border-style: solid;
5310: border-width: $border;
5311:
1.600 albertel 5312: background: $tabbg;
1.602 albertel 5313: border-collapse: collapse;
5314: padding: 0px
5315: }
5316:
5317: div.LC_edit_problem_discards {
5318: float: left;
5319: padding-bottom: 5px;
5320: }
5321: div.LC_edit_problem_saves {
5322: float: right;
5323: padding-bottom: 5px;
1.600 albertel 5324: }
5325: hr.LC_edit_problem_divide {
1.602 albertel 5326: clear: both;
1.600 albertel 5327: color: $tabbg;
5328: background-color: $tabbg;
5329: height: 3px;
5330: border: 0px;
5331: }
1.343 albertel 5332: END
5333: }
5334:
1.306 albertel 5335: =pod
5336:
5337: =item * &headtag()
5338:
5339: Returns a uniform footer for LON-CAPA web pages.
5340:
1.307 albertel 5341: Inputs: $title - optional title for the head
5342: $head_extra - optional extra HTML to put inside the <head>
1.315 albertel 5343: $args - optional arguments
1.319 albertel 5344: force_register - if is true call registerurl so the remote is
5345: informed
1.415 albertel 5346: redirect -> array ref of
5347: 1- seconds before redirect occurs
5348: 2- url to redirect to
5349: 3- whether the side effect should occur
1.315 albertel 5350: (side effect of setting
5351: $env{'internal.head.redirect'} to the url
5352: redirected too)
1.352 albertel 5353: domain -> force to color decorate a page for a specific
5354: domain
5355: function -> force usage of a specific rolish color scheme
5356: bgcolor -> override the default page bgcolor
1.460 albertel 5357: no_auto_mt_title
5358: -> prevent &mt()ing the title arg
1.464 albertel 5359:
1.306 albertel 5360: =cut
5361:
5362: sub headtag {
1.313 albertel 5363: my ($title,$head_extra,$args) = @_;
1.306 albertel 5364:
1.363 albertel 5365: my $function = $args->{'function'} || &get_users_function();
5366: my $domain = $args->{'domain'} || &determinedomain();
5367: my $bgcolor = $args->{'bgcolor'} || &designparm($function.'.pgbg',$domain);
1.418 albertel 5368: my $url = join(':',$env{'user.name'},$env{'user.domain'},
1.458 albertel 5369: $Apache::lonnet::perlvar{'lonVersion'},
1.531 albertel 5370: #time(),
1.418 albertel 5371: $env{'environment.color.timestamp'},
1.363 albertel 5372: $function,$domain,$bgcolor);
5373:
1.369 www 5374: $url = '/adm/css/'.&escape($url).'.css';
1.363 albertel 5375:
1.308 albertel 5376: my $result =
5377: '<head>'.
1.461 albertel 5378: &font_settings();
1.319 albertel 5379:
1.461 albertel 5380: if (!$args->{'frameset'}) {
5381: $result .= &Apache::lonhtmlcommon::htmlareaheaders();
5382: }
1.319 albertel 5383: if ($args->{'force_register'}) {
5384: $result .= &Apache::lonmenu::registerurl(1);
5385: }
1.436 albertel 5386: if (!$args->{'no_nav_bar'}
5387: && !$args->{'only_body'}
5388: && !$args->{'frameset'}) {
5389: $result .= &help_menu_js();
5390: }
1.319 albertel 5391:
1.314 albertel 5392: if (ref($args->{'redirect'})) {
1.414 albertel 5393: my ($time,$url,$inhibit_continue) = @{$args->{'redirect'}};
1.315 albertel 5394: $url = &Apache::lonenc::check_encrypt($url);
1.414 albertel 5395: if (!$inhibit_continue) {
5396: $env{'internal.head.redirect'} = $url;
5397: }
1.313 albertel 5398: $result.=<<ADDMETA
5399: <meta http-equiv="pragma" content="no-cache" />
1.344 albertel 5400: <meta http-equiv="Refresh" content="$time; url=$url" />
1.313 albertel 5401: ADDMETA
5402: }
1.306 albertel 5403: if (!defined($title)) {
5404: $title = 'The LearningOnline Network with CAPA';
5405: }
1.460 albertel 5406: if (!$args->{'no_auto_mt_title'}) { $title = &mt($title); }
5407: $result .= '<title> LON-CAPA '.$title.'</title>'
1.414 albertel 5408: .'<link rel="stylesheet" type="text/css" href="'.$url.'" />'
5409: .$head_extra;
1.306 albertel 5410: return $result;
5411: }
5412:
5413: =pod
5414:
1.340 albertel 5415: =item * &font_settings()
5416:
5417: Returns neccessary <meta> to set the proper encoding
5418:
5419: Inputs: none
5420:
5421: =cut
5422:
5423: sub font_settings {
5424: my $headerstring='';
1.647 www 5425: if (!$env{'browser.mathml'} && $env{'browser.unicode'}) {
1.340 albertel 5426: $headerstring.=
5427: '<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />';
5428: }
5429: return $headerstring;
5430: }
5431:
1.341 albertel 5432: =pod
5433:
5434: =item * &xml_begin()
5435:
5436: Returns the needed doctype and <html>
5437:
5438: Inputs: none
5439:
5440: =cut
5441:
5442: sub xml_begin {
5443: my $output='';
5444:
1.592 albertel 5445: if ($env{'internal.start_page'}==1) {
5446: &Apache::lonhtmlcommon::init_htmlareafields();
5447: }
1.342 albertel 5448:
1.341 albertel 5449: if ($env{'browser.mathml'}) {
5450: $output='<?xml version="1.0"?>'
5451: #.'<?xml-stylesheet type="text/css" href="/adm/MathML/mathml.css"?>'."\n"
5452: # .'<!DOCTYPE html SYSTEM "/adm/MathML/mathml.dtd" '
5453:
5454: # .'<!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">] >'
5455: .'<!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">'
5456: .'<html xmlns:math="http://www.w3.org/1998/Math/MathML" '
5457: .'xmlns="http://www.w3.org/1999/xhtml">';
5458: } else {
5459: $output='<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"><html>';
5460: }
5461: return $output;
5462: }
1.340 albertel 5463:
5464: =pod
5465:
1.306 albertel 5466: =item * &endheadtag()
5467:
5468: Returns a uniform </head> for LON-CAPA web pages.
5469:
5470: Inputs: none
5471:
5472: =cut
5473:
5474: sub endheadtag {
5475: return '</head>';
5476: }
5477:
5478: =pod
5479:
5480: =item * &head()
5481:
5482: Returns a uniform complete <head>..</head> section for LON-CAPA web pages.
5483:
1.648 raeburn 5484: Inputs:
5485:
5486: =over 4
5487:
5488: $title - optional title for the page
5489:
5490: $head_extra - optional extra HTML to put inside the <head>
5491:
5492: =back
1.405 albertel 5493:
1.306 albertel 5494: =cut
5495:
5496: sub head {
1.325 albertel 5497: my ($title,$head_extra,$args) = @_;
5498: return &headtag($title,$head_extra,$args).&endheadtag();
1.306 albertel 5499: }
5500:
5501: =pod
5502:
5503: =item * &start_page()
5504:
5505: Returns a complete <html> .. <body> section for LON-CAPA web pages.
5506:
1.648 raeburn 5507: Inputs:
5508:
5509: =over 4
5510:
5511: $title - optional title for the page
5512:
5513: $head_extra - optional extra HTML to incude inside the <head>
5514:
5515: $args - additional optional args supported are:
5516:
5517: =over 8
5518:
5519: only_body -> is true will set &bodytag() onlybodytag
1.317 albertel 5520: arg on
1.648 raeburn 5521: no_nav_bar -> is true will set &bodytag() notopbar arg on
5522: add_entries -> additional attributes to add to the <body>
5523: domain -> force to color decorate a page for a
1.317 albertel 5524: specific domain
1.648 raeburn 5525: function -> force usage of a specific rolish color
1.317 albertel 5526: scheme
1.648 raeburn 5527: redirect -> see &headtag()
5528: bgcolor -> override the default page bg color
5529: js_ready -> return a string ready for being used in
1.317 albertel 5530: a javascript writeln
1.648 raeburn 5531: html_encode -> return a string ready for being used in
1.320 albertel 5532: a html attribute
1.648 raeburn 5533: force_register -> if is true will turn on the &bodytag()
1.317 albertel 5534: $forcereg arg
1.648 raeburn 5535: body_title -> alternate text to use instead of $title
1.326 albertel 5536: in the title box that appears, this text
5537: is not auto translated like the $title is
1.648 raeburn 5538: frameset -> if true will start with a <frameset>
1.330 albertel 5539: rather than <body>
1.648 raeburn 5540: no_title -> if true the title bar won't be shown
5541: skip_phases -> hash ref of
1.338 albertel 5542: head -> skip the <html><head> generation
5543: body -> skip all <body> generation
1.648 raeburn 5544: no_inline_link -> if true and in remote mode, don't show the
1.361 albertel 5545: 'Switch To Inline Menu' link
1.648 raeburn 5546: no_auto_mt_title -> prevent &mt()ing the title arg
5547: inherit_jsmath -> when creating popup window in a page,
5548: should it have jsmath forced on by the
5549: current page
1.361 albertel 5550:
1.648 raeburn 5551: =back
1.460 albertel 5552:
1.648 raeburn 5553: =back
1.562 albertel 5554:
1.306 albertel 5555: =cut
5556:
5557: sub start_page {
1.309 albertel 5558: my ($title,$head_extra,$args) = @_;
1.318 albertel 5559: #&Apache::lonnet::logthis("start_page ".join(':',caller(0)));
1.313 albertel 5560: my %head_args;
1.352 albertel 5561: foreach my $arg ('redirect','force_register','domain','function',
1.460 albertel 5562: 'bgcolor','frameset','no_nav_bar','only_body',
5563: 'no_auto_mt_title') {
1.319 albertel 5564: if (defined($args->{$arg})) {
1.324 raeburn 5565: $head_args{$arg} = $args->{$arg};
1.319 albertel 5566: }
1.313 albertel 5567: }
1.319 albertel 5568:
1.315 albertel 5569: $env{'internal.start_page'}++;
1.338 albertel 5570: my $result;
5571: if (! exists($args->{'skip_phases'}{'head'}) ) {
5572: $result.=
1.341 albertel 5573: &xml_begin().
1.338 albertel 5574: &headtag($title,$head_extra,\%head_args).&endheadtag();
5575: }
5576:
5577: if (! exists($args->{'skip_phases'}{'body'}) ) {
5578: if ($args->{'frameset'}) {
5579: my $attr_string = &make_attr_string($args->{'force_register'},
5580: $args->{'add_entries'});
5581: $result .= "\n<frameset $attr_string>\n";
5582: } else {
5583: $result .=
5584: &bodytag($title,
5585: $args->{'function'}, $args->{'add_entries'},
5586: $args->{'only_body'}, $args->{'domain'},
5587: $args->{'force_register'}, $args->{'body_title'},
5588: $args->{'no_nav_bar'}, $args->{'bgcolor'},
1.460 albertel 5589: $args->{'no_title'}, $args->{'no_inline_link'},
5590: $args);
1.338 albertel 5591: }
1.330 albertel 5592: }
1.338 albertel 5593:
1.315 albertel 5594: if ($args->{'js_ready'}) {
1.317 albertel 5595: $result = &js_ready($result);
1.315 albertel 5596: }
1.320 albertel 5597: if ($args->{'html_encode'}) {
5598: $result = &html_encode($result);
5599: }
1.315 albertel 5600: return $result;
1.306 albertel 5601: }
5602:
1.330 albertel 5603:
1.306 albertel 5604: =pod
5605:
5606: =item * &head()
5607:
5608: Returns a complete </body></html> section for LON-CAPA web pages.
5609:
1.315 albertel 5610: Inputs: $args - additional optional args supported are:
5611: js_ready -> return a string ready for being used in
5612: a javascript writeln
1.320 albertel 5613: html_encode -> return a string ready for being used in
5614: a html attribute
1.330 albertel 5615: frameset -> if true will start with a <frameset>
5616: rather than <body>
1.493 albertel 5617: dicsussion -> if true will get discussion from
5618: lonxml::xmlend
5619: (you can pass the target and parser arguments
5620: through optional 'target' and 'parser' args
5621: to this routine)
1.306 albertel 5622:
5623: =cut
5624:
5625: sub end_page {
1.315 albertel 5626: my ($args) = @_;
5627: $env{'internal.end_page'}++;
1.330 albertel 5628: my $result;
1.335 albertel 5629: if ($args->{'discussion'}) {
5630: my ($target,$parser);
5631: if (ref($args->{'discussion'})) {
5632: ($target,$parser) =($args->{'discussion'}{'target'},
5633: $args->{'discussion'}{'parser'});
5634: }
5635: $result .= &Apache::lonxml::xmlend($target,$parser);
5636: }
5637:
1.330 albertel 5638: if ($args->{'frameset'}) {
5639: $result .= '</frameset>';
5640: } else {
1.635 raeburn 5641: $result .= &endbodytag($args);
1.330 albertel 5642: }
5643: $result .= "\n</html>";
5644:
1.315 albertel 5645: if ($args->{'js_ready'}) {
1.317 albertel 5646: $result = &js_ready($result);
1.315 albertel 5647: }
1.335 albertel 5648:
1.320 albertel 5649: if ($args->{'html_encode'}) {
5650: $result = &html_encode($result);
5651: }
1.335 albertel 5652:
1.315 albertel 5653: return $result;
5654: }
5655:
1.320 albertel 5656: sub html_encode {
5657: my ($result) = @_;
5658:
1.322 albertel 5659: $result = &HTML::Entities::encode($result,'<>&"');
1.320 albertel 5660:
5661: return $result;
5662: }
1.317 albertel 5663: sub js_ready {
5664: my ($result) = @_;
5665:
1.323 albertel 5666: $result =~ s/[\n\r]/ /xmsg;
5667: $result =~ s/\\/\\\\/xmsg;
5668: $result =~ s/'/\\'/xmsg;
1.372 albertel 5669: $result =~ s{</}{<\\/}xmsg;
1.317 albertel 5670:
5671: return $result;
5672: }
5673:
1.315 albertel 5674: sub validate_page {
5675: if ( exists($env{'internal.start_page'})
1.316 albertel 5676: && $env{'internal.start_page'} > 1) {
5677: &Apache::lonnet::logthis('start_page called multiple times '.
1.318 albertel 5678: $env{'internal.start_page'}.' '.
1.316 albertel 5679: $ENV{'request.filename'});
1.315 albertel 5680: }
5681: if ( exists($env{'internal.end_page'})
1.316 albertel 5682: && $env{'internal.end_page'} > 1) {
5683: &Apache::lonnet::logthis('end_page called multiple times '.
1.318 albertel 5684: $env{'internal.end_page'}.' '.
1.316 albertel 5685: $env{'request.filename'});
1.315 albertel 5686: }
5687: if ( exists($env{'internal.start_page'})
5688: && ! exists($env{'internal.end_page'})) {
1.316 albertel 5689: &Apache::lonnet::logthis('start_page called without end_page '.
5690: $env{'request.filename'});
1.315 albertel 5691: }
5692: if ( ! exists($env{'internal.start_page'})
5693: && exists($env{'internal.end_page'})) {
1.316 albertel 5694: &Apache::lonnet::logthis('end_page called without start_page'.
5695: $env{'request.filename'});
1.315 albertel 5696: }
1.306 albertel 5697: }
1.315 albertel 5698:
1.318 albertel 5699: sub simple_error_page {
5700: my ($r,$title,$msg) = @_;
5701: my $page =
5702: &Apache::loncommon::start_page($title).
5703: &mt($msg).
5704: &Apache::loncommon::end_page();
5705: if (ref($r)) {
5706: $r->print($page);
1.327 albertel 5707: return;
1.318 albertel 5708: }
5709: return $page;
5710: }
1.347 albertel 5711:
5712: {
1.610 albertel 5713: my @row_count;
1.347 albertel 5714: sub start_data_table {
1.422 albertel 5715: my ($add_class) = @_;
5716: my $css_class = (join(' ','LC_data_table',$add_class));
1.610 albertel 5717: unshift(@row_count,0);
1.422 albertel 5718: return '<table class="'.$css_class.'">'."\n";
1.347 albertel 5719: }
5720:
5721: sub end_data_table {
1.610 albertel 5722: shift(@row_count);
1.389 albertel 5723: return '</table>'."\n";;
1.347 albertel 5724: }
5725:
5726: sub start_data_table_row {
1.422 albertel 5727: my ($add_class) = @_;
1.610 albertel 5728: $row_count[0]++;
5729: my $css_class = ($row_count[0] % 2)?'LC_odd_row':'LC_even_row';
1.428 albertel 5730: $css_class = (join(' ',$css_class,$add_class));
1.422 albertel 5731: return '<tr class="'.$css_class.'">'."\n";;
1.347 albertel 5732: }
1.471 banghart 5733:
5734: sub continue_data_table_row {
5735: my ($add_class) = @_;
1.610 albertel 5736: my $css_class = ($row_count[0] % 2)?'LC_odd_row':'LC_even_row';
1.471 banghart 5737: $css_class = (join(' ',$css_class,$add_class));
5738: return '<tr class="'.$css_class.'">'."\n";;
5739: }
1.347 albertel 5740:
5741: sub end_data_table_row {
1.389 albertel 5742: return '</tr>'."\n";;
1.347 albertel 5743: }
1.367 www 5744:
1.421 albertel 5745: sub start_data_table_empty_row {
1.610 albertel 5746: $row_count[0]++;
1.421 albertel 5747: return '<tr class="LC_empty_row" >'."\n";;
5748: }
5749:
5750: sub end_data_table_empty_row {
5751: return '</tr>'."\n";;
5752: }
5753:
1.367 www 5754: sub start_data_table_header_row {
1.389 albertel 5755: return '<tr class="LC_header_row">'."\n";;
1.367 www 5756: }
5757:
5758: sub end_data_table_header_row {
1.389 albertel 5759: return '</tr>'."\n";;
1.367 www 5760: }
1.347 albertel 5761: }
5762:
1.548 albertel 5763: =pod
5764:
5765: =item * &inhibit_menu_check($arg)
5766:
5767: Checks for a inhibitmenu state and generates output to preserve it
5768:
5769: Inputs: $arg - can be any of
5770: - undef - in which case the return value is a string
5771: to add into arguments list of a uri
5772: - 'input' - in which case the return value is a HTML
5773: <form> <input> field of type hidden to
5774: preserve the value
5775: - a url - in which case the return value is the url with
5776: the neccesary cgi args added to preserve the
5777: inhibitmenu state
5778: - a ref to a url - no return value, but the string is
5779: updated to include the neccessary cgi
5780: args to preserve the inhibitmenu state
5781:
5782: =cut
5783:
5784: sub inhibit_menu_check {
5785: my ($arg) = @_;
5786: &get_unprocessed_cgi($ENV{'QUERY_STRING'}, ['inhibitmenu']);
5787: if ($arg eq 'input') {
5788: if ($env{'form.inhibitmenu'}) {
5789: return '<input type="hidden" name="inhibitmenu" value="'.$env{'form.inhibitmenu'}.'" />';
5790: } else {
5791: return
5792: }
5793: }
5794: if ($env{'form.inhibitmenu'}) {
5795: if (ref($arg)) {
5796: $$arg .= '?inhibitmenu='.$env{'form.inhibitmenu'};
5797: } elsif ($arg eq '') {
5798: $arg .= 'inhibitmenu='.$env{'form.inhibitmenu'};
5799: } else {
5800: $arg .= '?inhibitmenu='.$env{'form.inhibitmenu'};
5801: }
5802: }
5803: if (!ref($arg)) {
5804: return $arg;
5805: }
5806: }
5807:
1.251 albertel 5808: ###############################################
1.182 matthew 5809:
5810: =pod
5811:
1.549 albertel 5812: =back
5813:
5814: =head1 User Information Routines
5815:
5816: =over 4
5817:
1.405 albertel 5818: =item * &get_users_function()
1.182 matthew 5819:
5820: Used by &bodytag to determine the current users primary role.
5821: Returns either 'student','coordinator','admin', or 'author'.
5822:
5823: =cut
5824:
5825: ###############################################
5826: sub get_users_function {
5827: my $function = 'student';
1.258 albertel 5828: if ($env{'request.role'}=~/^(cc|in|ta|ep)/) {
1.182 matthew 5829: $function='coordinator';
5830: }
1.258 albertel 5831: if ($env{'request.role'}=~/^(su|dc|ad|li)/) {
1.182 matthew 5832: $function='admin';
5833: }
1.258 albertel 5834: if (($env{'request.role'}=~/^(au|ca)/) ||
1.182 matthew 5835: ($ENV{'REQUEST_URI'}=~/^(\/priv|\~)/)) {
5836: $function='author';
5837: }
5838: return $function;
1.54 www 5839: }
1.99 www 5840:
5841: ###############################################
5842:
1.233 raeburn 5843: =pod
5844:
1.542 raeburn 5845: =item * &check_user_status()
1.274 raeburn 5846:
5847: Determines current status of supplied role for a
5848: specific user. Roles can be active, previous or future.
5849:
5850: Inputs:
5851: user's domain, user's username, course's domain,
1.375 raeburn 5852: course's number, optional section ID.
1.274 raeburn 5853:
5854: Outputs:
5855: role status: active, previous or future.
5856:
5857: =cut
5858:
5859: sub check_user_status {
1.412 raeburn 5860: my ($udom,$uname,$cdom,$crs,$role,$sec) = @_;
1.274 raeburn 5861: my %userinfo = &Apache::lonnet::dump('roles',$udom,$uname);
5862: my @uroles = keys %userinfo;
5863: my $srchstr;
5864: my $active_chk = 'none';
1.412 raeburn 5865: my $now = time;
1.274 raeburn 5866: if (@uroles > 0) {
1.412 raeburn 5867: if (($role eq 'cc') || ($sec eq '') || (!defined($sec))) {
1.274 raeburn 5868: $srchstr = '/'.$cdom.'/'.$crs.'_'.$role;
5869: } else {
1.412 raeburn 5870: $srchstr = '/'.$cdom.'/'.$crs.'/'.$sec.'_'.$role;
5871: }
5872: if (grep/^\Q$srchstr\E$/,@uroles) {
1.274 raeburn 5873: my $role_end = 0;
5874: my $role_start = 0;
5875: $active_chk = 'active';
1.412 raeburn 5876: if ($userinfo{$srchstr} =~ m/^\Q$role\E_(\d+)/) {
5877: $role_end = $1;
5878: if ($userinfo{$srchstr} =~ m/^\Q$role\E_\Q$role_end\E_(\d+)$/) {
5879: $role_start = $1;
1.274 raeburn 5880: }
5881: }
5882: if ($role_start > 0) {
1.412 raeburn 5883: if ($now < $role_start) {
1.274 raeburn 5884: $active_chk = 'future';
5885: }
5886: }
5887: if ($role_end > 0) {
1.412 raeburn 5888: if ($now > $role_end) {
1.274 raeburn 5889: $active_chk = 'previous';
5890: }
5891: }
5892: }
5893: }
5894: return $active_chk;
5895: }
5896:
5897: ###############################################
5898:
5899: =pod
5900:
1.405 albertel 5901: =item * &get_sections()
1.233 raeburn 5902:
5903: Determines all the sections for a course including
5904: sections with students and sections containing other roles.
1.419 raeburn 5905: Incoming parameters:
5906:
5907: 1. domain
5908: 2. course number
5909: 3. reference to array containing roles for which sections should
5910: be gathered (optional).
5911: 4. reference to array containing status types for which sections
5912: should be gathered (optional).
5913:
5914: If the third argument is undefined, sections are gathered for any role.
5915: If the fourth argument is undefined, sections are gathered for any status.
5916: Permissible values are 'active' or 'future' or 'previous'.
1.233 raeburn 5917:
1.374 raeburn 5918: Returns section hash (keys are section IDs, values are
5919: number of users in each section), subject to the
1.419 raeburn 5920: optional roles filter, optional status filter
1.233 raeburn 5921:
5922: =cut
5923:
5924: ###############################################
5925: sub get_sections {
1.419 raeburn 5926: my ($cdom,$cnum,$possible_roles,$possible_status) = @_;
1.366 albertel 5927: if (!defined($cdom) || !defined($cnum)) {
5928: my $cid = $env{'request.course.id'};
5929:
5930: return if (!defined($cid));
5931:
5932: $cdom = $env{'course.'.$cid.'.domain'};
5933: $cnum = $env{'course.'.$cid.'.num'};
5934: }
5935:
5936: my %sectioncount;
1.419 raeburn 5937: my $now = time;
1.240 albertel 5938:
1.366 albertel 5939: if (!defined($possible_roles) || (grep(/^st$/,@$possible_roles))) {
1.276 albertel 5940: my ($classlist) = &Apache::loncoursedata::get_classlist($cdom,$cnum);
1.240 albertel 5941: my $sec_index = &Apache::loncoursedata::CL_SECTION();
5942: my $status_index = &Apache::loncoursedata::CL_STATUS();
1.419 raeburn 5943: my $start_index = &Apache::loncoursedata::CL_START();
5944: my $end_index = &Apache::loncoursedata::CL_END();
5945: my $status;
1.366 albertel 5946: while (my ($student,$data) = each(%$classlist)) {
1.419 raeburn 5947: my ($section,$stu_status,$start,$end) = ($data->[$sec_index],
5948: $data->[$status_index],
5949: $data->[$start_index],
5950: $data->[$end_index]);
5951: if ($stu_status eq 'Active') {
5952: $status = 'active';
5953: } elsif ($end < $now) {
5954: $status = 'previous';
5955: } elsif ($start > $now) {
5956: $status = 'future';
5957: }
5958: if ($section ne '-1' && $section !~ /^\s*$/) {
5959: if ((!defined($possible_status)) || (($status ne '') &&
5960: (grep/^\Q$status\E$/,@{$possible_status}))) {
5961: $sectioncount{$section}++;
5962: }
1.240 albertel 5963: }
5964: }
5965: }
5966: my %courseroles = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum);
5967: foreach my $user (sort(keys(%courseroles))) {
5968: if ($user !~ /^(\w{2})/) { next; }
5969: my ($role) = ($user =~ /^(\w{2})/);
5970: if ($possible_roles && !(grep(/^$role$/,@$possible_roles))) { next; }
1.419 raeburn 5971: my ($section,$status);
1.240 albertel 5972: if ($role eq 'cr' &&
5973: $user =~ m-^$role/[^/]*/[^/]*/[^/]*:[^:]*:[^:]*:(\w+)-) {
5974: $section=$1;
5975: }
5976: if ($user =~ /^$role:[^:]*:[^:]*:(\w+)/) { $section=$1; }
5977: if (!defined($section) || $section eq '-1') { next; }
1.419 raeburn 5978: my ($end,$start) = ($courseroles{$user} =~ /^([^:]*):([^:]*)$/);
5979: if ($end == -1 && $start == -1) {
5980: next; #deleted role
5981: }
5982: if (!defined($possible_status)) {
5983: $sectioncount{$section}++;
5984: } else {
5985: if ((!$end || $end >= $now) && (!$start || $start <= $now)) {
5986: $status = 'active';
5987: } elsif ($end < $now) {
5988: $status = 'future';
5989: } elsif ($start > $now) {
5990: $status = 'previous';
5991: }
5992: if (($status ne '') && (grep/^\Q$status\E$/,@{$possible_status})) {
5993: $sectioncount{$section}++;
5994: }
5995: }
1.233 raeburn 5996: }
1.366 albertel 5997: return %sectioncount;
1.233 raeburn 5998: }
5999:
1.274 raeburn 6000: ###############################################
1.294 raeburn 6001:
6002: =pod
1.405 albertel 6003:
6004: =item * &get_course_users()
6005:
1.275 raeburn 6006: Retrieves usernames:domains for users in the specified course
6007: with specific role(s), and access status.
6008:
6009: Incoming parameters:
1.277 albertel 6010: 1. course domain
6011: 2. course number
6012: 3. access status: users must have - either active,
1.275 raeburn 6013: previous, future, or all.
1.277 albertel 6014: 4. reference to array of permissible roles
1.288 raeburn 6015: 5. reference to array of section restrictions (optional)
6016: 6. reference to results object (hash of hashes).
6017: 7. reference to optional userdata hash
1.609 raeburn 6018: 8. reference to optional statushash
1.630 raeburn 6019: 9. flag if privileged users (except those set to unhide in
6020: course settings) should be excluded
1.609 raeburn 6021: Keys of top level results hash are roles.
1.275 raeburn 6022: Keys of inner hashes are username:domain, with
6023: values set to access type.
1.288 raeburn 6024: Optional userdata hash returns an array with arguments in the
6025: same order as loncoursedata::get_classlist() for student data.
6026:
1.609 raeburn 6027: Optional statushash returns
6028:
1.288 raeburn 6029: Entries for end, start, section and status are blank because
6030: of the possibility of multiple values for non-student roles.
6031:
1.275 raeburn 6032: =cut
1.405 albertel 6033:
1.275 raeburn 6034: ###############################################
1.405 albertel 6035:
1.275 raeburn 6036: sub get_course_users {
1.630 raeburn 6037: my ($cdom,$cnum,$types,$roles,$sections,$users,$userdata,$statushash,$hidepriv) = @_;
1.288 raeburn 6038: my %idx = ();
1.419 raeburn 6039: my %seclists;
1.288 raeburn 6040:
6041: $idx{udom} = &Apache::loncoursedata::CL_SDOM();
6042: $idx{uname} = &Apache::loncoursedata::CL_SNAME();
6043: $idx{end} = &Apache::loncoursedata::CL_END();
6044: $idx{start} = &Apache::loncoursedata::CL_START();
6045: $idx{id} = &Apache::loncoursedata::CL_ID();
6046: $idx{section} = &Apache::loncoursedata::CL_SECTION();
6047: $idx{fullname} = &Apache::loncoursedata::CL_FULLNAME();
6048: $idx{status} = &Apache::loncoursedata::CL_STATUS();
6049:
1.290 albertel 6050: if (grep(/^st$/,@{$roles})) {
1.276 albertel 6051: my ($classlist,$keylist)=&Apache::loncoursedata::get_classlist($cdom,$cnum);
1.278 raeburn 6052: my $now = time;
1.277 albertel 6053: foreach my $student (keys(%{$classlist})) {
1.288 raeburn 6054: my $match = 0;
1.412 raeburn 6055: my $secmatch = 0;
1.419 raeburn 6056: my $section = $$classlist{$student}[$idx{section}];
1.609 raeburn 6057: my $status = $$classlist{$student}[$idx{status}];
1.419 raeburn 6058: if ($section eq '') {
6059: $section = 'none';
6060: }
1.291 albertel 6061: if ((ref($sections) eq 'ARRAY') && (@{$sections} > 0)) {
1.420 albertel 6062: if (grep(/^all$/,@{$sections})) {
1.412 raeburn 6063: $secmatch = 1;
6064: } elsif ($$classlist{$student}[$idx{section}] eq '') {
1.420 albertel 6065: if (grep(/^none$/,@{$sections})) {
1.412 raeburn 6066: $secmatch = 1;
6067: }
6068: } else {
1.419 raeburn 6069: if (grep(/^\Q$section\E$/,@{$sections})) {
1.412 raeburn 6070: $secmatch = 1;
6071: }
1.290 albertel 6072: }
1.412 raeburn 6073: if (!$secmatch) {
6074: next;
6075: }
1.419 raeburn 6076: }
1.275 raeburn 6077: if (defined($$types{'active'})) {
1.288 raeburn 6078: if ($$classlist{$student}[$idx{status}] eq 'Active') {
1.275 raeburn 6079: push(@{$$users{st}{$student}},'active');
1.288 raeburn 6080: $match = 1;
1.275 raeburn 6081: }
6082: }
6083: if (defined($$types{'previous'})) {
1.609 raeburn 6084: if ($$classlist{$student}[$idx{status}] eq 'Expired') {
1.275 raeburn 6085: push(@{$$users{st}{$student}},'previous');
1.288 raeburn 6086: $match = 1;
1.275 raeburn 6087: }
6088: }
6089: if (defined($$types{'future'})) {
1.609 raeburn 6090: if ($$classlist{$student}[$idx{status}] eq 'Future') {
1.275 raeburn 6091: push(@{$$users{st}{$student}},'future');
1.288 raeburn 6092: $match = 1;
1.275 raeburn 6093: }
6094: }
1.609 raeburn 6095: if ($match) {
6096: push(@{$seclists{$student}},$section);
6097: if (ref($userdata) eq 'HASH') {
6098: $$userdata{$student} = $$classlist{$student};
6099: }
6100: if (ref($statushash) eq 'HASH') {
6101: $statushash->{$student}{'st'}{$section} = $status;
6102: }
1.288 raeburn 6103: }
1.275 raeburn 6104: }
6105: }
1.412 raeburn 6106: if ((@{$roles} > 1) || ((@{$roles} == 1) && ($$roles[0] ne "st"))) {
1.439 raeburn 6107: my %coursepersonnel = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum);
6108: my $now = time;
1.609 raeburn 6109: my %displaystatus = ( previous => 'Expired',
6110: active => 'Active',
6111: future => 'Future',
6112: );
1.630 raeburn 6113: my %nothide;
6114: if ($hidepriv) {
6115: my %coursehash=&Apache::lonnet::coursedescription($cdom.'_'.$cnum);
6116: foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
6117: if ($user !~ /:/) {
6118: $nothide{join(':',split(/[\@]/,$user))}=1;
6119: } else {
6120: $nothide{$user} = 1;
6121: }
6122: }
6123: }
1.439 raeburn 6124: foreach my $person (sort(keys(%coursepersonnel))) {
1.288 raeburn 6125: my $match = 0;
1.412 raeburn 6126: my $secmatch = 0;
1.439 raeburn 6127: my $status;
1.412 raeburn 6128: my ($role,$user,$usec) = ($person =~ /^([^:]*):([^:]+:[^:]+):([^:]*)/);
1.275 raeburn 6129: $user =~ s/:$//;
1.439 raeburn 6130: my ($end,$start) = split(/:/,$coursepersonnel{$person});
6131: if ($end == -1 || $start == -1) {
6132: next;
6133: }
6134: if (($role) && ((grep(/^\Q$role\E$/,@{$roles})) ||
6135: (grep(/^cr$/,@{$roles}) && $role =~ /^cr\//))) {
1.412 raeburn 6136: my ($uname,$udom) = split(/:/,$user);
6137: if ((ref($sections) eq 'ARRAY') && (@{$sections} > 0)) {
1.420 albertel 6138: if (grep(/^all$/,@{$sections})) {
1.412 raeburn 6139: $secmatch = 1;
6140: } elsif ($usec eq '') {
1.420 albertel 6141: if (grep(/^none$/,@{$sections})) {
1.412 raeburn 6142: $secmatch = 1;
6143: }
6144: } else {
6145: if (grep(/^\Q$usec\E$/,@{$sections})) {
6146: $secmatch = 1;
6147: }
6148: }
6149: if (!$secmatch) {
6150: next;
6151: }
1.288 raeburn 6152: }
1.419 raeburn 6153: if ($usec eq '') {
6154: $usec = 'none';
6155: }
1.275 raeburn 6156: if ($uname ne '' && $udom ne '') {
1.630 raeburn 6157: if ($hidepriv) {
6158: if ((&Apache::lonnet::privileged($uname,$udom)) &&
6159: (!$nothide{$uname.':'.$udom})) {
6160: next;
6161: }
6162: }
1.503 raeburn 6163: if ($end > 0 && $end < $now) {
1.439 raeburn 6164: $status = 'previous';
6165: } elsif ($start > $now) {
6166: $status = 'future';
6167: } else {
6168: $status = 'active';
6169: }
1.277 albertel 6170: foreach my $type (keys(%{$types})) {
1.275 raeburn 6171: if ($status eq $type) {
1.420 albertel 6172: if (!grep(/^\Q$type\E$/,@{$$users{$role}{$user}})) {
1.419 raeburn 6173: push(@{$$users{$role}{$user}},$type);
6174: }
1.288 raeburn 6175: $match = 1;
6176: }
6177: }
1.419 raeburn 6178: if (($match) && (ref($userdata) eq 'HASH')) {
6179: if (!exists($$userdata{$uname.':'.$udom})) {
6180: &get_user_info($udom,$uname,\%idx,$userdata);
6181: }
1.420 albertel 6182: if (!grep(/^\Q$usec\E$/,@{$seclists{$uname.':'.$udom}})) {
1.419 raeburn 6183: push(@{$seclists{$uname.':'.$udom}},$usec);
6184: }
1.609 raeburn 6185: if (ref($statushash) eq 'HASH') {
6186: $statushash->{$uname.':'.$udom}{$role}{$usec} = $displaystatus{$status};
6187: }
1.275 raeburn 6188: }
6189: }
6190: }
6191: }
1.290 albertel 6192: if (grep(/^ow$/,@{$roles})) {
1.279 raeburn 6193: if ((defined($cdom)) && (defined($cnum))) {
6194: my %csettings = &Apache::lonnet::get('environment',['internal.courseowner'],$cdom,$cnum);
6195: if ( defined($csettings{'internal.courseowner'}) ) {
6196: my $owner = $csettings{'internal.courseowner'};
1.609 raeburn 6197: next if ($owner eq '');
6198: my ($ownername,$ownerdom);
6199: if ($owner =~ /^([^:]+):([^:]+)$/) {
6200: $ownername = $1;
6201: $ownerdom = $2;
6202: } else {
6203: $ownername = $owner;
6204: $ownerdom = $cdom;
6205: $owner = $ownername.':'.$ownerdom;
1.439 raeburn 6206: }
6207: @{$$users{'ow'}{$owner}} = 'any';
1.290 albertel 6208: if (defined($userdata) &&
1.609 raeburn 6209: !exists($$userdata{$owner})) {
6210: &get_user_info($ownerdom,$ownername,\%idx,$userdata);
6211: if (!grep(/^none$/,@{$seclists{$owner}})) {
6212: push(@{$seclists{$owner}},'none');
6213: }
6214: if (ref($statushash) eq 'HASH') {
6215: $statushash->{$owner}{'ow'}{'none'} = 'Any';
1.419 raeburn 6216: }
1.290 albertel 6217: }
1.279 raeburn 6218: }
6219: }
6220: }
1.419 raeburn 6221: foreach my $user (keys(%seclists)) {
6222: @{$seclists{$user}} = (sort {$a <=> $b} @{$seclists{$user}});
6223: $$userdata{$user}[$idx{section}] = join(',',@{$seclists{$user}});
6224: }
1.275 raeburn 6225: }
6226: return;
6227: }
6228:
1.288 raeburn 6229: sub get_user_info {
6230: my ($udom,$uname,$idx,$userdata) = @_;
1.289 albertel 6231: $$userdata{$uname.':'.$udom}[$$idx{fullname}] =
6232: &plainname($uname,$udom,'lastname');
1.291 albertel 6233: $$userdata{$uname.':'.$udom}[$$idx{uname}] = $uname;
1.297 raeburn 6234: $$userdata{$uname.':'.$udom}[$$idx{udom}] = $udom;
1.609 raeburn 6235: my %idhash = &Apache::lonnet::idrget($udom,($uname));
6236: $$userdata{$uname.':'.$udom}[$$idx{id}] = $idhash{$uname};
1.288 raeburn 6237: return;
6238: }
1.275 raeburn 6239:
1.472 raeburn 6240: ###############################################
6241:
6242: =pod
6243:
6244: =item * &get_user_quota()
6245:
6246: Retrieves quota assigned for storage of portfolio files for a user
6247:
6248: Incoming parameters:
6249: 1. user's username
6250: 2. user's domain
6251:
6252: Returns:
1.536 raeburn 6253: 1. Disk quota (in Mb) assigned to student.
6254: 2. (Optional) Type of setting: custom or default
6255: (individually assigned or default for user's
6256: institutional status).
6257: 3. (Optional) - User's institutional status (e.g., faculty, staff
6258: or student - types as defined in localenroll::inst_usertypes
6259: for user's domain, which determines default quota for user.
6260: 4. (Optional) - Default quota which would apply to the user.
1.472 raeburn 6261:
6262: If a value has been stored in the user's environment,
1.536 raeburn 6263: it will return that, otherwise it returns the maximal default
6264: defined for the user's instituional status(es) in the domain.
1.472 raeburn 6265:
6266: =cut
6267:
6268: ###############################################
6269:
6270:
6271: sub get_user_quota {
6272: my ($uname,$udom) = @_;
1.536 raeburn 6273: my ($quota,$quotatype,$settingstatus,$defquota);
1.472 raeburn 6274: if (!defined($udom)) {
6275: $udom = $env{'user.domain'};
6276: }
6277: if (!defined($uname)) {
6278: $uname = $env{'user.name'};
6279: }
6280: if (($udom eq '' || $uname eq '') ||
6281: ($udom eq 'public') && ($uname eq 'public')) {
6282: $quota = 0;
1.536 raeburn 6283: $quotatype = 'default';
6284: $defquota = 0;
1.472 raeburn 6285: } else {
1.536 raeburn 6286: my $inststatus;
1.472 raeburn 6287: if ($udom eq $env{'user.domain'} && $uname eq $env{'user.name'}) {
6288: $quota = $env{'environment.portfolioquota'};
1.536 raeburn 6289: $inststatus = $env{'environment.inststatus'};
1.472 raeburn 6290: } else {
1.536 raeburn 6291: my %userenv =
6292: &Apache::lonnet::get('environment',['portfolioquota',
6293: 'inststatus'],$udom,$uname);
1.472 raeburn 6294: my ($tmp) = keys(%userenv);
6295: if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
6296: $quota = $userenv{'portfolioquota'};
1.536 raeburn 6297: $inststatus = $userenv{'inststatus'};
1.472 raeburn 6298: } else {
6299: undef(%userenv);
6300: }
6301: }
1.536 raeburn 6302: ($defquota,$settingstatus) = &default_quota($udom,$inststatus);
1.472 raeburn 6303: if ($quota eq '') {
1.536 raeburn 6304: $quota = $defquota;
6305: $quotatype = 'default';
6306: } else {
6307: $quotatype = 'custom';
1.472 raeburn 6308: }
6309: }
1.536 raeburn 6310: if (wantarray) {
6311: return ($quota,$quotatype,$settingstatus,$defquota);
6312: } else {
6313: return $quota;
6314: }
1.472 raeburn 6315: }
6316:
6317: ###############################################
6318:
6319: =pod
6320:
6321: =item * &default_quota()
6322:
1.536 raeburn 6323: Retrieves default quota assigned for storage of user portfolio files,
6324: given an (optional) user's institutional status.
1.472 raeburn 6325:
6326: Incoming parameters:
6327: 1. domain
1.536 raeburn 6328: 2. (Optional) institutional status(es). This is a : separated list of
6329: status types (e.g., faculty, staff, student etc.)
6330: which apply to the user for whom the default is being retrieved.
6331: If the institutional status string in undefined, the domain
6332: default quota will be returned.
1.472 raeburn 6333:
6334: Returns:
6335: 1. Default disk quota (in Mb) for user portfolios in the domain.
1.536 raeburn 6336: 2. (Optional) institutional type which determined the value of the
6337: default quota.
1.472 raeburn 6338:
6339: If a value has been stored in the domain's configuration db,
6340: it will return that, otherwise it returns 20 (for backwards
6341: compatibility with domains which have not set up a configuration
6342: db file; the original statically defined portfolio quota was 20 Mb).
6343:
1.536 raeburn 6344: If the user's status includes multiple types (e.g., staff and student),
6345: the largest default quota which applies to the user determines the
6346: default quota returned.
6347:
1.472 raeburn 6348: =cut
6349:
6350: ###############################################
6351:
6352:
6353: sub default_quota {
1.536 raeburn 6354: my ($udom,$inststatus) = @_;
6355: my ($defquota,$settingstatus);
6356: my %quotahash = &Apache::lonnet::get_dom('configuration',
1.622 raeburn 6357: ['quotas'],$udom);
6358: if (ref($quotahash{'quotas'}) eq 'HASH') {
1.536 raeburn 6359: if ($inststatus ne '') {
6360: my @statuses = split(/:/,$inststatus);
6361: foreach my $item (@statuses) {
1.622 raeburn 6362: if ($quotahash{'quotas'}{$item} ne '') {
1.536 raeburn 6363: if ($defquota eq '') {
1.622 raeburn 6364: $defquota = $quotahash{'quotas'}{$item};
1.536 raeburn 6365: $settingstatus = $item;
1.622 raeburn 6366: } elsif ($quotahash{'quotas'}{$item} > $defquota) {
6367: $defquota = $quotahash{'quotas'}{$item};
1.536 raeburn 6368: $settingstatus = $item;
6369: }
6370: }
6371: }
6372: }
6373: if ($defquota eq '') {
1.622 raeburn 6374: $defquota = $quotahash{'quotas'}{'default'};
1.536 raeburn 6375: $settingstatus = 'default';
6376: }
6377: } else {
6378: $settingstatus = 'default';
6379: $defquota = 20;
6380: }
6381: if (wantarray) {
6382: return ($defquota,$settingstatus);
1.472 raeburn 6383: } else {
1.536 raeburn 6384: return $defquota;
1.472 raeburn 6385: }
6386: }
6387:
1.384 raeburn 6388: sub get_secgrprole_info {
6389: my ($cdom,$cnum,$needroles,$type) = @_;
6390: my %sections_count = &get_sections($cdom,$cnum);
6391: my @sections = (sort {$a <=> $b} keys(%sections_count));
6392: my %curr_groups = &Apache::longroup::coursegroups($cdom,$cnum);
6393: my @groups = sort(keys(%curr_groups));
6394: my $allroles = [];
6395: my $rolehash;
6396: my $accesshash = {
6397: active => 'Currently has access',
6398: future => 'Will have future access',
6399: previous => 'Previously had access',
6400: };
6401: if ($needroles) {
6402: $rolehash = {'all' => 'all'};
1.385 albertel 6403: my %user_roles = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum);
6404: if (&Apache::lonnet::error(%user_roles)) {
6405: undef(%user_roles);
6406: }
6407: foreach my $item (keys(%user_roles)) {
1.384 raeburn 6408: my ($role)=split(/\:/,$item,2);
6409: if ($role eq 'cr') { next; }
6410: if ($role =~ /^cr/) {
6411: $$rolehash{$role} = (split('/',$role))[3];
6412: } else {
6413: $$rolehash{$role} = &Apache::lonnet::plaintext($role,$type);
6414: }
6415: }
6416: foreach my $key (sort(keys(%{$rolehash}))) {
6417: push(@{$allroles},$key);
6418: }
6419: push (@{$allroles},'st');
6420: $$rolehash{'st'} = &Apache::lonnet::plaintext('st',$type);
6421: }
6422: return (\@sections,\@groups,$allroles,$rolehash,$accesshash);
6423: }
6424:
1.555 raeburn 6425: sub user_picker {
1.627 raeburn 6426: my ($dom,$srch,$forcenewuser,$caller,$cancreate,$usertype) = @_;
1.555 raeburn 6427: my $currdom = $dom;
6428: my %curr_selected = (
6429: srchin => 'dom',
1.580 raeburn 6430: srchby => 'lastname',
1.555 raeburn 6431: );
6432: my $srchterm;
1.625 raeburn 6433: if ((ref($srch) eq 'HASH') && ($env{'form.origform'} ne 'crtusername')) {
1.555 raeburn 6434: if ($srch->{'srchby'} ne '') {
6435: $curr_selected{'srchby'} = $srch->{'srchby'};
6436: }
6437: if ($srch->{'srchin'} ne '') {
6438: $curr_selected{'srchin'} = $srch->{'srchin'};
6439: }
6440: if ($srch->{'srchtype'} ne '') {
6441: $curr_selected{'srchtype'} = $srch->{'srchtype'};
6442: }
6443: if ($srch->{'srchdomain'} ne '') {
6444: $currdom = $srch->{'srchdomain'};
6445: }
6446: $srchterm = $srch->{'srchterm'};
6447: }
6448: my %lt=&Apache::lonlocal::texthash(
1.573 raeburn 6449: 'usr' => 'Search criteria',
1.563 raeburn 6450: 'doma' => 'Domain/institution to search',
1.558 albertel 6451: 'uname' => 'username',
6452: 'lastname' => 'last name',
1.555 raeburn 6453: 'lastfirst' => 'last name, first name',
1.558 albertel 6454: 'crs' => 'in this course',
1.576 raeburn 6455: 'dom' => 'in selected LON-CAPA domain',
1.558 albertel 6456: 'alc' => 'all LON-CAPA',
1.573 raeburn 6457: 'instd' => 'in institutional directory for selected domain',
1.558 albertel 6458: 'exact' => 'is',
6459: 'contains' => 'contains',
1.569 raeburn 6460: 'begins' => 'begins with',
1.571 raeburn 6461: 'youm' => "You must include some text to search for.",
6462: 'thte' => "The text you are searching for must contain at least two characters when using a 'begins' type search.",
6463: 'thet' => "The text you are searching for must contain at least three characters when using a 'contains' type search.",
6464: 'yomc' => "You must choose a domain when using an institutional directory search.",
6465: 'ymcd' => "You must choose a domain when using a domain search.",
6466: 'whus' => "When using searching by last,first you must include a comma as separator between last name and first name.",
6467: 'whse' => "When searching by last,first you must include at least one character in the first name.",
6468: 'thfo' => "The following need to be corrected before the search can be run:",
1.555 raeburn 6469: );
1.563 raeburn 6470: my $domform = &select_dom_form($currdom,'srchdomain',1,1);
6471: my $srchinsel = ' <select name="srchin">';
1.555 raeburn 6472:
6473: my @srchins = ('crs','dom','alc','instd');
6474:
6475: foreach my $option (@srchins) {
6476: # FIXME 'alc' option unavailable until
6477: # loncreateuser::print_user_query_page()
6478: # has been completed.
6479: next if ($option eq 'alc');
6480: next if ($option eq 'crs' && !$env{'request.course.id'});
1.563 raeburn 6481: if ($curr_selected{'srchin'} eq $option) {
6482: $srchinsel .= '
6483: <option value="'.$option.'" selected="selected">'.$lt{$option}.'</option>';
6484: } else {
6485: $srchinsel .= '
6486: <option value="'.$option.'">'.$lt{$option}.'</option>';
6487: }
1.555 raeburn 6488: }
1.563 raeburn 6489: $srchinsel .= "\n </select>\n";
1.555 raeburn 6490:
6491: my $srchbysel = ' <select name="srchby">';
1.580 raeburn 6492: foreach my $option ('lastname','lastfirst','uname') {
1.555 raeburn 6493: if ($curr_selected{'srchby'} eq $option) {
6494: $srchbysel .= '
6495: <option value="'.$option.'" selected="selected">'.$lt{$option}.'</option>';
6496: } else {
6497: $srchbysel .= '
6498: <option value="'.$option.'">'.$lt{$option}.'</option>';
6499: }
6500: }
6501: $srchbysel .= "\n </select>\n";
6502:
6503: my $srchtypesel = ' <select name="srchtype">';
1.580 raeburn 6504: foreach my $option ('begins','contains','exact') {
1.555 raeburn 6505: if ($curr_selected{'srchtype'} eq $option) {
6506: $srchtypesel .= '
6507: <option value="'.$option.'" selected="selected">'.$lt{$option}.'</option>';
6508: } else {
6509: $srchtypesel .= '
6510: <option value="'.$option.'">'.$lt{$option}.'</option>';
6511: }
6512: }
6513: $srchtypesel .= "\n </select>\n";
6514:
1.558 albertel 6515: my ($newuserscript,$new_user_create);
1.556 raeburn 6516:
6517: if ($forcenewuser) {
1.576 raeburn 6518: if (ref($srch) eq 'HASH') {
6519: if ($srch->{'srchby'} eq 'uname' && $srch->{'srchtype'} eq 'exact' && $srch->{'srchin'} eq 'dom' && $srch->{'srchdomain'} eq $env{'request.role.domain'}) {
1.627 raeburn 6520: if ($cancreate) {
6521: $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>';
6522: } else {
6523: my $helplink = ' href="javascript:helpMenu('."'display'".')"';
6524: my %usertypetext = (
6525: official => 'institutional',
6526: unofficial => 'non-institutional',
6527: );
6528: $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 />';
6529: }
1.576 raeburn 6530: }
6531: }
6532:
1.556 raeburn 6533: $newuserscript = <<"ENDSCRIPT";
6534:
1.570 raeburn 6535: function setSearch(createnew,callingForm) {
1.556 raeburn 6536: if (createnew == 1) {
1.570 raeburn 6537: for (var i=0; i<callingForm.srchby.length; i++) {
6538: if (callingForm.srchby.options[i].value == 'uname') {
6539: callingForm.srchby.selectedIndex = i;
1.556 raeburn 6540: }
6541: }
1.570 raeburn 6542: for (var i=0; i<callingForm.srchin.length; i++) {
6543: if ( callingForm.srchin.options[i].value == 'dom') {
6544: callingForm.srchin.selectedIndex = i;
1.556 raeburn 6545: }
6546: }
1.570 raeburn 6547: for (var i=0; i<callingForm.srchtype.length; i++) {
6548: if (callingForm.srchtype.options[i].value == 'exact') {
6549: callingForm.srchtype.selectedIndex = i;
1.556 raeburn 6550: }
6551: }
1.570 raeburn 6552: for (var i=0; i<callingForm.srchdomain.length; i++) {
6553: if (callingForm.srchdomain.options[i].value == '$env{'request.role.domain'}') {
6554: callingForm.srchdomain.selectedIndex = i;
1.556 raeburn 6555: }
6556: }
6557: }
6558: }
6559: ENDSCRIPT
1.558 albertel 6560:
1.556 raeburn 6561: }
6562:
1.555 raeburn 6563: my $output = <<"END_BLOCK";
1.556 raeburn 6564: <script type="text/javascript">
1.570 raeburn 6565: function validateEntry(callingForm) {
1.558 albertel 6566:
1.556 raeburn 6567: var checkok = 1;
1.558 albertel 6568: var srchin;
1.570 raeburn 6569: for (var i=0; i<callingForm.srchin.length; i++) {
6570: if ( callingForm.srchin[i].checked ) {
6571: srchin = callingForm.srchin[i].value;
1.558 albertel 6572: }
6573: }
6574:
1.570 raeburn 6575: var srchtype = callingForm.srchtype.options[callingForm.srchtype.selectedIndex].value;
6576: var srchby = callingForm.srchby.options[callingForm.srchby.selectedIndex].value;
6577: var srchdomain = callingForm.srchdomain.options[callingForm.srchdomain.selectedIndex].value;
6578: var srchterm = callingForm.srchterm.value;
6579: var srchin = callingForm.srchin.options[callingForm.srchin.selectedIndex].value;
1.556 raeburn 6580: var msg = "";
6581:
6582: if (srchterm == "") {
6583: checkok = 0;
1.571 raeburn 6584: msg += "$lt{'youm'}\\n";
1.556 raeburn 6585: }
6586:
1.569 raeburn 6587: if (srchtype== 'begins') {
6588: if (srchterm.length < 2) {
6589: checkok = 0;
1.571 raeburn 6590: msg += "$lt{'thte'}\\n";
1.569 raeburn 6591: }
6592: }
6593:
1.556 raeburn 6594: if (srchtype== 'contains') {
6595: if (srchterm.length < 3) {
6596: checkok = 0;
1.571 raeburn 6597: msg += "$lt{'thet'}\\n";
1.556 raeburn 6598: }
6599: }
6600: if (srchin == 'instd') {
6601: if (srchdomain == '') {
6602: checkok = 0;
1.571 raeburn 6603: msg += "$lt{'yomc'}\\n";
1.556 raeburn 6604: }
6605: }
6606: if (srchin == 'dom') {
6607: if (srchdomain == '') {
6608: checkok = 0;
1.571 raeburn 6609: msg += "$lt{'ymcd'}\\n";
1.556 raeburn 6610: }
6611: }
6612: if (srchby == 'lastfirst') {
6613: if (srchterm.indexOf(",") == -1) {
6614: checkok = 0;
1.571 raeburn 6615: msg += "$lt{'whus'}\\n";
1.556 raeburn 6616: }
6617: if (srchterm.indexOf(",") == srchterm.length -1) {
6618: checkok = 0;
1.571 raeburn 6619: msg += "$lt{'whse'}\\n";
1.556 raeburn 6620: }
6621: }
6622: if (checkok == 0) {
1.571 raeburn 6623: alert("$lt{'thfo'}\\n"+msg);
1.556 raeburn 6624: return;
6625: }
6626: if (checkok == 1) {
1.570 raeburn 6627: callingForm.submit();
1.556 raeburn 6628: }
6629: }
6630:
6631: $newuserscript
6632:
6633: </script>
1.558 albertel 6634:
6635: $new_user_create
6636:
1.555 raeburn 6637: <table>
1.558 albertel 6638: <tr>
1.573 raeburn 6639: <td>$lt{'doma'}:</td>
6640: <td>$domform</td>
6641: </td>
6642: </tr>
6643: <tr>
6644: <td>$lt{'usr'}:</td>
1.563 raeburn 6645: <td>$srchbysel
6646: $srchtypesel
6647: <input type="text" size="15" name="srchterm" value="$srchterm" />
1.564 albertel 6648: $srchinsel
1.563 raeburn 6649: </td>
6650: </tr>
1.555 raeburn 6651: </table>
6652: <br />
6653: END_BLOCK
1.558 albertel 6654:
1.555 raeburn 6655: return $output;
6656: }
6657:
1.612 raeburn 6658: sub user_rule_check {
1.615 raeburn 6659: my ($usershash,$checks,$alerts,$rulematch,$inst_results,$curr_rules,$got_rules) = @_;
1.612 raeburn 6660: my $response;
6661: if (ref($usershash) eq 'HASH') {
6662: foreach my $user (keys(%{$usershash})) {
6663: my ($uname,$udom) = split(/:/,$user);
6664: next if ($udom eq '' || $uname eq '');
1.615 raeburn 6665: my ($id,$newuser);
1.612 raeburn 6666: if (ref($usershash->{$user}) eq 'HASH') {
1.615 raeburn 6667: $newuser = $usershash->{$user}->{'newuser'};
1.612 raeburn 6668: $id = $usershash->{$user}->{'id'};
6669: }
6670: my $inst_response;
6671: if (ref($checks) eq 'HASH') {
6672: if (defined($checks->{'username'})) {
1.615 raeburn 6673: ($inst_response,%{$inst_results->{$user}}) =
1.612 raeburn 6674: &Apache::lonnet::get_instuser($udom,$uname);
6675: } elsif (defined($checks->{'id'})) {
1.615 raeburn 6676: ($inst_response,%{$inst_results->{$user}}) =
1.612 raeburn 6677: &Apache::lonnet::get_instuser($udom,undef,$id);
6678: }
1.615 raeburn 6679: } else {
6680: ($inst_response,%{$inst_results->{$user}}) =
6681: &Apache::lonnet::get_instuser($udom,$uname);
6682: return;
1.612 raeburn 6683: }
1.615 raeburn 6684: if (!$got_rules->{$udom}) {
1.612 raeburn 6685: my %domconfig = &Apache::lonnet::get_dom('configuration',
6686: ['usercreation'],$udom);
6687: if (ref($domconfig{'usercreation'}) eq 'HASH') {
1.615 raeburn 6688: foreach my $item ('username','id') {
1.612 raeburn 6689: if (ref($domconfig{'usercreation'}{$item.'_rule'}) eq 'ARRAY') {
6690: $$curr_rules{$udom}{$item} =
6691: $domconfig{'usercreation'}{$item.'_rule'};
1.585 raeburn 6692: }
6693: }
6694: }
1.615 raeburn 6695: $got_rules->{$udom} = 1;
1.585 raeburn 6696: }
1.612 raeburn 6697: foreach my $item (keys(%{$checks})) {
6698: if (ref($$curr_rules{$udom}) eq 'HASH') {
6699: if (ref($$curr_rules{$udom}{$item}) eq 'ARRAY') {
6700: if (@{$$curr_rules{$udom}{$item}} > 0) {
6701: my %rule_check = &Apache::lonnet::inst_rulecheck($udom,$uname,$id,$item,$$curr_rules{$udom}{$item});
6702: foreach my $rule (@{$$curr_rules{$udom}{$item}}) {
6703: if ($rule_check{$rule}) {
6704: $$rulematch{$user}{$item} = $rule;
6705: if ($inst_response eq 'ok') {
1.615 raeburn 6706: if (ref($inst_results) eq 'HASH') {
6707: if (ref($inst_results->{$user}) eq 'HASH') {
6708: if (keys(%{$inst_results->{$user}}) == 0) {
6709: $$alerts{$item}{$udom}{$uname} = 1;
6710: }
1.612 raeburn 6711: }
6712: }
1.615 raeburn 6713: }
6714: last;
1.585 raeburn 6715: }
6716: }
6717: }
6718: }
6719: }
6720: }
6721: }
6722: }
1.612 raeburn 6723: return;
6724: }
6725:
6726: sub user_rule_formats {
6727: my ($domain,$domdesc,$curr_rules,$check) = @_;
6728: my %text = (
6729: 'username' => 'Usernames',
6730: 'id' => 'IDs',
6731: );
6732: my $output;
6733: my ($rules,$ruleorder) = &Apache::lonnet::inst_userrules($domain,$check);
6734: if ((ref($rules) eq 'HASH') && (ref($ruleorder) eq 'ARRAY')) {
6735: if (@{$ruleorder} > 0) {
6736: $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>';
6737: foreach my $rule (@{$ruleorder}) {
6738: if (ref($curr_rules) eq 'ARRAY') {
6739: if (grep(/^\Q$rule\E$/,@{$curr_rules})) {
6740: if (ref($rules->{$rule}) eq 'HASH') {
6741: $output .= '<li>'.$rules->{$rule}{'name'}.': '.
6742: $rules->{$rule}{'desc'}.'</li>';
6743: }
6744: }
6745: }
6746: }
6747: $output .= '</ul>';
6748: }
6749: }
6750: return $output;
6751: }
6752:
6753: sub instrule_disallow_msg {
1.615 raeburn 6754: my ($checkitem,$domdesc,$count,$mode) = @_;
1.612 raeburn 6755: my $response;
6756: my %text = (
6757: item => 'username',
6758: items => 'usernames',
6759: match => 'matches',
6760: do => 'does',
6761: action => 'a username',
6762: one => 'one',
6763: );
6764: if ($count > 1) {
6765: $text{'item'} = 'usernames';
6766: $text{'match'} ='match';
6767: $text{'do'} = 'do';
6768: $text{'action'} = 'usernames',
6769: $text{'one'} = 'ones';
6770: }
6771: if ($checkitem eq 'id') {
6772: $text{'items'} = 'IDs';
6773: $text{'item'} = 'ID';
6774: $text{'action'} = 'an ID';
1.615 raeburn 6775: if ($count > 1) {
6776: $text{'item'} = 'IDs';
6777: $text{'action'} = 'IDs';
6778: }
1.612 raeburn 6779: }
6780: $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 6781: if ($mode eq 'upload') {
6782: if ($checkitem eq 'username') {
6783: $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'}.");
6784: } elsif ($checkitem eq 'id') {
6785: $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.");
6786: }
6787: } else {
6788: if ($checkitem eq 'username') {
6789: $response .= &mt("You must choose $text{'action'} with a different format -- $text{'one'} that will not conflict with 'official' institutional $text{'items'}.");
6790: } elsif ($checkitem eq 'id') {
6791: $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.");
6792: }
1.612 raeburn 6793: }
6794: return $response;
1.585 raeburn 6795: }
6796:
1.624 raeburn 6797: sub personal_data_fieldtitles {
6798: my %fieldtitles = &Apache::lonlocal::texthash (
6799: id => 'Student/Employee ID',
6800: permanentemail => 'E-mail address',
6801: lastname => 'Last Name',
6802: firstname => 'First Name',
6803: middlename => 'Middle Name',
6804: generation => 'Generation',
6805: gen => 'Generation',
6806: );
6807: return %fieldtitles;
6808: }
6809:
1.642 raeburn 6810: sub sorted_inst_types {
6811: my ($dom) = @_;
6812: my ($usertypes,$order) = &Apache::lonnet::retrieve_inst_usertypes($dom);
6813: my $othertitle = &mt('All users');
6814: if ($env{'request.course.id'}) {
6815: $othertitle = 'any';
6816: }
6817: my @types;
6818: if (ref($order) eq 'ARRAY') {
6819: @types = @{$order};
6820: }
6821: if (@types == 0) {
6822: if (ref($usertypes) eq 'HASH') {
6823: @types = sort(keys(%{$usertypes}));
6824: }
6825: }
6826: if (keys(%{$usertypes}) > 0) {
6827: $othertitle = &mt('Other users');
6828: if ($env{'request.course.id'}) {
6829: $othertitle = 'other';
6830: }
6831: }
6832: return ($othertitle,$usertypes,\@types);
6833: }
6834:
1.645 raeburn 6835: sub get_institutional_codes {
6836: my ($settings,$allcourses,$LC_code) = @_;
6837: # Get complete list of course sections to update
6838: my @currsections = ();
6839: my @currxlists = ();
6840: my $coursecode = $$settings{'internal.coursecode'};
6841:
6842: if ($$settings{'internal.sectionnums'} ne '') {
6843: @currsections = split(/,/,$$settings{'internal.sectionnums'});
6844: }
6845:
6846: if ($$settings{'internal.crosslistings'} ne '') {
6847: @currxlists = split(/,/,$$settings{'internal.crosslistings'});
6848: }
6849:
6850: if (@currxlists > 0) {
6851: foreach (@currxlists) {
6852: if (m/^([^:]+):(\w*)$/) {
6853: unless (grep/^$1$/,@{$allcourses}) {
6854: push @{$allcourses},$1;
6855: $$LC_code{$1} = $2;
6856: }
6857: }
6858: }
6859: }
6860:
6861: if (@currsections > 0) {
6862: foreach (@currsections) {
6863: if (m/^(\w+):(\w*)$/) {
6864: my $sec = $coursecode.$1;
6865: my $lc_sec = $2;
6866: unless (grep/^$sec$/,@{$allcourses}) {
6867: push @{$allcourses},$sec;
6868: $$LC_code{$sec} = $lc_sec;
6869: }
6870: }
6871: }
6872: }
6873: return;
6874: }
6875:
1.112 bowersj2 6876: =pod
6877:
1.549 albertel 6878: =back
6879:
6880: =head1 HTTP Helpers
6881:
6882: =over 4
6883:
1.648 raeburn 6884: =item * &get_unprocessed_cgi($query,$possible_names)
1.112 bowersj2 6885:
1.258 albertel 6886: Modify the %env hash to contain unprocessed CGI form parameters held in
1.112 bowersj2 6887: $query. The parameters listed in $possible_names (an array reference),
1.258 albertel 6888: will be set in $env{'form.name'} if they do not already exist.
1.112 bowersj2 6889:
6890: Typically called with $ENV{'QUERY_STRING'} as the first parameter.
6891: $possible_names is an ref to an array of form element names. As an example:
6892: get_unprocessed_cgi($ENV{'QUERY_STRING'},['uname','udom']);
1.258 albertel 6893: will result in $env{'form.uname'} and $env{'form.udom'} being set.
1.112 bowersj2 6894:
6895: =cut
1.1 albertel 6896:
1.6 albertel 6897: sub get_unprocessed_cgi {
1.25 albertel 6898: my ($query,$possible_names)= @_;
1.26 matthew 6899: # $Apache::lonxml::debug=1;
1.356 albertel 6900: foreach my $pair (split(/&/,$query)) {
6901: my ($name, $value) = split(/=/,$pair);
1.369 www 6902: $name = &unescape($name);
1.25 albertel 6903: if (!defined($possible_names) || (grep {$_ eq $name} @$possible_names)) {
6904: $value =~ tr/+/ /;
6905: $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
1.258 albertel 6906: unless (defined($env{'form.'.$name})) { &add_to_env('form.'.$name,$value) };
1.25 albertel 6907: }
1.16 harris41 6908: }
1.6 albertel 6909: }
6910:
1.112 bowersj2 6911: =pod
6912:
1.648 raeburn 6913: =item * &cacheheader()
1.112 bowersj2 6914:
6915: returns cache-controlling header code
6916:
6917: =cut
6918:
1.7 albertel 6919: sub cacheheader {
1.258 albertel 6920: unless ($env{'request.method'} eq 'GET') { return ''; }
1.216 albertel 6921: my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
6922: my $output .='<meta HTTP-EQUIV="Expires" CONTENT="'.$date.'" />
1.7 albertel 6923: <meta HTTP-EQUIV="Cache-control" CONTENT="no-cache" />
6924: <meta HTTP-EQUIV="Pragma" CONTENT="no-cache" />';
1.216 albertel 6925: return $output;
1.7 albertel 6926: }
6927:
1.112 bowersj2 6928: =pod
6929:
1.648 raeburn 6930: =item * &no_cache($r)
1.112 bowersj2 6931:
6932: specifies header code to not have cache
6933:
6934: =cut
6935:
1.9 albertel 6936: sub no_cache {
1.216 albertel 6937: my ($r) = @_;
6938: if ($ENV{'REQUEST_METHOD'} ne 'GET' &&
1.258 albertel 6939: $env{'request.method'} ne 'GET') { return ''; }
1.216 albertel 6940: my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime(time));
6941: $r->no_cache(1);
6942: $r->header_out("Expires" => $date);
6943: $r->header_out("Pragma" => "no-cache");
1.123 www 6944: }
6945:
6946: sub content_type {
1.181 albertel 6947: my ($r,$type,$charset) = @_;
1.299 foxr 6948: if ($r) {
6949: # Note that printout.pl calls this with undef for $r.
6950: &no_cache($r);
6951: }
1.258 albertel 6952: if ($env{'browser.mathml'} && $type eq 'text/html') { $type='text/xml'; }
1.181 albertel 6953: unless ($charset) {
6954: $charset=&Apache::lonlocal::current_encoding;
6955: }
6956: if ($charset) { $type.='; charset='.$charset; }
6957: if ($r) {
6958: $r->content_type($type);
6959: } else {
6960: print("Content-type: $type\n\n");
6961: }
1.9 albertel 6962: }
1.25 albertel 6963:
1.112 bowersj2 6964: =pod
6965:
1.648 raeburn 6966: =item * &add_to_env($name,$value)
1.112 bowersj2 6967:
1.258 albertel 6968: adds $name to the %env hash with value
1.112 bowersj2 6969: $value, if $name already exists, the entry is converted to an array
6970: reference and $value is added to the array.
6971:
6972: =cut
6973:
1.25 albertel 6974: sub add_to_env {
6975: my ($name,$value)=@_;
1.258 albertel 6976: if (defined($env{$name})) {
6977: if (ref($env{$name})) {
1.25 albertel 6978: #already have multiple values
1.258 albertel 6979: push(@{ $env{$name} },$value);
1.25 albertel 6980: } else {
6981: #first time seeing multiple values, convert hash entry to an arrayref
1.258 albertel 6982: my $first=$env{$name};
6983: undef($env{$name});
6984: push(@{ $env{$name} },$first,$value);
1.25 albertel 6985: }
6986: } else {
1.258 albertel 6987: $env{$name}=$value;
1.25 albertel 6988: }
1.31 albertel 6989: }
1.149 albertel 6990:
6991: =pod
6992:
1.648 raeburn 6993: =item * &get_env_multiple($name)
1.149 albertel 6994:
1.258 albertel 6995: gets $name from the %env hash, it seemlessly handles the cases where multiple
1.149 albertel 6996: values may be defined and end up as an array ref.
6997:
6998: returns an array of values
6999:
7000: =cut
7001:
7002: sub get_env_multiple {
7003: my ($name) = @_;
7004: my @values;
1.258 albertel 7005: if (defined($env{$name})) {
1.149 albertel 7006: # exists is it an array
1.258 albertel 7007: if (ref($env{$name})) {
7008: @values=@{ $env{$name} };
1.149 albertel 7009: } else {
1.258 albertel 7010: $values[0]=$env{$name};
1.149 albertel 7011: }
7012: }
7013: return(@values);
7014: }
7015:
1.31 albertel 7016:
1.41 ng 7017: =pod
1.45 matthew 7018:
1.464 albertel 7019: =back
1.41 ng 7020:
1.112 bowersj2 7021: =head1 CSV Upload/Handling functions
1.38 albertel 7022:
1.41 ng 7023: =over 4
7024:
1.648 raeburn 7025: =item * &upfile_store($r)
1.41 ng 7026:
7027: Store uploaded file, $r should be the HTTP Request object,
1.258 albertel 7028: needs $env{'form.upfile'}
1.41 ng 7029: returns $datatoken to be put into hidden field
7030:
7031: =cut
1.31 albertel 7032:
7033: sub upfile_store {
7034: my $r=shift;
1.258 albertel 7035: $env{'form.upfile'}=~s/\r/\n/gs;
7036: $env{'form.upfile'}=~s/\f/\n/gs;
7037: $env{'form.upfile'}=~s/\n+/\n/gs;
7038: $env{'form.upfile'}=~s/\n+$//gs;
1.31 albertel 7039:
1.258 albertel 7040: my $datatoken=$env{'user.name'}.'_'.$env{'user.domain'}.
7041: '_enroll_'.$env{'request.course.id'}.'_'.time.'_'.$$;
1.31 albertel 7042: {
1.158 raeburn 7043: my $datafile = $r->dir_config('lonDaemons').
7044: '/tmp/'.$datatoken.'.tmp';
7045: if ( open(my $fh,">$datafile") ) {
1.258 albertel 7046: print $fh $env{'form.upfile'};
1.158 raeburn 7047: close($fh);
7048: }
1.31 albertel 7049: }
7050: return $datatoken;
7051: }
7052:
1.56 matthew 7053: =pod
7054:
1.648 raeburn 7055: =item * &load_tmp_file($r)
1.41 ng 7056:
7057: Load uploaded file from tmp, $r should be the HTTP Request object,
1.258 albertel 7058: needs $env{'form.datatoken'},
7059: sets $env{'form.upfile'} to the contents of the file
1.41 ng 7060:
7061: =cut
1.31 albertel 7062:
7063: sub load_tmp_file {
7064: my $r=shift;
7065: my @studentdata=();
7066: {
1.158 raeburn 7067: my $studentfile = $r->dir_config('lonDaemons').
1.258 albertel 7068: '/tmp/'.$env{'form.datatoken'}.'.tmp';
1.158 raeburn 7069: if ( open(my $fh,"<$studentfile") ) {
7070: @studentdata=<$fh>;
7071: close($fh);
7072: }
1.31 albertel 7073: }
1.258 albertel 7074: $env{'form.upfile'}=join('',@studentdata);
1.31 albertel 7075: }
7076:
1.56 matthew 7077: =pod
7078:
1.648 raeburn 7079: =item * &upfile_record_sep()
1.41 ng 7080:
7081: Separate uploaded file into records
7082: returns array of records,
1.258 albertel 7083: needs $env{'form.upfile'} and $env{'form.upfiletype'}
1.41 ng 7084:
7085: =cut
1.31 albertel 7086:
7087: sub upfile_record_sep {
1.258 albertel 7088: if ($env{'form.upfiletype'} eq 'xml') {
1.31 albertel 7089: } else {
1.248 albertel 7090: my @records;
1.258 albertel 7091: foreach my $line (split(/\n/,$env{'form.upfile'})) {
1.248 albertel 7092: if ($line=~/^\s*$/) { next; }
7093: push(@records,$line);
7094: }
7095: return @records;
1.31 albertel 7096: }
7097: }
7098:
1.56 matthew 7099: =pod
7100:
1.648 raeburn 7101: =item * &record_sep($record)
1.41 ng 7102:
1.258 albertel 7103: Separate a record into fields $record should be an item from the upfile_record_sep(), needs $env{'form.upfiletype'}
1.41 ng 7104:
7105: =cut
7106:
1.263 www 7107: sub takeleft {
7108: my $index=shift;
7109: return substr('0000'.$index,-4,4);
7110: }
7111:
1.31 albertel 7112: sub record_sep {
7113: my $record=shift;
7114: my %components=();
1.258 albertel 7115: if ($env{'form.upfiletype'} eq 'xml') {
7116: } elsif ($env{'form.upfiletype'} eq 'space') {
1.31 albertel 7117: my $i=0;
1.356 albertel 7118: foreach my $field (split(/\s+/,$record)) {
1.31 albertel 7119: $field=~s/^(\"|\')//;
7120: $field=~s/(\"|\')$//;
1.263 www 7121: $components{&takeleft($i)}=$field;
1.31 albertel 7122: $i++;
7123: }
1.258 albertel 7124: } elsif ($env{'form.upfiletype'} eq 'tab') {
1.31 albertel 7125: my $i=0;
1.356 albertel 7126: foreach my $field (split(/\t/,$record)) {
1.31 albertel 7127: $field=~s/^(\"|\')//;
7128: $field=~s/(\"|\')$//;
1.263 www 7129: $components{&takeleft($i)}=$field;
1.31 albertel 7130: $i++;
7131: }
7132: } else {
1.561 www 7133: my $separator=',';
1.480 banghart 7134: if ($env{'form.upfiletype'} eq 'semisv') {
1.561 www 7135: $separator=';';
1.480 banghart 7136: }
1.31 albertel 7137: my $i=0;
1.561 www 7138: # the character we are looking for to indicate the end of a quote or a record
7139: my $looking_for=$separator;
7140: # do not add the characters to the fields
7141: my $ignore=0;
7142: # we just encountered a separator (or the beginning of the record)
7143: my $just_found_separator=1;
7144: # store the field we are working on here
7145: my $field='';
7146: # work our way through all characters in record
7147: foreach my $character ($record=~/(.)/g) {
7148: if ($character eq $looking_for) {
7149: if ($character ne $separator) {
7150: # Found the end of a quote, again looking for separator
7151: $looking_for=$separator;
7152: $ignore=1;
7153: } else {
7154: # Found a separator, store away what we got
7155: $components{&takeleft($i)}=$field;
7156: $i++;
7157: $just_found_separator=1;
7158: $ignore=0;
7159: $field='';
7160: }
7161: next;
7162: }
7163: # single or double quotation marks after a separator indicate beginning of a quote
7164: # we are now looking for the end of the quote and need to ignore separators
7165: if ((($character eq '"') || ($character eq "'")) && ($just_found_separator)) {
7166: $looking_for=$character;
7167: next;
7168: }
7169: # ignore would be true after we reached the end of a quote
7170: if ($ignore) { next; }
7171: if (($just_found_separator) && ($character=~/\s/)) { next; }
7172: $field.=$character;
7173: $just_found_separator=0;
1.31 albertel 7174: }
1.561 www 7175: # catch the very last entry, since we never encountered the separator
7176: $components{&takeleft($i)}=$field;
1.31 albertel 7177: }
7178: return %components;
7179: }
7180:
1.144 matthew 7181: ######################################################
7182: ######################################################
7183:
1.56 matthew 7184: =pod
7185:
1.648 raeburn 7186: =item * &upfile_select_html()
1.41 ng 7187:
1.144 matthew 7188: Return HTML code to select a file from the users machine and specify
7189: the file type.
1.41 ng 7190:
7191: =cut
7192:
1.144 matthew 7193: ######################################################
7194: ######################################################
1.31 albertel 7195: sub upfile_select_html {
1.144 matthew 7196: my %Types = (
7197: csv => &mt('CSV (comma separated values, spreadsheet)'),
1.480 banghart 7198: semisv => &mt('Semicolon separated values'),
1.144 matthew 7199: space => &mt('Space separated'),
7200: tab => &mt('Tabulator separated'),
7201: # xml => &mt('HTML/XML'),
7202: );
7203: my $Str = '<input type="file" name="upfile" size="50" />'.
7204: '<br />Type: <select name="upfiletype">';
7205: foreach my $type (sort(keys(%Types))) {
7206: $Str .= '<option value="'.$type.'" >'.$Types{$type}."</option>\n";
7207: }
7208: $Str .= "</select>\n";
7209: return $Str;
1.31 albertel 7210: }
7211:
1.301 albertel 7212: sub get_samples {
7213: my ($records,$toget) = @_;
7214: my @samples=({});
7215: my $got=0;
7216: foreach my $rec (@$records) {
7217: my %temp = &record_sep($rec);
7218: if (! grep(/\S/, values(%temp))) { next; }
7219: if (%temp) {
7220: $samples[$got]=\%temp;
7221: $got++;
7222: if ($got == $toget) { last; }
7223: }
7224: }
7225: return \@samples;
7226: }
7227:
1.144 matthew 7228: ######################################################
7229: ######################################################
7230:
1.56 matthew 7231: =pod
7232:
1.648 raeburn 7233: =item * &csv_print_samples($r,$records)
1.41 ng 7234:
7235: Prints a table of sample values from each column uploaded $r is an
7236: Apache Request ref, $records is an arrayref from
7237: &Apache::loncommon::upfile_record_sep
7238:
7239: =cut
7240:
1.144 matthew 7241: ######################################################
7242: ######################################################
1.31 albertel 7243: sub csv_print_samples {
7244: my ($r,$records) = @_;
1.301 albertel 7245: my $samples = &get_samples($records,3);
7246:
1.594 raeburn 7247: $r->print(&mt('Samples').'<br />'.&start_data_table().
7248: &start_data_table_header_row());
1.356 albertel 7249: foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
7250: $r->print('<th>'.&mt('Column [_1]',($sample+1)).'</th>'); }
1.594 raeburn 7251: $r->print(&end_data_table_header_row());
1.301 albertel 7252: foreach my $hash (@$samples) {
1.594 raeburn 7253: $r->print(&start_data_table_row());
1.356 albertel 7254: foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
1.31 albertel 7255: $r->print('<td>');
1.356 albertel 7256: if (defined($$hash{$sample})) { $r->print($$hash{$sample}); }
1.31 albertel 7257: $r->print('</td>');
7258: }
1.594 raeburn 7259: $r->print(&end_data_table_row());
1.31 albertel 7260: }
1.594 raeburn 7261: $r->print(&end_data_table().'<br />'."\n");
1.31 albertel 7262: }
7263:
1.144 matthew 7264: ######################################################
7265: ######################################################
7266:
1.56 matthew 7267: =pod
7268:
1.648 raeburn 7269: =item * &csv_print_select_table($r,$records,$d)
1.41 ng 7270:
7271: Prints a table to create associations between values and table columns.
1.144 matthew 7272:
1.41 ng 7273: $r is an Apache Request ref,
7274: $records is an arrayref from &Apache::loncommon::upfile_record_sep,
1.174 matthew 7275: $d is an array of 2 element arrays (internal name, displayed name,defaultcol)
1.41 ng 7276:
7277: =cut
7278:
1.144 matthew 7279: ######################################################
7280: ######################################################
1.31 albertel 7281: sub csv_print_select_table {
7282: my ($r,$records,$d) = @_;
1.301 albertel 7283: my $i=0;
7284: my $samples = &get_samples($records,1);
1.144 matthew 7285: $r->print(&mt('Associate columns with student attributes.')."\n".
1.594 raeburn 7286: &start_data_table().&start_data_table_header_row().
1.144 matthew 7287: '<th>'.&mt('Attribute').'</th>'.
1.594 raeburn 7288: '<th>'.&mt('Column').'</th>'.
7289: &end_data_table_header_row()."\n");
1.356 albertel 7290: foreach my $array_ref (@$d) {
7291: my ($value,$display,$defaultcol)=@{ $array_ref };
1.594 raeburn 7292: $r->print(&start_data_table_row().'<tr><td>'.$display.'</td>');
1.31 albertel 7293:
7294: $r->print('<td><select name=f'.$i.
1.32 matthew 7295: ' onchange="javascript:flip(this.form,'.$i.');">');
1.31 albertel 7296: $r->print('<option value="none"></option>');
1.356 albertel 7297: foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
7298: $r->print('<option value="'.$sample.'"'.
7299: ($sample eq $defaultcol ? ' selected="selected" ' : '').
7300: '>Column '.($sample+1).'</option>');
1.31 albertel 7301: }
1.594 raeburn 7302: $r->print('</select></td>'.&end_data_table_row()."\n");
1.31 albertel 7303: $i++;
7304: }
1.594 raeburn 7305: $r->print(&end_data_table());
1.31 albertel 7306: $i--;
7307: return $i;
7308: }
1.56 matthew 7309:
1.144 matthew 7310: ######################################################
7311: ######################################################
7312:
1.56 matthew 7313: =pod
1.31 albertel 7314:
1.648 raeburn 7315: =item * &csv_samples_select_table($r,$records,$d)
1.41 ng 7316:
7317: Prints a table of sample values from the upload and can make associate samples to internal names.
7318:
7319: $r is an Apache Request ref,
7320: $records is an arrayref from &Apache::loncommon::upfile_record_sep,
7321: $d is an array of 2 element arrays (internal name, displayed name)
7322:
7323: =cut
7324:
1.144 matthew 7325: ######################################################
7326: ######################################################
1.31 albertel 7327: sub csv_samples_select_table {
7328: my ($r,$records,$d) = @_;
7329: my $i=0;
1.144 matthew 7330: #
1.301 albertel 7331: my $samples = &get_samples($records,3);
1.594 raeburn 7332: $r->print(&start_data_table().
7333: &start_data_table_header_row().'<th>'.
7334: &mt('Field').'</th><th>'.&mt('Samples').'</th>'.
7335: &end_data_table_header_row());
1.301 albertel 7336:
7337: foreach my $key (sort(keys(%{ $samples->[0] }))) {
1.594 raeburn 7338: $r->print(&start_data_table_row().'<td><select name="f'.$i.'"'.
1.32 matthew 7339: ' onchange="javascript:flip(this.form,'.$i.');">');
1.301 albertel 7340: foreach my $option (@$d) {
7341: my ($value,$display,$defaultcol)=@{ $option };
1.174 matthew 7342: $r->print('<option value="'.$value.'"'.
1.253 albertel 7343: ($i eq $defaultcol ? ' selected="selected" ':'').'>'.
1.174 matthew 7344: $display.'</option>');
1.31 albertel 7345: }
7346: $r->print('</select></td><td>');
1.301 albertel 7347: foreach my $line (0..2) {
7348: if (defined($samples->[$line]{$key})) {
7349: $r->print($samples->[$line]{$key}."<br />\n");
7350: }
7351: }
1.594 raeburn 7352: $r->print('</td>'.&end_data_table_row());
1.31 albertel 7353: $i++;
7354: }
1.594 raeburn 7355: $r->print(&end_data_table());
1.31 albertel 7356: $i--;
7357: return($i);
1.115 matthew 7358: }
7359:
1.144 matthew 7360: ######################################################
7361: ######################################################
7362:
1.115 matthew 7363: =pod
7364:
1.648 raeburn 7365: =item * &clean_excel_name($name)
1.115 matthew 7366:
7367: Returns a replacement for $name which does not contain any illegal characters.
7368:
7369: =cut
7370:
1.144 matthew 7371: ######################################################
7372: ######################################################
1.115 matthew 7373: sub clean_excel_name {
7374: my ($name) = @_;
7375: $name =~ s/[:\*\?\/\\]//g;
7376: if (length($name) > 31) {
7377: $name = substr($name,0,31);
7378: }
7379: return $name;
1.25 albertel 7380: }
1.84 albertel 7381:
1.85 albertel 7382: =pod
7383:
1.648 raeburn 7384: =item * &check_if_partid_hidden($id,$symb,$udom,$uname)
1.85 albertel 7385:
7386: Returns either 1 or undef
7387:
7388: 1 if the part is to be hidden, undef if it is to be shown
7389:
7390: Arguments are:
7391:
7392: $id the id of the part to be checked
7393: $symb, optional the symb of the resource to check
7394: $udom, optional the domain of the user to check for
7395: $uname, optional the username of the user to check for
7396:
7397: =cut
1.84 albertel 7398:
7399: sub check_if_partid_hidden {
7400: my ($id,$symb,$udom,$uname) = @_;
1.133 albertel 7401: my $hiddenparts=&Apache::lonnet::EXT('resource.0.hiddenparts',
1.84 albertel 7402: $symb,$udom,$uname);
1.141 albertel 7403: my $truth=1;
7404: #if the string starts with !, then the list is the list to show not hide
7405: if ($hiddenparts=~s/^\s*!//) { $truth=undef; }
1.84 albertel 7406: my @hiddenlist=split(/,/,$hiddenparts);
7407: foreach my $checkid (@hiddenlist) {
1.141 albertel 7408: if ($checkid =~ /^\s*\Q$id\E\s*$/) { return $truth; }
1.84 albertel 7409: }
1.141 albertel 7410: return !$truth;
1.84 albertel 7411: }
1.127 matthew 7412:
1.138 matthew 7413:
7414: ############################################################
7415: ############################################################
7416:
7417: =pod
7418:
1.157 matthew 7419: =back
7420:
1.138 matthew 7421: =head1 cgi-bin script and graphing routines
7422:
1.157 matthew 7423: =over 4
7424:
1.648 raeburn 7425: =item * &get_cgi_id()
1.138 matthew 7426:
7427: Inputs: none
7428:
7429: Returns an id which can be used to pass environment variables
7430: to various cgi-bin scripts. These environment variables will
7431: be removed from the users environment after a given time by
7432: the routine &Apache::lonnet::transfer_profile_to_env.
7433:
7434: =cut
7435:
7436: ############################################################
7437: ############################################################
1.152 albertel 7438: my $uniq=0;
1.136 matthew 7439: sub get_cgi_id {
1.154 albertel 7440: $uniq=($uniq+1)%100000;
1.280 albertel 7441: return (time.'_'.$$.'_'.$uniq);
1.136 matthew 7442: }
7443:
1.127 matthew 7444: ############################################################
7445: ############################################################
7446:
7447: =pod
7448:
1.648 raeburn 7449: =item * &DrawBarGraph()
1.127 matthew 7450:
1.138 matthew 7451: Facilitates the plotting of data in a (stacked) bar graph.
7452: Puts plot definition data into the users environment in order for
7453: graph.png to plot it. Returns an <img> tag for the plot.
7454: The bars on the plot are labeled '1','2',...,'n'.
7455:
7456: Inputs:
7457:
7458: =over 4
7459:
7460: =item $Title: string, the title of the plot
7461:
7462: =item $xlabel: string, text describing the X-axis of the plot
7463:
7464: =item $ylabel: string, text describing the Y-axis of the plot
7465:
7466: =item $Max: scalar, the maximum Y value to use in the plot
7467: If $Max is < any data point, the graph will not be rendered.
7468:
1.140 matthew 7469: =item $colors: array ref holding the colors to be used for the data sets when
1.138 matthew 7470: they are plotted. If undefined, default values will be used.
7471:
1.178 matthew 7472: =item $labels: array ref holding the labels to use on the x-axis for the bars.
7473:
1.138 matthew 7474: =item @Values: An array of array references. Each array reference holds data
7475: to be plotted in a stacked bar chart.
7476:
1.239 matthew 7477: =item If the final element of @Values is a hash reference the key/value
7478: pairs will be added to the graph definition.
7479:
1.138 matthew 7480: =back
7481:
7482: Returns:
7483:
7484: An <img> tag which references graph.png and the appropriate identifying
7485: information for the plot.
7486:
1.127 matthew 7487: =cut
7488:
7489: ############################################################
7490: ############################################################
1.134 matthew 7491: sub DrawBarGraph {
1.178 matthew 7492: my ($Title,$xlabel,$ylabel,$Max,$colors,$labels,@Values)=@_;
1.134 matthew 7493: #
7494: if (! defined($colors)) {
7495: $colors = ['#33ff00',
7496: '#0033cc', '#990000', '#aaaa66', '#663399', '#ff9933',
7497: '#66ccff', '#ff9999', '#cccc33', '#660000', '#33cc66',
7498: ];
7499: }
1.228 matthew 7500: my $extra_settings = {};
7501: if (ref($Values[-1]) eq 'HASH') {
7502: $extra_settings = pop(@Values);
7503: }
1.127 matthew 7504: #
1.136 matthew 7505: my $identifier = &get_cgi_id();
7506: my $id = 'cgi.'.$identifier;
1.129 matthew 7507: if (! @Values || ref($Values[0]) ne 'ARRAY') {
1.127 matthew 7508: return '';
7509: }
1.225 matthew 7510: #
7511: my @Labels;
7512: if (defined($labels)) {
7513: @Labels = @$labels;
7514: } else {
7515: for (my $i=0;$i<@{$Values[0]};$i++) {
7516: push (@Labels,$i+1);
7517: }
7518: }
7519: #
1.129 matthew 7520: my $NumBars = scalar(@{$Values[0]});
1.225 matthew 7521: if ($NumBars < scalar(@Labels)) { $NumBars = scalar(@Labels); }
1.129 matthew 7522: my %ValuesHash;
7523: my $NumSets=1;
7524: foreach my $array (@Values) {
7525: next if (! ref($array));
1.136 matthew 7526: $ValuesHash{$id.'.data.'.$NumSets++} =
1.132 matthew 7527: join(',',@$array);
1.129 matthew 7528: }
1.127 matthew 7529: #
1.136 matthew 7530: my ($height,$width,$xskip,$bar_width) = (200,120,1,15);
1.225 matthew 7531: if ($NumBars < 3) {
7532: $width = 120+$NumBars*32;
1.220 matthew 7533: $xskip = 1;
1.225 matthew 7534: $bar_width = 30;
7535: } elsif ($NumBars < 5) {
7536: $width = 120+$NumBars*20;
7537: $xskip = 1;
7538: $bar_width = 20;
1.220 matthew 7539: } elsif ($NumBars < 10) {
1.136 matthew 7540: $width = 120+$NumBars*15;
7541: $xskip = 1;
7542: $bar_width = 15;
7543: } elsif ($NumBars <= 25) {
7544: $width = 120+$NumBars*11;
7545: $xskip = 5;
7546: $bar_width = 8;
7547: } elsif ($NumBars <= 50) {
7548: $width = 120+$NumBars*8;
7549: $xskip = 5;
7550: $bar_width = 4;
7551: } else {
7552: $width = 120+$NumBars*8;
7553: $xskip = 5;
7554: $bar_width = 4;
7555: }
7556: #
1.137 matthew 7557: $Max = 1 if ($Max < 1);
7558: if ( int($Max) < $Max ) {
7559: $Max++;
7560: $Max = int($Max);
7561: }
1.127 matthew 7562: $Title = '' if (! defined($Title));
7563: $xlabel = '' if (! defined($xlabel));
7564: $ylabel = '' if (! defined($ylabel));
1.369 www 7565: $ValuesHash{$id.'.title'} = &escape($Title);
7566: $ValuesHash{$id.'.xlabel'} = &escape($xlabel);
7567: $ValuesHash{$id.'.ylabel'} = &escape($ylabel);
1.137 matthew 7568: $ValuesHash{$id.'.y_max_value'} = $Max;
1.136 matthew 7569: $ValuesHash{$id.'.NumBars'} = $NumBars;
7570: $ValuesHash{$id.'.NumSets'} = $NumSets;
7571: $ValuesHash{$id.'.PlotType'} = 'bar';
7572: $ValuesHash{$id.'.Colors'} = join(',',@{$colors});
7573: $ValuesHash{$id.'.height'} = $height;
7574: $ValuesHash{$id.'.width'} = $width;
7575: $ValuesHash{$id.'.xskip'} = $xskip;
7576: $ValuesHash{$id.'.bar_width'} = $bar_width;
7577: $ValuesHash{$id.'.labels'} = join(',',@Labels);
1.127 matthew 7578: #
1.228 matthew 7579: # Deal with other parameters
7580: while (my ($key,$value) = each(%$extra_settings)) {
7581: $ValuesHash{$id.'.'.$key} = $value;
7582: }
7583: #
1.646 raeburn 7584: &Apache::lonnet::appenv(\%ValuesHash);
1.137 matthew 7585: return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';
7586: }
7587:
7588: ############################################################
7589: ############################################################
7590:
7591: =pod
7592:
1.648 raeburn 7593: =item * &DrawXYGraph()
1.137 matthew 7594:
1.138 matthew 7595: Facilitates the plotting of data in an XY graph.
7596: Puts plot definition data into the users environment in order for
7597: graph.png to plot it. Returns an <img> tag for the plot.
7598:
7599: Inputs:
7600:
7601: =over 4
7602:
7603: =item $Title: string, the title of the plot
7604:
7605: =item $xlabel: string, text describing the X-axis of the plot
7606:
7607: =item $ylabel: string, text describing the Y-axis of the plot
7608:
7609: =item $Max: scalar, the maximum Y value to use in the plot
7610: If $Max is < any data point, the graph will not be rendered.
7611:
7612: =item $colors: Array ref containing the hex color codes for the data to be
7613: plotted in. If undefined, default values will be used.
7614:
7615: =item $Xlabels: Array ref containing the labels to be used for the X-axis.
7616:
7617: =item $Ydata: Array ref containing Array refs.
1.185 www 7618: Each of the contained arrays will be plotted as a separate curve.
1.138 matthew 7619:
7620: =item %Values: hash indicating or overriding any default values which are
7621: passed to graph.png.
7622: Possible values are: width, xskip, x_ticks, x_tick_offset, among others.
7623:
7624: =back
7625:
7626: Returns:
7627:
7628: An <img> tag which references graph.png and the appropriate identifying
7629: information for the plot.
7630:
1.137 matthew 7631: =cut
7632:
7633: ############################################################
7634: ############################################################
7635: sub DrawXYGraph {
7636: my ($Title,$xlabel,$ylabel,$Max,$colors,$Xlabels,$Ydata,%Values)=@_;
7637: #
7638: # Create the identifier for the graph
7639: my $identifier = &get_cgi_id();
7640: my $id = 'cgi.'.$identifier;
7641: #
7642: $Title = '' if (! defined($Title));
7643: $xlabel = '' if (! defined($xlabel));
7644: $ylabel = '' if (! defined($ylabel));
7645: my %ValuesHash =
7646: (
1.369 www 7647: $id.'.title' => &escape($Title),
7648: $id.'.xlabel' => &escape($xlabel),
7649: $id.'.ylabel' => &escape($ylabel),
1.137 matthew 7650: $id.'.y_max_value'=> $Max,
7651: $id.'.labels' => join(',',@$Xlabels),
7652: $id.'.PlotType' => 'XY',
7653: );
7654: #
7655: if (defined($colors) && ref($colors) eq 'ARRAY') {
7656: $ValuesHash{$id.'.Colors'} = join(',',@{$colors});
7657: }
7658: #
7659: if (! ref($Ydata) || ref($Ydata) ne 'ARRAY') {
7660: return '';
7661: }
7662: my $NumSets=1;
1.138 matthew 7663: foreach my $array (@{$Ydata}){
1.137 matthew 7664: next if (! ref($array));
7665: $ValuesHash{$id.'.data.'.$NumSets++} = join(',',@$array);
7666: }
1.138 matthew 7667: $ValuesHash{$id.'.NumSets'} = $NumSets-1;
1.137 matthew 7668: #
7669: # Deal with other parameters
7670: while (my ($key,$value) = each(%Values)) {
7671: $ValuesHash{$id.'.'.$key} = $value;
1.127 matthew 7672: }
7673: #
1.646 raeburn 7674: &Apache::lonnet::appenv(\%ValuesHash);
1.136 matthew 7675: return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';
7676: }
7677:
7678: ############################################################
7679: ############################################################
7680:
7681: =pod
7682:
1.648 raeburn 7683: =item * &DrawXYYGraph()
1.138 matthew 7684:
7685: Facilitates the plotting of data in an XY graph with two Y axes.
7686: Puts plot definition data into the users environment in order for
7687: graph.png to plot it. Returns an <img> tag for the plot.
7688:
7689: Inputs:
7690:
7691: =over 4
7692:
7693: =item $Title: string, the title of the plot
7694:
7695: =item $xlabel: string, text describing the X-axis of the plot
7696:
7697: =item $ylabel: string, text describing the Y-axis of the plot
7698:
7699: =item $colors: Array ref containing the hex color codes for the data to be
7700: plotted in. If undefined, default values will be used.
7701:
7702: =item $Xlabels: Array ref containing the labels to be used for the X-axis.
7703:
7704: =item $Ydata1: The first data set
7705:
7706: =item $Min1: The minimum value of the left Y-axis
7707:
7708: =item $Max1: The maximum value of the left Y-axis
7709:
7710: =item $Ydata2: The second data set
7711:
7712: =item $Min2: The minimum value of the right Y-axis
7713:
7714: =item $Max2: The maximum value of the left Y-axis
7715:
7716: =item %Values: hash indicating or overriding any default values which are
7717: passed to graph.png.
7718: Possible values are: width, xskip, x_ticks, x_tick_offset, among others.
7719:
7720: =back
7721:
7722: Returns:
7723:
7724: An <img> tag which references graph.png and the appropriate identifying
7725: information for the plot.
1.136 matthew 7726:
7727: =cut
7728:
7729: ############################################################
7730: ############################################################
1.137 matthew 7731: sub DrawXYYGraph {
7732: my ($Title,$xlabel,$ylabel,$colors,$Xlabels,$Ydata1,$Min1,$Max1,
7733: $Ydata2,$Min2,$Max2,%Values)=@_;
1.136 matthew 7734: #
7735: # Create the identifier for the graph
7736: my $identifier = &get_cgi_id();
7737: my $id = 'cgi.'.$identifier;
7738: #
7739: $Title = '' if (! defined($Title));
7740: $xlabel = '' if (! defined($xlabel));
7741: $ylabel = '' if (! defined($ylabel));
7742: my %ValuesHash =
7743: (
1.369 www 7744: $id.'.title' => &escape($Title),
7745: $id.'.xlabel' => &escape($xlabel),
7746: $id.'.ylabel' => &escape($ylabel),
1.136 matthew 7747: $id.'.labels' => join(',',@$Xlabels),
7748: $id.'.PlotType' => 'XY',
7749: $id.'.NumSets' => 2,
1.137 matthew 7750: $id.'.two_axes' => 1,
7751: $id.'.y1_max_value' => $Max1,
7752: $id.'.y1_min_value' => $Min1,
7753: $id.'.y2_max_value' => $Max2,
7754: $id.'.y2_min_value' => $Min2,
1.136 matthew 7755: );
7756: #
1.137 matthew 7757: if (defined($colors) && ref($colors) eq 'ARRAY') {
7758: $ValuesHash{$id.'.Colors'} = join(',',@{$colors});
7759: }
7760: #
7761: if (! ref($Ydata1) || ref($Ydata1) ne 'ARRAY' ||
7762: ! ref($Ydata2) || ref($Ydata2) ne 'ARRAY'){
1.136 matthew 7763: return '';
7764: }
7765: my $NumSets=1;
1.137 matthew 7766: foreach my $array ($Ydata1,$Ydata2){
1.136 matthew 7767: next if (! ref($array));
7768: $ValuesHash{$id.'.data.'.$NumSets++} = join(',',@$array);
1.137 matthew 7769: }
7770: #
7771: # Deal with other parameters
7772: while (my ($key,$value) = each(%Values)) {
7773: $ValuesHash{$id.'.'.$key} = $value;
1.136 matthew 7774: }
7775: #
1.646 raeburn 7776: &Apache::lonnet::appenv(\%ValuesHash);
1.130 albertel 7777: return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';
1.139 matthew 7778: }
7779:
7780: ############################################################
7781: ############################################################
7782:
7783: =pod
7784:
1.157 matthew 7785: =back
7786:
1.139 matthew 7787: =head1 Statistics helper routines?
7788:
7789: Bad place for them but what the hell.
7790:
1.157 matthew 7791: =over 4
7792:
1.648 raeburn 7793: =item * &chartlink()
1.139 matthew 7794:
7795: Returns a link to the chart for a specific student.
7796:
7797: Inputs:
7798:
7799: =over 4
7800:
7801: =item $linktext: The text of the link
7802:
7803: =item $sname: The students username
7804:
7805: =item $sdomain: The students domain
7806:
7807: =back
7808:
1.157 matthew 7809: =back
7810:
1.139 matthew 7811: =cut
7812:
7813: ############################################################
7814: ############################################################
7815: sub chartlink {
7816: my ($linktext, $sname, $sdomain) = @_;
7817: my $link = '<a href="/adm/statistics?reportSelected=student_assessment'.
1.369 www 7818: '&SelectedStudent='.&escape($sname.':'.$sdomain).
1.219 albertel 7819: '&chartoutputmode='.HTML::Entities::encode('html, with all links').
1.139 matthew 7820: '">'.$linktext.'</a>';
1.153 matthew 7821: }
7822:
7823: #######################################################
7824: #######################################################
7825:
7826: =pod
7827:
7828: =head1 Course Environment Routines
1.157 matthew 7829:
7830: =over 4
1.153 matthew 7831:
1.648 raeburn 7832: =item * &restore_course_settings()
1.153 matthew 7833:
1.648 raeburn 7834: =item * &store_course_settings()
1.153 matthew 7835:
7836: Restores/Store indicated form parameters from the course environment.
7837: Will not overwrite existing values of the form parameters.
7838:
7839: Inputs:
7840: a scalar describing the data (e.g. 'chart', 'problem_analysis')
7841:
7842: a hash ref describing the data to be stored. For example:
7843:
7844: %Save_Parameters = ('Status' => 'scalar',
7845: 'chartoutputmode' => 'scalar',
7846: 'chartoutputdata' => 'scalar',
7847: 'Section' => 'array',
1.373 raeburn 7848: 'Group' => 'array',
1.153 matthew 7849: 'StudentData' => 'array',
7850: 'Maps' => 'array');
7851:
7852: Returns: both routines return nothing
7853:
1.631 raeburn 7854: =back
7855:
1.153 matthew 7856: =cut
7857:
7858: #######################################################
7859: #######################################################
7860: sub store_course_settings {
1.496 albertel 7861: return &store_settings($env{'request.course.id'},@_);
7862: }
7863:
7864: sub store_settings {
1.153 matthew 7865: # save to the environment
7866: # appenv the same items, just to be safe
1.300 albertel 7867: my $udom = $env{'user.domain'};
7868: my $uname = $env{'user.name'};
1.496 albertel 7869: my ($context,$prefix,$Settings) = @_;
1.153 matthew 7870: my %SaveHash;
7871: my %AppHash;
7872: while (my ($setting,$type) = each(%$Settings)) {
1.496 albertel 7873: my $basename = join('.','internal',$context,$prefix,$setting);
1.300 albertel 7874: my $envname = 'environment.'.$basename;
1.258 albertel 7875: if (exists($env{'form.'.$setting})) {
1.153 matthew 7876: # Save this value away
7877: if ($type eq 'scalar' &&
1.258 albertel 7878: (! exists($env{$envname}) ||
7879: $env{$envname} ne $env{'form.'.$setting})) {
7880: $SaveHash{$basename} = $env{'form.'.$setting};
7881: $AppHash{$envname} = $env{'form.'.$setting};
1.153 matthew 7882: } elsif ($type eq 'array') {
7883: my $stored_form;
1.258 albertel 7884: if (ref($env{'form.'.$setting})) {
1.153 matthew 7885: $stored_form = join(',',
7886: map {
1.369 www 7887: &escape($_);
1.258 albertel 7888: } sort(@{$env{'form.'.$setting}}));
1.153 matthew 7889: } else {
7890: $stored_form =
1.369 www 7891: &escape($env{'form.'.$setting});
1.153 matthew 7892: }
7893: # Determine if the array contents are the same.
1.258 albertel 7894: if ($stored_form ne $env{$envname}) {
1.153 matthew 7895: $SaveHash{$basename} = $stored_form;
7896: $AppHash{$envname} = $stored_form;
7897: }
7898: }
7899: }
7900: }
7901: my $put_result = &Apache::lonnet::put('environment',\%SaveHash,
1.300 albertel 7902: $udom,$uname);
1.153 matthew 7903: if ($put_result !~ /^(ok|delayed)/) {
7904: &Apache::lonnet::logthis('unable to save form parameters, '.
7905: 'got error:'.$put_result);
7906: }
7907: # Make sure these settings stick around in this session, too
1.646 raeburn 7908: &Apache::lonnet::appenv(\%AppHash);
1.153 matthew 7909: return;
7910: }
7911:
7912: sub restore_course_settings {
1.499 albertel 7913: return &restore_settings($env{'request.course.id'},@_);
1.496 albertel 7914: }
7915:
7916: sub restore_settings {
7917: my ($context,$prefix,$Settings) = @_;
1.153 matthew 7918: while (my ($setting,$type) = each(%$Settings)) {
1.258 albertel 7919: next if (exists($env{'form.'.$setting}));
1.496 albertel 7920: my $envname = 'environment.internal.'.$context.'.'.$prefix.
1.153 matthew 7921: '.'.$setting;
1.258 albertel 7922: if (exists($env{$envname})) {
1.153 matthew 7923: if ($type eq 'scalar') {
1.258 albertel 7924: $env{'form.'.$setting} = $env{$envname};
1.153 matthew 7925: } elsif ($type eq 'array') {
1.258 albertel 7926: $env{'form.'.$setting} = [
1.153 matthew 7927: map {
1.369 www 7928: &unescape($_);
1.258 albertel 7929: } split(',',$env{$envname})
1.153 matthew 7930: ];
7931: }
7932: }
7933: }
1.127 matthew 7934: }
7935:
1.618 raeburn 7936: #######################################################
7937: #######################################################
7938:
7939: =pod
7940:
7941: =head1 Domain E-mail Routines
7942:
7943: =over 4
7944:
1.648 raeburn 7945: =item * &build_recipient_list()
1.618 raeburn 7946:
7947: Build recipient lists for three types of e-mail:
7948: (a) Error Reports, (b) Package Updates, (c) Help requests, generated by
1.619 raeburn 7949: lonerrorhandler.pm, CHECKRPMS and lonsupportreq.pm respectively.
1.618 raeburn 7950:
7951: Inputs:
1.619 raeburn 7952: defmail (scalar - email address of default recipient),
1.618 raeburn 7953: mailing type (scalar - errormail, packagesmail, or helpdeskmail),
1.619 raeburn 7954: defdom (domain for which to retrieve configuration settings),
7955: origmail (scalar - email address of recipient from loncapa.conf,
7956: i.e., predates configuration by DC via domainprefs.pm
1.618 raeburn 7957:
1.655 ! raeburn 7958: Returns: comma separated list of addresses to which to send e-mail.
! 7959:
! 7960: =back
1.618 raeburn 7961:
7962: =cut
7963:
7964: ############################################################
7965: ############################################################
7966: sub build_recipient_list {
1.619 raeburn 7967: my ($defmail,$mailing,$defdom,$origmail) = @_;
1.618 raeburn 7968: my @recipients;
7969: my $otheremails;
7970: my %domconfig =
7971: &Apache::lonnet::get_dom('configuration',['contacts'],$defdom);
7972: if (ref($domconfig{'contacts'}) eq 'HASH') {
7973: if (ref($domconfig{'contacts'}{$mailing}) eq 'HASH') {
7974: my @contacts = ('adminemail','supportemail');
7975: foreach my $item (@contacts) {
7976: if ($domconfig{'contacts'}{$mailing}{$item}) {
1.619 raeburn 7977: my $addr = $domconfig{'contacts'}{$item};
7978: if (!grep(/^\Q$addr\E$/,@recipients)) {
7979: push(@recipients,$addr);
7980: }
1.618 raeburn 7981: }
7982: $otheremails = $domconfig{'contacts'}{$mailing}{'others'};
7983: }
7984: }
1.619 raeburn 7985: } elsif ($origmail ne '') {
7986: push(@recipients,$origmail);
1.618 raeburn 7987: }
7988: if ($defmail ne '') {
7989: push(@recipients,$defmail);
7990: }
7991: if ($otheremails) {
1.619 raeburn 7992: my @others;
7993: if ($otheremails =~ /,/) {
7994: @others = split(/,/,$otheremails);
1.618 raeburn 7995: } else {
1.619 raeburn 7996: push(@others,$otheremails);
7997: }
7998: foreach my $addr (@others) {
7999: if (!grep(/^\Q$addr\E$/,@recipients)) {
8000: push(@recipients,$addr);
8001: }
1.618 raeburn 8002: }
8003: }
1.619 raeburn 8004: my $recipientlist = join(',',@recipients);
1.618 raeburn 8005: return $recipientlist;
8006: }
8007:
1.127 matthew 8008: ############################################################
8009: ############################################################
1.154 albertel 8010:
1.655 ! raeburn 8011: =pod
! 8012:
! 8013: =head1 Course Catalog Routines
! 8014:
! 8015: =over 4
! 8016:
! 8017: =item * &gather_categories()
! 8018:
! 8019: Converts category definitions - keys of categories hash stored in
! 8020: coursecategories in configuration.db on the primary library server in a
! 8021: domain - to an array. Also generates javascript and idx hash used to
! 8022: generate Domain Coordinator interface for editing Course Categories.
! 8023:
! 8024: Inputs:
! 8025: categories (reference to hash of category definitions).
! 8026: cats (reference to array of arrays/hashes which encapsulates hierarchy of
! 8027: categories and subcategories).
! 8028: idx (reference to hash of counters used in Domain Coordinator interface for
! 8029: editing Course Categories).
! 8030: jsarray (reference to array of categories used to create Javascript arrays for
! 8031: Domain Coordinator interface for editing Course Categories).
! 8032:
! 8033: Returns: nothing
! 8034:
! 8035: Side effects: populates cats, idx and jsarray.
! 8036:
! 8037: =cut
! 8038:
! 8039: sub gather_categories {
! 8040: my ($categories,$cats,$idx,$jsarray) = @_;
! 8041: my %counters;
! 8042: my $num = 0;
! 8043: foreach my $item (keys(%{$categories})) {
! 8044: my ($cat,$container,$depth) = map { &unescape($_); } split(/:/,$item);
! 8045: if ($container eq '' && $depth == 0) {
! 8046: $cats->[$depth][$categories->{$item}] = $cat;
! 8047: } else {
! 8048: $cats->[$depth]{$container}[$categories->{$item}] = $cat;
! 8049: }
! 8050: my ($escitem,$tail) = split(/:/,$item,2);
! 8051: if ($counters{$tail} eq '') {
! 8052: $counters{$tail} = $num;
! 8053: $num ++;
! 8054: }
! 8055: if (ref($idx) eq 'HASH') {
! 8056: $idx->{$item} = $counters{$tail};
! 8057: }
! 8058: if (ref($jsarray) eq 'ARRAY') {
! 8059: push(@{$jsarray->[$counters{$tail}]},$item);
! 8060: }
! 8061: }
! 8062: return;
! 8063: }
! 8064:
! 8065: =pod
! 8066:
! 8067: =item * &extract_categories()
! 8068:
! 8069: Used to generate breadcrumb trails for course categories.
! 8070:
! 8071: Inputs:
! 8072: categories (reference to hash of category definitions).
! 8073: cats (reference to array of arrays/hashes which encapsulates hierarchy of
! 8074: categories and subcategories).
! 8075: trails (reference to array of breacrumb trails for each category).
! 8076: allitems (reference to hash - key is category key
! 8077: (format: escaped(name):escaped(parent category):depth in hierarchy).
! 8078: idx (reference to hash of counters used in Domain Coordinator interface for
! 8079: editing Course Categories).
! 8080: jsarray (reference to array of categories used to create Javascript arrays for
! 8081: Domain Coordinator interface for editing Course Categories).
! 8082:
! 8083: Returns: nothing
! 8084:
! 8085: Side effects: populates trails and allitems hash references.
! 8086:
! 8087: =cut
! 8088:
! 8089: sub extract_categories {
! 8090: my ($categories,$cats,$trails,$allitems,$idx,$jsarray) = @_;
! 8091: if (ref($categories) eq 'HASH') {
! 8092: &gather_categories($categories,$cats,$idx,$jsarray);
! 8093: if (ref($cats->[0]) eq 'ARRAY') {
! 8094: for (my $i=0; $i<@{$cats->[0]}; $i++) {
! 8095: my $name = $cats->[0][$i];
! 8096: my $item = &escape($name).'::0';
! 8097: my $trailstr;
! 8098: if ($name eq 'instcode') {
! 8099: $trailstr = &mt('Official courses (with institutional codes)');
! 8100: } else {
! 8101: $trailstr = $name;
! 8102: }
! 8103: if ($allitems->{$item} eq '') {
! 8104: push(@{$trails},$trailstr);
! 8105: $allitems->{$item} = scalar(@{$trails})-1;
! 8106: }
! 8107: my @parents = ($name);
! 8108: if (ref($cats->[1]{$name}) eq 'ARRAY') {
! 8109: for (my $j=0; $j<@{$cats->[1]{$name}}; $j++) {
! 8110: my $category = $cats->[1]{$name}[$j];
! 8111: &recurse_categories($cats,2,$category,$trails,$allitems,\@parents);
! 8112: }
! 8113: }
! 8114: }
! 8115: }
! 8116: }
! 8117: return;
! 8118: }
! 8119:
! 8120: =pod
! 8121:
! 8122: =item *&recurse_categories()
! 8123:
! 8124: Recursively used to generate breadcrumb trails for course categories.
! 8125:
! 8126: Inputs:
! 8127: cats (reference to array of arrays/hashes which encapsulates hierarchy of
! 8128: categories and subcategories).
! 8129: depth (current depth in hierarchy of categories and sub-categories - 0 indexed).
! 8130: category (current course category, for which breadcrumb trail is being generated).
! 8131: trails (reference to array of breacrumb trails for each category).
! 8132: allitems (reference to hash - key is category key
! 8133: (format: escaped(name):escaped(parent category):depth in hierarchy).
! 8134: parents (array containing containers directories for current category,
! 8135: back to top level).
! 8136:
! 8137: Returns: nothing
! 8138:
! 8139: Side effects: populates trails and allitems hash references
! 8140:
! 8141: =back
! 8142:
! 8143: =cut
! 8144:
! 8145: sub recurse_categories {
! 8146: my ($cats,$depth,$category,$trails,$allitems,$parents) = @_;
! 8147: my $shallower = $depth - 1;
! 8148: if (ref($cats->[$depth]{$category}) eq 'ARRAY') {
! 8149: for (my $k=0; $k<@{$cats->[$depth]{$category}}; $k++) {
! 8150: my $name = $cats->[$depth]{$category}[$k];
! 8151: my $item = &escape($category).':'.&escape($parents->[-1]).':'.$shallower;
! 8152: my $trailstr = join(' -> ',(@{$parents},$category));
! 8153: if ($allitems->{$item} eq '') {
! 8154: push(@{$trails},$trailstr);
! 8155: $allitems->{$item} = scalar(@{$trails})-1;
! 8156: }
! 8157: my $deeper = $depth+1;
! 8158: push(@{$parents},$category);
! 8159: &recurse_categories($cats,$deeper,$name,$trails,$allitems,$parents);
! 8160: pop(@{$parents});
! 8161: }
! 8162: } else {
! 8163: my $item = &escape($category).':'.&escape($parents->[-1]).':'.$shallower;
! 8164: my $trailstr = join(' -> ',(@{$parents},$category));
! 8165: if ($allitems->{$item} eq '') {
! 8166: push(@{$trails},$trailstr);
! 8167: $allitems->{$item} = scalar(@{$trails})-1;
! 8168: }
! 8169: }
! 8170: return;
! 8171: }
! 8172:
! 8173: ############################################################
! 8174: ############################################################
! 8175:
! 8176:
1.443 albertel 8177: sub commit_customrole {
8178: my ($udom,$uname,$url,$three,$four,$five,$start,$end) = @_;
1.630 raeburn 8179: my $output = &mt('Assigning custom role').' "'.$five.'" by '.$four.':'.$three.' in '.$url.
1.443 albertel 8180: ($start?', '.&mt('starting').' '.localtime($start):'').
8181: ($end?', ending '.localtime($end):'').': <b>'.
8182: &Apache::lonnet::assigncustomrole(
8183: $udom,$uname,$url,$three,$four,$five,$end,$start).
8184: '</b><br />';
8185: return $output;
8186: }
8187:
8188: sub commit_standardrole {
1.541 raeburn 8189: my ($udom,$uname,$url,$three,$start,$end,$one,$two,$sec,$context) = @_;
8190: my ($output,$logmsg,$linefeed);
8191: if ($context eq 'auto') {
8192: $linefeed = "\n";
8193: } else {
8194: $linefeed = "<br />\n";
8195: }
1.443 albertel 8196: if ($three eq 'st') {
1.541 raeburn 8197: my $result = &commit_studentrole(\$logmsg,$udom,$uname,$url,$three,$start,$end,
8198: $one,$two,$sec,$context);
8199: if (($result =~ /^error/) || ($result eq 'not_in_class') ||
1.626 raeburn 8200: ($result eq 'unknown_course') || ($result eq 'refused')) {
8201: $output = $logmsg.' '.&mt('Error: ').$result."\n";
1.443 albertel 8202: } else {
1.541 raeburn 8203: $output = $logmsg.$linefeed.&mt('Assigning').' '.$three.' in '.$url.
1.443 albertel 8204: ($start?', '.&mt('starting').' '.localtime($start):'').
1.541 raeburn 8205: ($end?', '.&mt('ending').' '.localtime($end):'').': ';
8206: if ($context eq 'auto') {
8207: $output .= $result.$linefeed.&mt('Add to classlist').': ok';
8208: } else {
8209: $output .= '<b>'.$result.'</b>'.$linefeed.
8210: &mt('Add to classlist').': <b>ok</b>';
8211: }
8212: $output .= $linefeed;
1.443 albertel 8213: }
8214: } else {
8215: $output = &mt('Assigning').' '.$three.' in '.$url.
8216: ($start?', '.&mt('starting').' '.localtime($start):'').
1.541 raeburn 8217: ($end?', '.&mt('ending').' '.localtime($end):'').': ';
1.652 raeburn 8218: my $result = &Apache::lonnet::assignrole($udom,$uname,$url,$three,$end,$start,'','',$context);
1.541 raeburn 8219: if ($context eq 'auto') {
8220: $output .= $result.$linefeed;
8221: } else {
8222: $output .= '<b>'.$result.'</b>'.$linefeed;
8223: }
1.443 albertel 8224: }
8225: return $output;
8226: }
8227:
8228: sub commit_studentrole {
1.541 raeburn 8229: my ($logmsg,$udom,$uname,$url,$three,$start,$end,$one,$two,$sec,$context) = @_;
1.626 raeburn 8230: my ($result,$linefeed,$oldsecurl,$newsecurl);
1.541 raeburn 8231: if ($context eq 'auto') {
8232: $linefeed = "\n";
8233: } else {
8234: $linefeed = '<br />'."\n";
8235: }
1.443 albertel 8236: if (defined($one) && defined($two)) {
8237: my $cid=$one.'_'.$two;
8238: my $oldsec=&Apache::lonnet::getsection($udom,$uname,$cid);
8239: my $secchange = 0;
8240: my $expire_role_result;
8241: my $modify_section_result;
1.628 raeburn 8242: if ($oldsec ne '-1') {
8243: if ($oldsec ne $sec) {
1.443 albertel 8244: $secchange = 1;
1.628 raeburn 8245: my $now = time;
1.443 albertel 8246: my $uurl='/'.$cid;
8247: $uurl=~s/\_/\//g;
8248: if ($oldsec) {
8249: $uurl.='/'.$oldsec;
8250: }
1.626 raeburn 8251: $oldsecurl = $uurl;
1.628 raeburn 8252: $expire_role_result =
1.652 raeburn 8253: &Apache::lonnet::assignrole($udom,$uname,$uurl,'st',$now,'','',$context);
1.628 raeburn 8254: if ($env{'request.course.sec'} ne '') {
8255: if ($expire_role_result eq 'refused') {
8256: my @roles = ('st');
8257: my @statuses = ('previous');
8258: my @roledoms = ($one);
8259: my $withsec = 1;
8260: my %roleshash =
8261: &Apache::lonnet::get_my_roles($uname,$udom,'userroles',
8262: \@statuses,\@roles,\@roledoms,$withsec);
8263: if (defined ($roleshash{$two.':'.$one.':st:'.$oldsec})) {
8264: my ($oldstart,$oldend) =
8265: split(':',$roleshash{$two.':'.$one.':st:'.$oldsec});
8266: if ($oldend > 0 && $oldend <= $now) {
8267: $expire_role_result = 'ok';
8268: }
8269: }
8270: }
8271: }
1.443 albertel 8272: $result = $expire_role_result;
8273: }
8274: }
8275: if (($expire_role_result eq 'ok') || ($secchange == 0)) {
1.652 raeburn 8276: $modify_section_result = &Apache::lonnet::modify_student_enrollment($udom,$uname,undef,undef,undef,undef,undef,$sec,$end,$start,'','',$cid,'',$context);
1.443 albertel 8277: if ($modify_section_result =~ /^ok/) {
8278: if ($secchange == 1) {
1.628 raeburn 8279: if ($sec eq '') {
8280: $$logmsg .= &mt('Section for [_1] switched from (possibly expired) old section: [_2] to student role without a section.',$uname,$oldsec).$linefeed;
8281: } else {
8282: $$logmsg .= &mt('Section for [_1] switched from (possibly expired) old section: [_2] to new section: [_3].',$uname,$oldsec,$sec).$linefeed;
8283: }
1.443 albertel 8284: } elsif ($oldsec eq '-1') {
1.628 raeburn 8285: if ($sec eq '') {
8286: $$logmsg .= &mt('New student role without a section for [_1] in course [_2].',$uname,$cid).$linefeed;
8287: } else {
8288: $$logmsg .= &mt('New student role for [_1] in section [_2] in course [_3].',$uname,$sec,$cid).$linefeed;
8289: }
1.443 albertel 8290: } else {
1.628 raeburn 8291: if ($sec eq '') {
8292: $$logmsg .= &mt('Student [_1] assigned to course [_2] without a section.',$uname,$cid).$linefeed;
8293: } else {
8294: $$logmsg .= &mt('Student [_1] assigned to section [_2] in course [_3].',$uname,$sec,$cid).$linefeed;
8295: }
1.443 albertel 8296: }
8297: } else {
1.628 raeburn 8298: if ($secchange) {
8299: $$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;
8300: } else {
8301: $$logmsg .= &mt('Error when attempting to modify role for [_1] for section: "[_2]" in course [_3] -error:',$uname,$sec,$cid).' '.$modify_section_result.$linefeed;
8302: }
1.443 albertel 8303: }
8304: $result = $modify_section_result;
8305: } elsif ($secchange == 1) {
1.628 raeburn 8306: if ($oldsec eq '') {
8307: $$logmsg .= &mt('Error when attempting to expire existing role without a section for [_1] in course [_3] -error: ',$uname,$cid).' '.$expire_role_result.$linefeed;
8308: } else {
8309: $$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;
8310: }
1.626 raeburn 8311: if ($expire_role_result eq 'refused') {
8312: my $newsecurl = '/'.$cid;
8313: $newsecurl =~ s/\_/\//g;
8314: if ($sec ne '') {
8315: $newsecurl.='/'.$sec;
8316: }
8317: if (&Apache::lonnet::allowed('cst',$newsecurl) && !(&Apache::lonnet::allowed('cst',$oldsecurl))) {
8318: if ($sec eq '') {
8319: $$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;
8320: } else {
8321: $$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;
8322: }
8323: }
8324: }
1.443 albertel 8325: }
8326: } else {
1.626 raeburn 8327: $$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 8328: $result = "error: incomplete course id\n";
8329: }
8330: return $result;
8331: }
8332:
8333: ############################################################
8334: ############################################################
8335:
1.566 albertel 8336: sub check_clone {
1.578 raeburn 8337: my ($args,$linefeed) = @_;
1.566 albertel 8338: my $cloneid='/'.$args->{'clonedomain'}.'/'.$args->{'clonecourse'};
8339: my ($clonecrsudom,$clonecrsunum)= &LONCAPA::split_courseid($cloneid);
8340: my $clonehome=&Apache::lonnet::homeserver($clonecrsunum,$clonecrsudom);
8341: my $clonemsg;
8342: my $can_clone = 0;
8343:
8344: if ($clonehome eq 'no_host') {
1.578 raeburn 8345: $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 8346: } else {
8347: my %clonedesc = &Apache::lonnet::coursedescription($cloneid,{'one_time' => 1});
1.568 albertel 8348: if ($env{'request.role.domain'} eq $args->{'clonedomain'}) {
1.566 albertel 8349: $can_clone = 1;
8350: } else {
8351: my %clonehash = &Apache::lonnet::get('environment',['cloners'],
8352: $args->{'clonedomain'},$args->{'clonecourse'});
8353: my @cloners = split(/,/,$clonehash{'cloners'});
1.578 raeburn 8354: if (grep(/^\*$/,@cloners)) {
8355: $can_clone = 1;
8356: } elsif (grep(/^\*\:\Q$args->{'ccdomain'}\E$/,@cloners)) {
8357: $can_clone = 1;
8358: } else {
8359: my %roleshash =
8360: &Apache::lonnet::get_my_roles($args->{'ccuname'},
8361: $args->{'ccdomain'},
8362: 'userroles',['active'],['cc'],
8363: [$args->{'clonedomain'}]);
8364: if (($roleshash{$args->{'clonecourse'}.':'.$args->{'clonedomain'}.':cc'}) || (grep(/^\Q$args->{'ccuname'}\E:\Q$args->{'ccdomain'}\E$/,@cloners))) {
8365: $can_clone = 1;
8366: } else {
8367: $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'});
8368: }
1.566 albertel 8369: }
1.578 raeburn 8370: }
1.566 albertel 8371: }
8372: return ($can_clone, $clonemsg, $cloneid, $clonehome);
8373: }
8374:
1.444 albertel 8375: sub construct_course {
1.541 raeburn 8376: my ($args,$logmsg,$courseid,$crsudom,$crsunum,$udom,$uname,$context) = @_;
1.444 albertel 8377: my $outcome;
1.541 raeburn 8378: my $linefeed = '<br />'."\n";
8379: if ($context eq 'auto') {
8380: $linefeed = "\n";
8381: }
1.566 albertel 8382:
8383: #
8384: # Are we cloning?
8385: #
8386: my ($can_clone, $clonemsg, $cloneid, $clonehome);
8387: if (($args->{'clonecourse'}) && ($args->{'clonedomain'})) {
1.578 raeburn 8388: ($can_clone, $clonemsg, $cloneid, $clonehome) = &check_clone($args,$linefeed);
1.566 albertel 8389: if ($context ne 'auto') {
1.578 raeburn 8390: if ($clonemsg ne '') {
8391: $clonemsg = '<span class="LC_error">'.$clonemsg.'</span>';
8392: }
1.566 albertel 8393: }
8394: $outcome .= $clonemsg.$linefeed;
8395:
8396: if (!$can_clone) {
8397: return (0,$outcome);
8398: }
8399: }
8400:
1.444 albertel 8401: #
8402: # Open course
8403: #
8404: my $crstype = lc($args->{'crstype'});
8405: my %cenv=();
8406: $$courseid=&Apache::lonnet::createcourse($args->{'course_domain'},
8407: $args->{'cdescr'},
8408: $args->{'curl'},
8409: $args->{'course_home'},
8410: $args->{'nonstandard'},
8411: $args->{'crscode'},
8412: $args->{'ccuname'}.':'.
8413: $args->{'ccdomain'},
8414: $args->{'crstype'});
8415:
8416: # Note: The testing routines depend on this being output; see
8417: # Utils::Course. This needs to at least be output as a comment
8418: # if anyone ever decides to not show this, and Utils::Course::new
8419: # will need to be suitably modified.
1.541 raeburn 8420: $outcome .= &mt('New LON-CAPA [_1] ID: [_2]',$crstype,$$courseid).$linefeed;
1.444 albertel 8421: #
8422: # Check if created correctly
8423: #
1.479 albertel 8424: ($$crsudom,$$crsunum)= &LONCAPA::split_courseid($$courseid);
1.444 albertel 8425: my $crsuhome=&Apache::lonnet::homeserver($$crsunum,$$crsudom);
1.541 raeburn 8426: $outcome .= &mt('Created on').': '.$crsuhome.$linefeed;
1.566 albertel 8427:
1.444 albertel 8428: #
1.566 albertel 8429: # Do the cloning
8430: #
8431: if ($can_clone && $cloneid) {
8432: $clonemsg = &mt('Cloning [_1] from [_2]',$crstype,$clonehome);
8433: if ($context ne 'auto') {
8434: $clonemsg = '<span class="LC_success">'.$clonemsg.'</span>';
8435: }
8436: $outcome .= $clonemsg.$linefeed;
8437: my %oldcenv=&Apache::lonnet::dump('environment',$$crsudom,$$crsunum);
1.444 albertel 8438: # Copy all files
1.637 www 8439: &Apache::lonclonecourse::copycoursefiles($cloneid,$$courseid,$args->{'datemode'},$args->{'dateshift'});
1.444 albertel 8440: # Restore URL
1.566 albertel 8441: $cenv{'url'}=$oldcenv{'url'};
1.444 albertel 8442: # Restore title
1.566 albertel 8443: $cenv{'description'}=$oldcenv{'description'};
1.444 albertel 8444: # Mark as cloned
1.566 albertel 8445: $cenv{'clonedfrom'}=$cloneid;
1.638 www 8446: # Need to clone grading mode
8447: my %newenv=&Apache::lonnet::get('environment',['grading'],$$crsudom,$$crsunum);
8448: $cenv{'grading'}=$newenv{'grading'};
8449: # Do not clone these environment entries
8450: &Apache::lonnet::del('environment',
8451: ['default_enrollment_start_date',
8452: 'default_enrollment_end_date',
8453: 'question.email',
8454: 'policy.email',
8455: 'comment.email',
8456: 'pch.users.denied',
8457: 'plc.users.denied'],
8458: $$crsudom,$$crsunum);
1.444 albertel 8459: }
1.566 albertel 8460:
1.444 albertel 8461: #
8462: # Set environment (will override cloned, if existing)
8463: #
8464: my @sections = ();
8465: my @xlists = ();
8466: if ($args->{'crstype'}) {
8467: $cenv{'type'}=$args->{'crstype'};
8468: }
8469: if ($args->{'crsid'}) {
8470: $cenv{'courseid'}=$args->{'crsid'};
8471: }
8472: if ($args->{'crscode'}) {
8473: $cenv{'internal.coursecode'}=$args->{'crscode'};
8474: }
8475: if ($args->{'crsquota'} ne '') {
8476: $cenv{'internal.coursequota'}=$args->{'crsquota'};
8477: } else {
8478: $cenv{'internal.coursequota'}=$args->{'crsquota'} = 20;
8479: }
8480: if ($args->{'ccuname'}) {
8481: $cenv{'internal.courseowner'} = $args->{'ccuname'}.
8482: ':'.$args->{'ccdomain'};
8483: } else {
8484: $cenv{'internal.courseowner'} = $args->{'curruser'};
8485: }
8486: my @badclasses = (); # Used to accumulate sections/crosslistings that did not pass classlist access check for course owner.
8487: if ($args->{'crssections'}) {
8488: $cenv{'internal.sectionnums'} = '';
8489: if ($args->{'crssections'} =~ m/,/) {
8490: @sections = split/,/,$args->{'crssections'};
8491: } else {
8492: $sections[0] = $args->{'crssections'};
8493: }
8494: if (@sections > 0) {
8495: foreach my $item (@sections) {
8496: my ($sec,$gp) = split/:/,$item;
8497: my $class = $args->{'crscode'}.$sec;
8498: my $addcheck = &Apache::lonnet::auto_new_course($$crsunum,$$crsudom,$class,$cenv{'internal.courseowner'});
8499: $cenv{'internal.sectionnums'} .= $item.',';
8500: unless ($addcheck eq 'ok') {
8501: push @badclasses, $class;
8502: }
8503: }
8504: $cenv{'internal.sectionnums'} =~ s/,$//;
8505: }
8506: }
8507: # do not hide course coordinator from staff listing,
8508: # even if privileged
8509: $cenv{'nothideprivileged'}=$args->{'ccuname'}.':'.$args->{'ccdomain'};
8510: # add crosslistings
8511: if ($args->{'crsxlist'}) {
8512: $cenv{'internal.crosslistings'}='';
8513: if ($args->{'crsxlist'} =~ m/,/) {
8514: @xlists = split/,/,$args->{'crsxlist'};
8515: } else {
8516: $xlists[0] = $args->{'crsxlist'};
8517: }
8518: if (@xlists > 0) {
8519: foreach my $item (@xlists) {
8520: my ($xl,$gp) = split/:/,$item;
8521: my $addcheck = &Apache::lonnet::auto_new_course($$crsunum,$$crsudom,$xl,$cenv{'internal.courseowner'});
8522: $cenv{'internal.crosslistings'} .= $item.',';
8523: unless ($addcheck eq 'ok') {
8524: push @badclasses, $xl;
8525: }
8526: }
8527: $cenv{'internal.crosslistings'} =~ s/,$//;
8528: }
8529: }
8530: if ($args->{'autoadds'}) {
8531: $cenv{'internal.autoadds'}=$args->{'autoadds'};
8532: }
8533: if ($args->{'autodrops'}) {
8534: $cenv{'internal.autodrops'}=$args->{'autodrops'};
8535: }
8536: # check for notification of enrollment changes
8537: my @notified = ();
8538: if ($args->{'notify_owner'}) {
8539: if ($args->{'ccuname'} ne '') {
8540: push(@notified,$args->{'ccuname'}.':'.$args->{'ccdomain'});
8541: }
8542: }
8543: if ($args->{'notify_dc'}) {
8544: if ($uname ne '') {
1.630 raeburn 8545: push(@notified,$uname.':'.$udom);
1.444 albertel 8546: }
8547: }
8548: if (@notified > 0) {
8549: my $notifylist;
8550: if (@notified > 1) {
8551: $notifylist = join(',',@notified);
8552: } else {
8553: $notifylist = $notified[0];
8554: }
8555: $cenv{'internal.notifylist'} = $notifylist;
8556: }
8557: if (@badclasses > 0) {
8558: my %lt=&Apache::lonlocal::texthash(
8559: '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',
8560: 'dnhr' => 'does not have rights to access enrollment in these classes',
8561: 'adby' => 'as determined by the policies of your institution on access to official classlists'
8562: );
1.541 raeburn 8563: my $badclass_msg = $cenv{'internal.courseowner'}.') - '.$lt{'dnhr'}.
8564: ' ('.$lt{'adby'}.')';
8565: if ($context eq 'auto') {
8566: $outcome .= $badclass_msg.$linefeed;
1.566 albertel 8567: $outcome .= '<div class="LC_warning">'.$badclass_msg.$linefeed.'<ul>'."\n";
1.541 raeburn 8568: foreach my $item (@badclasses) {
8569: if ($context eq 'auto') {
8570: $outcome .= " - $item\n";
8571: } else {
8572: $outcome .= "<li>$item</li>\n";
8573: }
8574: }
8575: if ($context eq 'auto') {
8576: $outcome .= $linefeed;
8577: } else {
1.566 albertel 8578: $outcome .= "</ul><br /><br /></div>\n";
1.541 raeburn 8579: }
8580: }
1.444 albertel 8581: }
8582: if ($args->{'no_end_date'}) {
8583: $args->{'endaccess'} = 0;
8584: }
8585: $cenv{'internal.autostart'}=$args->{'enrollstart'};
8586: $cenv{'internal.autoend'}=$args->{'enrollend'};
8587: $cenv{'default_enrollment_start_date'}=$args->{'startaccess'};
8588: $cenv{'default_enrollment_end_date'}=$args->{'endaccess'};
8589: if ($args->{'showphotos'}) {
8590: $cenv{'internal.showphotos'}=$args->{'showphotos'};
8591: }
8592: $cenv{'internal.authtype'} = $args->{'authtype'};
8593: $cenv{'internal.autharg'} = $args->{'autharg'};
8594: if ( ($cenv{'internal.authtype'} =~ /^krb/) && ($cenv{'internal.autoadds'} == 1)) {
8595: if (! defined($cenv{'internal.autharg'}) || $cenv{'internal.autharg'} eq '') {
1.541 raeburn 8596: 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');
8597: if ($context eq 'auto') {
8598: $outcome .= $krb_msg;
8599: } else {
1.566 albertel 8600: $outcome .= '<span class="LC_error">'.$krb_msg.'</span>';
1.541 raeburn 8601: }
8602: $outcome .= $linefeed;
1.444 albertel 8603: }
8604: }
8605: if (($args->{'ccdomain'}) && ($args->{'ccuname'})) {
8606: if ($args->{'setpolicy'}) {
8607: $cenv{'policy.email'}=$args->{'ccuname'}.':'.$args->{'ccdomain'};
8608: }
8609: if ($args->{'setcontent'}) {
8610: $cenv{'question.email'}=$args->{'ccuname'}.':'.$args->{'ccdomain'};
8611: }
8612: }
8613: if ($args->{'reshome'}) {
8614: $cenv{'reshome'}=$args->{'reshome'}.'/';
8615: $cenv{'reshome'}=~s/\/+$/\//;
8616: }
8617: #
8618: # course has keyed access
8619: #
8620: if ($args->{'setkeys'}) {
8621: $cenv{'keyaccess'}='yes';
8622: }
8623: # if specified, key authority is not course, but user
8624: # only active if keyaccess is yes
8625: if ($args->{'keyauth'}) {
1.487 albertel 8626: my ($user,$domain) = split(':',$args->{'keyauth'});
8627: $user = &LONCAPA::clean_username($user);
8628: $domain = &LONCAPA::clean_username($domain);
1.488 foxr 8629: if ($user ne '' && $domain ne '') {
1.487 albertel 8630: $cenv{'keyauth'}=$user.':'.$domain;
1.444 albertel 8631: }
8632: }
8633:
8634: if ($args->{'disresdis'}) {
8635: $cenv{'pch.roles.denied'}='st';
8636: }
8637: if ($args->{'disablechat'}) {
8638: $cenv{'plc.roles.denied'}='st';
8639: }
8640:
8641: # Record we've not yet viewed the Course Initialization Helper for this
8642: # course
8643: $cenv{'course.helper.not.run'} = 1;
8644: #
8645: # Use new Randomseed
8646: #
8647: $cenv{'rndseed'}=&Apache::lonnet::latest_rnd_algorithm_id();;
8648: $cenv{'receiptalg'}=&Apache::lonnet::latest_receipt_algorithm_id();;
8649: #
8650: # The encryption code and receipt prefix for this course
8651: #
8652: $cenv{'internal.encseed'}=$Apache::lonnet::perlvar{'lonReceipt'}.$$.time.int(rand(9999));
8653: $cenv{'internal.encpref'}=100+int(9*rand(99));
8654: #
8655: # By default, use standard grading
8656: if (!defined($cenv{'grading'})) { $cenv{'grading'} = 'standard'; }
8657:
1.541 raeburn 8658: $outcome .= $linefeed.&mt('Setting environment').': '.
8659: &Apache::lonnet::put('environment',\%cenv,$$crsudom,$$crsunum).$linefeed;
1.444 albertel 8660: #
8661: # Open all assignments
8662: #
8663: if ($args->{'openall'}) {
8664: my $storeunder=$$crsudom.'_'.$$crsunum.'.0.opendate';
8665: my %storecontent = ($storeunder => time,
8666: $storeunder.'.type' => 'date_start');
8667:
8668: $outcome .= &mt('Opening all assignments').': '.&Apache::lonnet::cput
1.541 raeburn 8669: ('resourcedata',\%storecontent,$$crsudom,$$crsunum).$linefeed;
1.444 albertel 8670: }
8671: #
8672: # Set first page
8673: #
8674: unless (($args->{'nonstandard'}) || ($args->{'firstres'} eq 'blank')
8675: || ($cloneid)) {
1.445 albertel 8676: use LONCAPA::map;
1.444 albertel 8677: $outcome .= &mt('Setting first resource').': ';
1.445 albertel 8678:
8679: my $map = '/uploaded/'.$$crsudom.'/'.$$crsunum.'/default.sequence';
8680: my ($errtext,$fatal)=&LONCAPA::map::mapread($map);
8681:
1.444 albertel 8682: $outcome .= ($fatal?$errtext:'read ok').' - ';
8683: my $title; my $url;
8684: if ($args->{'firstres'} eq 'syl') {
8685: $title='Syllabus';
8686: $url='/public/'.$$crsudom.'/'.$$crsunum.'/syllabus';
8687: } else {
8688: $title='Navigate Contents';
8689: $url='/adm/navmaps';
8690: }
1.445 albertel 8691:
8692: $LONCAPA::map::resources[1]=$title.':'.$url.':false:start:res';
8693: (my $outtext,$errtext) = &LONCAPA::map::storemap($map,1);
8694:
8695: if ($errtext) { $fatal=2; }
1.541 raeburn 8696: $outcome .= ($fatal?$errtext:'write ok').$linefeed;
1.444 albertel 8697: }
1.566 albertel 8698:
8699: return (1,$outcome);
1.444 albertel 8700: }
8701:
8702: ############################################################
8703: ############################################################
8704:
1.378 raeburn 8705: sub course_type {
8706: my ($cid) = @_;
8707: if (!defined($cid)) {
8708: $cid = $env{'request.course.id'};
8709: }
1.404 albertel 8710: if (defined($env{'course.'.$cid.'.type'})) {
8711: return $env{'course.'.$cid.'.type'};
1.378 raeburn 8712: } else {
8713: return 'Course';
1.377 raeburn 8714: }
8715: }
1.156 albertel 8716:
1.406 raeburn 8717: sub group_term {
8718: my $crstype = &course_type();
8719: my %names = (
8720: 'Course' => 'group',
8721: 'Group' => 'team',
8722: );
8723: return $names{$crstype};
8724: }
8725:
1.156 albertel 8726: sub icon {
8727: my ($file)=@_;
1.505 albertel 8728: my $curfext = lc((split(/\./,$file))[-1]);
1.168 albertel 8729: my $iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/unknown.gif';
1.156 albertel 8730: my $embstyle = &Apache::loncommon::fileembstyle($curfext);
1.168 albertel 8731: if (!(!defined($embstyle) || $embstyle eq 'unk' || $embstyle eq 'hdn')) {
8732: if (-e $Apache::lonnet::perlvar{'lonDocRoot'}.'/'.
8733: $Apache::lonnet::perlvar{'lonIconsURL'}.'/'.
8734: $curfext.".gif") {
8735: $iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/'.
8736: $curfext.".gif";
8737: }
8738: }
1.249 albertel 8739: return &lonhttpdurl($iconname);
1.154 albertel 8740: }
1.84 albertel 8741:
1.575 albertel 8742: sub lonhttpd_port {
1.215 albertel 8743: my $lonhttpd_port=$Apache::lonnet::perlvar{'lonhttpdPort'};
8744: if (!defined($lonhttpd_port)) { $lonhttpd_port='8080'; }
1.574 albertel 8745: # IE doesn't like a secure page getting images from a non-secure
8746: # port (when logging we haven't parsed the browser type so default
8747: # back to secure
8748: if ((!exists($env{'browser.type'}) || $env{'browser.type'} eq 'explorer')
8749: && $ENV{'SERVER_PORT'} == 443) {
1.575 albertel 8750: return 443;
8751: }
8752: return $lonhttpd_port;
8753:
8754: }
8755:
8756: sub lonhttpdurl {
8757: my ($url)=@_;
8758:
8759: my $lonhttpd_port = &lonhttpd_port();
8760: if ($lonhttpd_port == 443) {
1.574 albertel 8761: return 'https://'.$ENV{'SERVER_NAME'}.$url;
8762: }
1.215 albertel 8763: return 'http://'.$ENV{'SERVER_NAME'}.':'.$lonhttpd_port.$url;
8764: }
8765:
1.213 albertel 8766: sub connection_aborted {
8767: my ($r)=@_;
8768: $r->print(" ");$r->rflush();
8769: my $c = $r->connection;
8770: return $c->aborted();
8771: }
8772:
1.221 foxr 8773: # Escapes strings that may have embedded 's that will be put into
1.222 foxr 8774: # strings as 'strings'.
8775: sub escape_single {
1.221 foxr 8776: my ($input) = @_;
1.223 albertel 8777: $input =~ s/\\/\\\\/g; # Escape the \'s..(must be first)>
1.221 foxr 8778: $input =~ s/\'/\\\'/g; # Esacpe the 's....
8779: return $input;
8780: }
1.223 albertel 8781:
1.222 foxr 8782: # Same as escape_single, but escape's "'s This
8783: # can be used for "strings"
8784: sub escape_double {
8785: my ($input) = @_;
8786: $input =~ s/\\/\\\\/g; # Escape the /'s..(must be first)>
8787: $input =~ s/\"/\\\"/g; # Esacpe the "s....
8788: return $input;
8789: }
1.223 albertel 8790:
1.222 foxr 8791: # Escapes the last element of a full URL.
8792: sub escape_url {
8793: my ($url) = @_;
1.238 raeburn 8794: my @urlslices = split(/\//, $url,-1);
1.369 www 8795: my $lastitem = &escape(pop(@urlslices));
1.223 albertel 8796: return join('/',@urlslices).'/'.$lastitem;
1.222 foxr 8797: }
1.462 albertel 8798:
8799: # -------------------------------------------------------- Initliaze user login
8800: sub init_user_environment {
1.463 albertel 8801: my ($r, $username, $domain, $authhost, $form, $args) = @_;
1.462 albertel 8802: my $lonids=$Apache::lonnet::perlvar{'lonIDsDir'};
8803:
8804: my $public=($username eq 'public' && $domain eq 'public');
8805:
8806: # See if old ID present, if so, remove
8807:
8808: my ($filename,$cookie,$userroles);
8809: my $now=time;
8810:
8811: if ($public) {
8812: my $max_public=100;
8813: my $oldest;
8814: my $oldest_time=0;
8815: for(my $next=1;$next<=$max_public;$next++) {
8816: if (-e $lonids."/publicuser_$next.id") {
8817: my $mtime=(stat($lonids."/publicuser_$next.id"))[9];
8818: if ($mtime<$oldest_time || !$oldest_time) {
8819: $oldest_time=$mtime;
8820: $oldest=$next;
8821: }
8822: } else {
8823: $cookie="publicuser_$next";
8824: last;
8825: }
8826: }
8827: if (!$cookie) { $cookie="publicuser_$oldest"; }
8828: } else {
1.463 albertel 8829: # if this isn't a robot, kill any existing non-robot sessions
8830: if (!$args->{'robot'}) {
8831: opendir(DIR,$lonids);
8832: while ($filename=readdir(DIR)) {
8833: if ($filename=~/^$username\_\d+\_$domain\_$authhost\.id$/) {
8834: unlink($lonids.'/'.$filename);
8835: }
1.462 albertel 8836: }
1.463 albertel 8837: closedir(DIR);
1.462 albertel 8838: }
8839: # Give them a new cookie
1.463 albertel 8840: my $id = ($args->{'robot'} ? 'robot'.$args->{'robot'}
8841: : $now);
8842: $cookie="$username\_$id\_$domain\_$authhost";
1.462 albertel 8843:
8844: # Initialize roles
8845:
8846: $userroles=&Apache::lonnet::rolesinit($domain,$username,$authhost);
8847: }
8848: # ------------------------------------ Check browser type and MathML capability
8849:
8850: my ($httpbrowser,$clientbrowser,$clientversion,$clientmathml,
8851: $clientunicode,$clientos) = &decode_user_agent($r);
8852:
8853: # -------------------------------------- Any accessibility options to remember?
8854: if (($form->{'interface'}) && ($form->{'remember'} eq 'true')) {
8855: foreach my $option ('imagesuppress','appletsuppress',
8856: 'embedsuppress','fontenhance','blackwhite') {
8857: if ($form->{$option} eq 'true') {
8858: &Apache::lonnet::put('environment',{$option => 'on'},
8859: $domain,$username);
8860: } else {
8861: &Apache::lonnet::del('environment',[$option],
8862: $domain,$username);
8863: }
8864: }
8865: }
8866: # ------------------------------------------------------------- Get environment
8867:
8868: my %userenv = &Apache::lonnet::dump('environment',$domain,$username);
8869: my ($tmp) = keys(%userenv);
8870: if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
8871: # default remote control to off
8872: if ($userenv{'remote'} ne 'on') { $userenv{'remote'} = 'off'; }
8873: } else {
8874: undef(%userenv);
8875: }
8876: if (($userenv{'interface'}) && (!$form->{'interface'})) {
8877: $form->{'interface'}=$userenv{'interface'};
8878: }
8879: $env{'environment.remote'}=$userenv{'remote'};
8880: if ($userenv{'texengine'} eq 'ttm') { $clientmathml=1; }
8881:
8882: # --------------- Do not trust query string to be put directly into environment
8883: foreach my $option ('imagesuppress','appletsuppress',
8884: 'embedsuppress','fontenhance','blackwhite',
8885: 'interface','localpath','localres') {
8886: $form->{$option}=~s/[\n\r\=]//gs;
8887: }
8888: # --------------------------------------------------------- Write first profile
8889:
8890: {
8891: my %initial_env =
8892: ("user.name" => $username,
8893: "user.domain" => $domain,
8894: "user.home" => $authhost,
8895: "browser.type" => $clientbrowser,
8896: "browser.version" => $clientversion,
8897: "browser.mathml" => $clientmathml,
8898: "browser.unicode" => $clientunicode,
8899: "browser.os" => $clientos,
8900: "server.domain" => $Apache::lonnet::perlvar{'lonDefDomain'},
8901: "request.course.fn" => '',
8902: "request.course.uri" => '',
8903: "request.course.sec" => '',
8904: "request.role" => 'cm',
8905: "request.role.adv" => $env{'user.adv'},
8906: "request.host" => $ENV{'REMOTE_ADDR'},);
8907:
8908: if ($form->{'localpath'}) {
8909: $initial_env{"browser.localpath"} = $form->{'localpath'};
8910: $initial_env{"browser.localres"} = $form->{'localres'};
8911: }
8912:
8913: if ($public) {
8914: $initial_env{"environment.remote"} = "off";
8915: }
8916: if ($form->{'interface'}) {
8917: $form->{'interface'}=~s/\W//gs;
8918: $initial_env{"browser.interface"} = $form->{'interface'};
8919: $env{'browser.interface'}=$form->{'interface'};
8920: foreach my $option ('imagesuppress','appletsuppress',
8921: 'embedsuppress','fontenhance','blackwhite') {
8922: if (($form->{$option} eq 'true') ||
8923: ($userenv{$option} eq 'on')) {
8924: $initial_env{"browser.$option"} = "on";
8925: }
8926: }
8927: }
8928:
8929: $env{'user.environment'} = "$lonids/$cookie.id";
8930:
8931: if (tie(my %disk_env,'GDBM_File',"$lonids/$cookie.id",
8932: &GDBM_WRCREAT(),0640)) {
8933: &_add_to_env(\%disk_env,\%initial_env);
8934: &_add_to_env(\%disk_env,\%userenv,'environment.');
8935: &_add_to_env(\%disk_env,$userroles);
1.463 albertel 8936: if (ref($args->{'extra_env'})) {
8937: &_add_to_env(\%disk_env,$args->{'extra_env'});
8938: }
1.462 albertel 8939: untie(%disk_env);
8940: } else {
8941: &Apache::lonnet::logthis("<font color=\"blue\">WARNING: ".
8942: 'Could not create environment storage in lonauth: '.$!.'</font>');
8943: return 'error: '.$!;
8944: }
8945: }
8946: $env{'request.role'}='cm';
8947: $env{'request.role.adv'}=$env{'user.adv'};
8948: $env{'browser.type'}=$clientbrowser;
8949:
8950: return $cookie;
8951:
8952: }
8953:
8954: sub _add_to_env {
8955: my ($idf,$env_data,$prefix) = @_;
8956: while (my ($key,$value) = each(%$env_data)) {
8957: $idf->{$prefix.$key} = $value;
8958: $env{$prefix.$key} = $value;
8959: }
8960: }
8961:
8962:
1.41 ng 8963: =pod
8964:
8965: =back
8966:
1.112 bowersj2 8967: =cut
1.41 ng 8968:
1.112 bowersj2 8969: 1;
8970: __END__;
1.41 ng 8971:
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