Annotation of loncom/interface/loncommon.pm, revision 1.656
1.10 albertel 1: # The LearningOnline Network with CAPA
1.1 albertel 2: # a pile of common routines
1.10 albertel 3: #
1.656 ! www 4: # $Id: loncommon.pm,v 1.655 2008/05/29 02:58:41 raeburn 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.656 ! www 153: my %timezone;
1.124 www 154: my %supported_language;
1.12 harris41 155: my %cprtag;
1.192 taceyjo1 156: my %scprtag;
1.351 www 157: my %fe; my %fd; my %fm;
1.41 ng 158: my %category_extensions;
1.12 harris41 159:
1.46 matthew 160: # ---------------------------------------------- Thesaurus variables
1.144 matthew 161: #
162: # %Keywords:
163: # A hash used by &keyword to determine if a word is considered a keyword.
164: # $thesaurus_db_file
165: # Scalar containing the full path to the thesaurus database.
1.46 matthew 166:
167: my %Keywords;
168: my $thesaurus_db_file;
169:
1.144 matthew 170: #
171: # Initialize values from language.tab, copyright.tab, filetypes.tab,
172: # thesaurus.tab, and filecategories.tab.
173: #
1.18 www 174: BEGIN {
1.46 matthew 175: # Variable initialization
176: $thesaurus_db_file = $Apache::lonnet::perlvar{'lonTabDir'}."/thesaurus.db";
177: #
1.22 www 178: unless ($readit) {
1.12 harris41 179: # ------------------------------------------------------------------- languages
180: {
1.158 raeburn 181: my $langtabfile = $Apache::lonnet::perlvar{'lonTabDir'}.
182: '/language.tab';
183: if ( open(my $fh,"<$langtabfile") ) {
1.356 albertel 184: while (my $line = <$fh>) {
185: next if ($line=~/^\#/);
186: chomp($line);
187: my ($key,$two,$country,$three,$enc,$val,$sup)=(split(/\t/,$line));
1.158 raeburn 188: $language{$key}=$val.' - '.$enc;
189: if ($sup) {
190: $supported_language{$key}=$sup;
191: }
192: }
193: close($fh);
194: }
1.12 harris41 195: }
1.656 ! www 196: # ------------------------------------------------------------------- timezones
! 197: {
! 198: my $timetabfile = $Apache::lonnet::perlvar{'lonTabDir'}.
! 199: '/timezone.tab';
! 200: if ( open(my $fh,"<$timetabfile") ) {
! 201: while (my $line = <$fh>) {
! 202: next if ($line=~/^\#/);
! 203: chomp($line);
! 204: my $value=$line;
! 205: $value=~s/\_/ /g;
! 206: $timezone{$line}=$value;
! 207: }
! 208: close($fh);
! 209: }
! 210: }
! 211:
1.12 harris41 212: # ------------------------------------------------------------------ copyrights
213: {
1.158 raeburn 214: my $copyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.
215: '/copyright.tab';
216: if ( open (my $fh,"<$copyrightfile") ) {
1.356 albertel 217: while (my $line = <$fh>) {
218: next if ($line=~/^\#/);
219: chomp($line);
220: my ($key,$val)=(split(/\s+/,$line,2));
1.158 raeburn 221: $cprtag{$key}=$val;
222: }
223: close($fh);
224: }
1.12 harris41 225: }
1.351 www 226: # ----------------------------------------------------------- source copyrights
1.192 taceyjo1 227: {
228: my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.
229: '/source_copyright.tab';
230: if ( open (my $fh,"<$sourcecopyrightfile") ) {
1.356 albertel 231: while (my $line = <$fh>) {
232: next if ($line =~ /^\#/);
233: chomp($line);
234: my ($key,$val)=(split(/\s+/,$line,2));
1.192 taceyjo1 235: $scprtag{$key}=$val;
236: }
237: close($fh);
238: }
239: }
1.63 www 240:
1.517 raeburn 241: # -------------------------------------------------------------- default domain designs
1.63 www 242: my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors';
1.517 raeburn 243: my $designfile = $designdir.'/default.tab';
244: if ( open (my $fh,"<$designfile") ) {
245: while (my $line = <$fh>) {
246: next if ($line =~ /^\#/);
247: chomp($line);
248: my ($key,$val)=(split(/\=/,$line));
249: if ($val) { $defaultdesign{$key}=$val; }
250: }
251: close($fh);
1.63 www 252: }
253:
1.15 harris41 254: # ------------------------------------------------------------- file categories
255: {
1.158 raeburn 256: my $categoryfile = $Apache::lonnet::perlvar{'lonTabDir'}.
257: '/filecategories.tab';
258: if ( open (my $fh,"<$categoryfile") ) {
1.356 albertel 259: while (my $line = <$fh>) {
260: next if ($line =~ /^\#/);
261: chomp($line);
262: my ($extension,$category)=(split(/\s+/,$line,2));
1.158 raeburn 263: push @{$category_extensions{lc($category)}},$extension;
264: }
265: close($fh);
266: }
267:
1.15 harris41 268: }
1.12 harris41 269: # ------------------------------------------------------------------ file types
270: {
1.158 raeburn 271: my $typesfile = $Apache::lonnet::perlvar{'lonTabDir'}.
272: '/filetypes.tab';
273: if ( open (my $fh,"<$typesfile") ) {
1.356 albertel 274: while (my $line = <$fh>) {
275: next if ($line =~ /^\#/);
276: chomp($line);
277: my ($ending,$emb,$mime,$descr)=split(/\s+/,$line,4);
1.158 raeburn 278: if ($descr ne '') {
279: $fe{$ending}=lc($emb);
280: $fd{$ending}=$descr;
1.351 www 281: if ($mime ne 'unk') { $fm{$ending}=$mime; }
1.158 raeburn 282: }
283: }
284: close($fh);
285: }
1.12 harris41 286: }
1.22 www 287: &Apache::lonnet::logthis(
1.46 matthew 288: "<font color=yellow>INFO: Read file types</font>");
1.22 www 289: $readit=1;
1.46 matthew 290: } # end of unless($readit)
1.32 matthew 291:
292: }
1.112 bowersj2 293:
1.42 matthew 294: ###############################################################
295: ## HTML and Javascript Helper Functions ##
296: ###############################################################
297:
298: =pod
299:
1.112 bowersj2 300: =head1 HTML and Javascript Functions
1.42 matthew 301:
1.112 bowersj2 302: =over 4
303:
1.648 raeburn 304: =item * &browser_and_searcher_javascript()
1.112 bowersj2 305:
306: X<browsing, javascript>X<searching, javascript>Returns a string
307: containing javascript with two functions, C<openbrowser> and
308: C<opensearcher>. Returned string does not contain E<lt>scriptE<gt>
309: tags.
1.42 matthew 310:
1.648 raeburn 311: =item * &openbrowser(formname,elementname,only,omit) [javascript]
1.42 matthew 312:
313: inputs: formname, elementname, only, omit
314:
315: formname and elementname indicate the name of the html form and name of
316: the element that the results of the browsing selection are to be placed in.
317:
318: Specifying 'only' will restrict the browser to displaying only files
1.185 www 319: with the given extension. Can be a comma separated list.
1.42 matthew 320:
321: Specifying 'omit' will restrict the browser to NOT displaying files
1.185 www 322: with the given extension. Can be a comma separated list.
1.42 matthew 323:
1.648 raeburn 324: =item * &opensearcher(formname,elementname) [javascript]
1.42 matthew 325:
326: Inputs: formname, elementname
327:
328: formname and elementname specify the name of the html form and the name
329: of the element the selection from the search results will be placed in.
1.542 raeburn 330:
1.42 matthew 331: =cut
332:
333: sub browser_and_searcher_javascript {
1.199 albertel 334: my ($mode)=@_;
335: if (!defined($mode)) { $mode='edit'; }
1.453 albertel 336: my $resurl=&escape_single(&lastresurl());
1.42 matthew 337: return <<END;
1.219 albertel 338: // <!-- BEGIN LON-CAPA Internal
1.50 matthew 339: var editbrowser = null;
1.135 albertel 340: function openbrowser(formname,elementname,only,omit,titleelement) {
1.170 www 341: var url = '$resurl/?';
1.42 matthew 342: if (editbrowser == null) {
343: url += 'launch=1&';
344: }
345: url += 'catalogmode=interactive&';
1.199 albertel 346: url += 'mode=$mode&';
1.611 albertel 347: url += 'inhibitmenu=yes&';
1.42 matthew 348: url += 'form=' + formname + '&';
349: if (only != null) {
350: url += 'only=' + only + '&';
1.217 albertel 351: } else {
352: url += 'only=&';
353: }
1.42 matthew 354: if (omit != null) {
355: url += 'omit=' + omit + '&';
1.217 albertel 356: } else {
357: url += 'omit=&';
358: }
1.135 albertel 359: if (titleelement != null) {
360: url += 'titleelement=' + titleelement + '&';
1.217 albertel 361: } else {
362: url += 'titleelement=&';
363: }
1.42 matthew 364: url += 'element=' + elementname + '';
365: var title = 'Browser';
1.435 albertel 366: var options = 'scrollbars=1,resizable=1,menubar=0,toolbar=1,location=1';
1.42 matthew 367: options += ',width=700,height=600';
368: editbrowser = open(url,title,options,'1');
369: editbrowser.focus();
370: }
371: var editsearcher;
1.135 albertel 372: function opensearcher(formname,elementname,titleelement) {
1.42 matthew 373: var url = '/adm/searchcat?';
374: if (editsearcher == null) {
375: url += 'launch=1&';
376: }
377: url += 'catalogmode=interactive&';
1.199 albertel 378: url += 'mode=$mode&';
1.42 matthew 379: url += 'form=' + formname + '&';
1.135 albertel 380: if (titleelement != null) {
381: url += 'titleelement=' + titleelement + '&';
1.217 albertel 382: } else {
383: url += 'titleelement=&';
384: }
1.42 matthew 385: url += 'element=' + elementname + '';
386: var title = 'Search';
1.435 albertel 387: var options = 'scrollbars=1,resizable=1,menubar=0,toolbar=1,location=1';
1.42 matthew 388: options += ',width=700,height=600';
389: editsearcher = open(url,title,options,'1');
390: editsearcher.focus();
391: }
1.219 albertel 392: // END LON-CAPA Internal -->
1.42 matthew 393: END
1.170 www 394: }
395:
396: sub lastresurl {
1.258 albertel 397: if ($env{'environment.lastresurl'}) {
398: return $env{'environment.lastresurl'}
1.170 www 399: } else {
400: return '/res';
401: }
402: }
403:
404: sub storeresurl {
405: my $resurl=&Apache::lonnet::clutter(shift);
406: unless ($resurl=~/^\/res/) { return 0; }
407: $resurl=~s/\/$//;
408: &Apache::lonnet::put('environment',{'lastresurl' => $resurl});
1.646 raeburn 409: &Apache::lonnet::appenv({'environment.lastresurl' => $resurl});
1.170 www 410: return 1;
1.42 matthew 411: }
412:
1.74 www 413: sub studentbrowser_javascript {
1.111 www 414: unless (
1.258 albertel 415: (($env{'request.course.id'}) &&
1.302 albertel 416: (&Apache::lonnet::allowed('srm',$env{'request.course.id'})
417: || &Apache::lonnet::allowed('srm',$env{'request.course.id'}.
418: '/'.$env{'request.course.sec'})
419: ))
1.258 albertel 420: || ($env{'request.role'}=~/^(au|dc|su)/)
1.111 www 421: ) { return ''; }
1.74 www 422: return (<<'ENDSTDBRW');
423: <script type="text/javascript" language="Javascript" >
424: var stdeditbrowser;
1.558 albertel 425: function openstdbrowser(formname,uname,udom,roleflag,ignorefilter) {
1.74 www 426: var url = '/adm/pickstudent?';
427: var filter;
1.558 albertel 428: if (!ignorefilter) {
429: eval('filter=document.'+formname+'.'+uname+'.value;');
430: }
1.74 www 431: if (filter != null) {
432: if (filter != '') {
433: url += 'filter='+filter+'&';
434: }
435: }
436: url += 'form=' + formname + '&unameelement='+uname+
437: '&udomelement='+udom;
1.111 www 438: if (roleflag) { url+="&roles=1"; }
1.102 www 439: var title = 'Student_Browser';
1.74 www 440: var options = 'scrollbars=1,resizable=1,menubar=0';
441: options += ',width=700,height=600';
442: stdeditbrowser = open(url,title,options,'1');
443: stdeditbrowser.focus();
444: }
445: </script>
446: ENDSTDBRW
447: }
1.42 matthew 448:
1.74 www 449: sub selectstudent_link {
1.111 www 450: my ($form,$unameele,$udomele)=@_;
1.258 albertel 451: if ($env{'request.course.id'}) {
1.302 albertel 452: if (!&Apache::lonnet::allowed('srm',$env{'request.course.id'})
453: && !&Apache::lonnet::allowed('srm',$env{'request.course.id'}.
454: '/'.$env{'request.course.sec'})) {
1.111 www 455: return '';
456: }
457: return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele.
1.607 albertel 458: '","'.$udomele.'");'."'>".&mt('Select User')."</a>";
1.74 www 459: }
1.258 albertel 460: if ($env{'request.role'}=~/^(au|dc|su)/) {
1.111 www 461: return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele.
1.119 www 462: '","'.$udomele.'",1);'."'>".&mt('Select User')."</a>";
1.111 www 463: }
464: return '';
1.91 www 465: }
466:
1.653 raeburn 467: sub authorbrowser_javascript {
468: return <<"ENDAUTHORBRW";
469: <script type="text/javascript">
470: var stdeditbrowser;
471:
472: function openauthorbrowser(formname,udom) {
473: var url = '/adm/pickauthor?';
474: url += 'form='+formname+'&roledom='+udom;
475: var title = 'Author_Browser';
476: var options = 'scrollbars=1,resizable=1,menubar=0';
477: options += ',width=700,height=600';
478: stdeditbrowser = open(url,title,options,'1');
479: stdeditbrowser.focus();
480: }
481:
482: </script>
483: ENDAUTHORBRW
484: }
485:
1.91 www 486: sub coursebrowser_javascript {
1.468 raeburn 487: my ($domainfilter,$sec_element,$formname)=@_;
1.377 raeburn 488: 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 489: my $output = '
1.538 albertel 490: <script type="text/javascript">
1.468 raeburn 491: var stdeditbrowser;'."\n";
492: $output .= <<"ENDSTDBRW";
1.377 raeburn 493: function opencrsbrowser(formname,uname,udom,desc,extra_element,multflag,crstype) {
1.91 www 494: var url = '/adm/pickcourse?';
1.468 raeburn 495: var domainfilter = '';
496: var formid = getFormIdByName(formname);
497: if (formid > -1) {
498: var domid = getIndexByName(formid,udom);
499: if (domid > -1) {
500: if (document.forms[formid].elements[domid].type == 'select-one') {
501: domainfilter=document.forms[formid].elements[domid].options[document.forms[formid].elements[domid].selectedIndex].value;
502: }
503: if (document.forms[formid].elements[domid].type == 'hidden') {
504: domainfilter=document.forms[formid].elements[domid].value;
505: }
506: }
1.91 www 507: }
1.128 albertel 508: if (domainfilter != null) {
509: if (domainfilter != '') {
510: url += 'domainfilter='+domainfilter+'&';
511: }
512: }
1.91 www 513: url += 'form=' + formname + '&cnumelement='+uname+
1.187 albertel 514: '&cdomelement='+udom+
515: '&cnameelement='+desc;
1.468 raeburn 516: if (extra_element !=null && extra_element != '') {
1.594 raeburn 517: if (formname == 'rolechoice' || formname == 'studentform') {
1.468 raeburn 518: url += '&roleelement='+extra_element;
519: if (domainfilter == null || domainfilter == '') {
520: url += '&domainfilter='+extra_element;
521: }
1.234 raeburn 522: }
1.468 raeburn 523: else {
524: if (formname == 'portform') {
525: url += '&setroles='+extra_element;
526: }
527: }
1.230 raeburn 528: }
1.293 raeburn 529: if (multflag !=null && multflag != '') {
530: url += '&multiple='+multflag;
531: }
1.377 raeburn 532: if (crstype == 'Course/Group') {
533: if (formname == 'cu') {
534: crstype = document.cu.crstype.options[document.cu.crstype.selectedIndex].value;
535: if (crstype == "") {
536: alert("$crs_or_grp_alert");
537: return;
538: }
539: }
540: }
541: if (crstype !=null && crstype != '') {
542: url += '&type='+crstype;
543: }
1.102 www 544: var title = 'Course_Browser';
1.91 www 545: var options = 'scrollbars=1,resizable=1,menubar=0';
546: options += ',width=700,height=600';
547: stdeditbrowser = open(url,title,options,'1');
548: stdeditbrowser.focus();
549: }
1.468 raeburn 550:
551: function getFormIdByName(formname) {
552: for (var i=0;i<document.forms.length;i++) {
553: if (document.forms[i].name == formname) {
554: return i;
555: }
556: }
557: return -1;
558: }
559:
560: function getIndexByName(formid,item) {
561: for (var i=0;i<document.forms[formid].elements.length;i++) {
562: if (document.forms[formid].elements[i].name == item) {
563: return i;
564: }
565: }
566: return -1;
567: }
1.91 www 568: ENDSTDBRW
1.468 raeburn 569: if ($sec_element ne '') {
570: $output .= &setsec_javascript($sec_element,$formname);
571: }
572: $output .= '
573: </script>';
574: return $output;
575: }
576:
577: sub setsec_javascript {
578: my ($sec_element,$formname) = @_;
579: my $setsections = qq|
580: function setSect(sectionlist) {
1.629 raeburn 581: var sectionsArray = new Array();
582: if ((sectionlist != '') && (typeof sectionlist != "undefined")) {
583: sectionsArray = sectionlist.split(",");
584: }
1.468 raeburn 585: var numSections = sectionsArray.length;
586: document.$formname.$sec_element.length = 0;
587: if (numSections == 0) {
588: document.$formname.$sec_element.multiple=false;
589: document.$formname.$sec_element.size=1;
590: document.$formname.$sec_element.options[0] = new Option('No existing sections','',false,false)
591: } else {
592: if (numSections == 1) {
593: document.$formname.$sec_element.multiple=false;
594: document.$formname.$sec_element.size=1;
595: document.$formname.$sec_element.options[0] = new Option('Select','',true,true);
596: document.$formname.$sec_element.options[1] = new Option('No section','',false,false)
597: document.$formname.$sec_element.options[2] = new Option(sectionsArray[0],sectionsArray[0],false,false);
598: } else {
599: for (var i=0; i<numSections; i++) {
600: document.$formname.$sec_element.options[i] = new Option(sectionsArray[i],sectionsArray[i],false,false)
601: }
602: document.$formname.$sec_element.multiple=true
603: if (numSections < 3) {
604: document.$formname.$sec_element.size=numSections;
605: } else {
606: document.$formname.$sec_element.size=3;
607: }
608: document.$formname.$sec_element.options[0].selected = false
609: }
610: }
1.91 www 611: }
1.468 raeburn 612: |;
613: return $setsections;
614: }
615:
1.91 www 616:
617: sub selectcourse_link {
1.377 raeburn 618: my ($form,$unameele,$udomele,$desc,$extra_element,$multflag,$selecttype)=@_;
1.492 albertel 619: return "<a href='".'javascript:opencrsbrowser("'.$form.'","'.$unameele.
620: '","'.$udomele.'","'.$desc.'","'.$extra_element.'","'.$multflag.'","'.$selecttype.'");'."'>".&mt('Select Course')."</a>";
1.74 www 621: }
1.42 matthew 622:
1.653 raeburn 623: sub selectauthor_link {
624: my ($form,$udom)=@_;
625: return '<a href="javascript:openauthorbrowser('."'$form','$udom'".');">'.
626: &mt('Select Author').'</a>';
627: }
628:
1.273 raeburn 629: sub check_uncheck_jscript {
630: my $jscript = <<"ENDSCRT";
631: function checkAll(field) {
632: if (field.length > 0) {
633: for (i = 0; i < field.length; i++) {
634: field[i].checked = true ;
635: }
636: } else {
637: field.checked = true
638: }
639: }
640:
641: function uncheckAll(field) {
642: if (field.length > 0) {
643: for (i = 0; i < field.length; i++) {
644: field[i].checked = false ;
1.543 albertel 645: }
646: } else {
1.273 raeburn 647: field.checked = false ;
648: }
649: }
650: ENDSCRT
651: return $jscript;
652: }
653:
1.656 ! www 654: sub select_timezone {
! 655: my ($name,$selected,$onchange)=@_;
! 656: my $output="<select name='$name' $onchange>\n";
! 657: foreach my $key (sort(keys(%timezone))) {
! 658: $output.="<option value='$timezone{$key}'";
! 659: if ($key eq $selected) {
! 660: $output.=" selected='selected'";
! 661: }
! 662: $output.=">$timezone{$key}</option>\n";
! 663: }
! 664: $output.="</select>";
! 665: return $output;
! 666: }
1.273 raeburn 667:
1.42 matthew 668: =pod
1.36 matthew 669:
1.648 raeburn 670: =item * &linked_select_forms(...)
1.36 matthew 671:
672: linked_select_forms returns a string containing a <script></script> block
673: and html for two <select> menus. The select menus will be linked in that
674: changing the value of the first menu will result in new values being placed
675: in the second menu. The values in the select menu will appear in alphabetical
1.609 raeburn 676: order unless a defined order is provided.
1.36 matthew 677:
678: linked_select_forms takes the following ordered inputs:
679:
680: =over 4
681:
1.112 bowersj2 682: =item * $formname, the name of the <form> tag
1.36 matthew 683:
1.112 bowersj2 684: =item * $middletext, the text which appears between the <select> tags
1.36 matthew 685:
1.112 bowersj2 686: =item * $firstdefault, the default value for the first menu
1.36 matthew 687:
1.112 bowersj2 688: =item * $firstselectname, the name of the first <select> tag
1.36 matthew 689:
1.112 bowersj2 690: =item * $secondselectname, the name of the second <select> tag
1.36 matthew 691:
1.112 bowersj2 692: =item * $hashref, a reference to a hash containing the data for the menus.
1.36 matthew 693:
1.609 raeburn 694: =item * $menuorder, the order of values in the first menu
695:
1.41 ng 696: =back
697:
1.36 matthew 698: Below is an example of such a hash. Only the 'text', 'default', and
699: 'select2' keys must appear as stated. keys(%menu) are the possible
700: values for the first select menu. The text that coincides with the
1.41 ng 701: first menu value is given in $menu{$choice1}->{'text'}. The values
1.36 matthew 702: and text for the second menu are given in the hash pointed to by
703: $menu{$choice1}->{'select2'}.
704:
1.112 bowersj2 705: my %menu = ( A1 => { text =>"Choice A1" ,
706: default => "B3",
707: select2 => {
708: B1 => "Choice B1",
709: B2 => "Choice B2",
710: B3 => "Choice B3",
711: B4 => "Choice B4"
1.609 raeburn 712: },
713: order => ['B4','B3','B1','B2'],
1.112 bowersj2 714: },
715: A2 => { text =>"Choice A2" ,
716: default => "C2",
717: select2 => {
718: C1 => "Choice C1",
719: C2 => "Choice C2",
720: C3 => "Choice C3"
1.609 raeburn 721: },
722: order => ['C2','C1','C3'],
1.112 bowersj2 723: },
724: A3 => { text =>"Choice A3" ,
725: default => "D6",
726: select2 => {
727: D1 => "Choice D1",
728: D2 => "Choice D2",
729: D3 => "Choice D3",
730: D4 => "Choice D4",
731: D5 => "Choice D5",
732: D6 => "Choice D6",
733: D7 => "Choice D7"
1.609 raeburn 734: },
735: order => ['D4','D3','D2','D1','D7','D6','D5'],
1.112 bowersj2 736: }
737: );
1.36 matthew 738:
739: =cut
740:
741: sub linked_select_forms {
742: my ($formname,
743: $middletext,
744: $firstdefault,
745: $firstselectname,
746: $secondselectname,
1.609 raeburn 747: $hashref,
748: $menuorder,
1.36 matthew 749: ) = @_;
750: my $second = "document.$formname.$secondselectname";
751: my $first = "document.$formname.$firstselectname";
752: # output the javascript to do the changing
753: my $result = '';
1.219 albertel 754: $result.="<script type=\"text/javascript\">\n";
1.36 matthew 755: $result.="var select2data = new Object();\n";
756: $" = '","';
757: my $debug = '';
758: foreach my $s1 (sort(keys(%$hashref))) {
759: $result.="select2data.d_$s1 = new Object();\n";
760: $result.="select2data.d_$s1.def = new String('".
761: $hashref->{$s1}->{'default'}."');\n";
1.609 raeburn 762: $result.="select2data.d_$s1.values = new Array(";
1.36 matthew 763: my @s2values = sort(keys( %{ $hashref->{$s1}->{'select2'} } ));
1.609 raeburn 764: if (ref($hashref->{$s1}->{'order'}) eq 'ARRAY') {
765: @s2values = @{$hashref->{$s1}->{'order'}};
766: }
1.36 matthew 767: $result.="\"@s2values\");\n";
768: $result.="select2data.d_$s1.texts = new Array(";
769: my @s2texts;
770: foreach my $value (@s2values) {
771: push @s2texts, $hashref->{$s1}->{'select2'}->{$value};
772: }
773: $result.="\"@s2texts\");\n";
774: }
775: $"=' ';
776: $result.= <<"END";
777:
778: function select1_changed() {
779: // Determine new choice
780: var newvalue = "d_" + $first.value;
781: // update select2
782: var values = select2data[newvalue].values;
783: var texts = select2data[newvalue].texts;
784: var select2def = select2data[newvalue].def;
785: var i;
786: // out with the old
787: for (i = 0; i < $second.options.length; i++) {
788: $second.options[i] = null;
789: }
790: // in with the nuclear
791: for (i=0;i<values.length; i++) {
792: $second.options[i] = new Option(values[i]);
1.143 matthew 793: $second.options[i].value = values[i];
1.36 matthew 794: $second.options[i].text = texts[i];
795: if (values[i] == select2def) {
796: $second.options[i].selected = true;
797: }
798: }
799: }
800: </script>
801: END
802: # output the initial values for the selection lists
803: $result .= "<select size=\"1\" name=\"$firstselectname\" onchange=\"select1_changed()\">\n";
1.609 raeburn 804: my @order = sort(keys(%{$hashref}));
805: if (ref($menuorder) eq 'ARRAY') {
806: @order = @{$menuorder};
807: }
808: foreach my $value (@order) {
1.36 matthew 809: $result.=" <option value=\"$value\" ";
1.253 albertel 810: $result.=" selected=\"selected\" " if ($value eq $firstdefault);
1.119 www 811: $result.=">".&mt($hashref->{$value}->{'text'})."</option>\n";
1.36 matthew 812: }
813: $result .= "</select>\n";
814: my %select2 = %{$hashref->{$firstdefault}->{'select2'}};
815: $result .= $middletext;
816: $result .= "<select size=\"1\" name=\"$secondselectname\">\n";
817: my $seconddefault = $hashref->{$firstdefault}->{'default'};
1.609 raeburn 818:
819: my @secondorder = sort(keys(%select2));
820: if (ref($hashref->{$firstdefault}->{'order'}) eq 'ARRAY') {
821: @secondorder = @{$hashref->{$firstdefault}->{'order'}};
822: }
823: foreach my $value (@secondorder) {
1.36 matthew 824: $result.=" <option value=\"$value\" ";
1.253 albertel 825: $result.=" selected=\"selected\" " if ($value eq $seconddefault);
1.119 www 826: $result.=">".&mt($select2{$value})."</option>\n";
1.36 matthew 827: }
828: $result .= "</select>\n";
829: # return $debug;
830: return $result;
831: } # end of sub linked_select_forms {
832:
1.45 matthew 833: =pod
1.44 bowersj2 834:
1.648 raeburn 835: =item * &help_open_topic($topic,$text,$stayOnPage,$width,$height)
1.44 bowersj2 836:
1.112 bowersj2 837: Returns a string corresponding to an HTML link to the given help
838: $topic, where $topic corresponds to the name of a .tex file in
839: /home/httpd/html/adm/help/tex, with underscores replaced by
840: spaces.
841:
842: $text will optionally be linked to the same topic, allowing you to
843: link text in addition to the graphic. If you do not want to link
844: text, but wish to specify one of the later parameters, pass an
845: empty string.
846:
847: $stayOnPage is a value that will be interpreted as a boolean. If true,
848: the link will not open a new window. If false, the link will open
849: a new window using Javascript. (Default is false.)
850:
851: $width and $height are optional numerical parameters that will
852: override the width and height of the popped up window, which may
853: be useful for certain help topics with big pictures included.
1.44 bowersj2 854:
855: =cut
856:
857: sub help_open_topic {
1.48 bowersj2 858: my ($topic, $text, $stayOnPage, $width, $height) = @_;
859: $text = "" if (not defined $text);
1.44 bowersj2 860: $stayOnPage = 0 if (not defined $stayOnPage);
1.552 banghart 861: if ($env{'browser.interface'} eq 'textual') {
1.79 www 862: $stayOnPage=1;
863: }
1.44 bowersj2 864: $width = 350 if (not defined $width);
865: $height = 400 if (not defined $height);
866: my $filename = $topic;
867: $filename =~ s/ /_/g;
868:
1.48 bowersj2 869: my $template = "";
870: my $link;
1.572 banghart 871:
1.159 www 872: $topic=~s/\W/\_/g;
1.44 bowersj2 873:
1.572 banghart 874: if (!$stayOnPage) {
1.72 bowersj2 875: $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 876: } else {
1.48 bowersj2 877: $link = "/adm/help/${filename}.hlp";
878: }
879:
880: # Add the text
1.572 banghart 881: if ($text ne "") {
1.77 www 882: $template .=
1.572 banghart 883: "<table bgcolor='#3333AA' cellspacing='1' cellpadding='1' border='0'><tr>".
884: "<td bgcolor='#5555FF'><a target=\"_top\" href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";
1.48 bowersj2 885: }
886:
887: # Add the graphic
1.179 matthew 888: my $title = &mt('Online Help');
1.649 www 889: my $helpicon=&lonhttpdurl("/res/adm/pages/help.png");
1.48 bowersj2 890: $template .= <<"ENDTEMPLATE";
1.436 albertel 891: <a target="_top" href="$link" title="$title"><img src="$helpicon" border="0" alt="(Help: $topic)" /></a>
1.44 bowersj2 892: ENDTEMPLATE
1.78 www 893: if ($text ne '') { $template.='</td></tr></table>' };
1.44 bowersj2 894: return $template;
895:
1.106 bowersj2 896: }
897:
898: # This is a quicky function for Latex cheatsheet editing, since it
899: # appears in at least four places
900: sub helpLatexCheatsheet {
901: my $other = shift;
902: my $addOther = '';
903: if ($other) {
904: $addOther = Apache::loncommon::help_open_topic($other, shift,
905: undef, undef, 600) .
906: '</td><td>';
907: }
908: return '<table><tr><td>'.
909: $addOther .
1.636 raeburn 910: &Apache::loncommon::help_open_topic("Greek_Symbols",&mt('Greek Symbols'),
1.106 bowersj2 911: undef,undef,600)
912: .'</td><td>'.
1.636 raeburn 913: &Apache::loncommon::help_open_topic("Other_Symbols",&mt('Other Symbols'),
1.106 bowersj2 914: undef,undef,600)
915: .'</td></tr></table>';
1.172 www 916: }
917:
1.430 albertel 918: sub general_help {
919: my $helptopic='Student_Intro';
920: if ($env{'request.role'}=~/^(ca|au)/) {
921: $helptopic='Authoring_Intro';
922: } elsif ($env{'request.role'}=~/^cc/) {
923: $helptopic='Course_Coordination_Intro';
924: }
925: return $helptopic;
926: }
927:
928: sub update_help_link {
929: my ($topic,$component_help,$faq,$bug,$stayOnPage) = @_;
930: my $origurl = $ENV{'REQUEST_URI'};
931: $origurl=~s|^/~|/priv/|;
932: my $timestamp = time;
933: foreach my $datum (\$topic,\$component_help,\$faq,\$bug,\$origurl) {
934: $$datum = &escape($$datum);
935: }
936:
937: my $banner_link = "/adm/helpmenu?page=banner&topic=$topic&component_help=$component_help&faq=$faq&bug=$bug&origurl=$origurl&stamp=$timestamp&stayonpage=$stayOnPage";
938: my $output .= <<"ENDOUTPUT";
939: <script type="text/javascript">
940: banner_link = '$banner_link';
941: </script>
942: ENDOUTPUT
943: return $output;
944: }
945:
946: # now just updates the help link and generates a blue icon
1.193 raeburn 947: sub help_open_menu {
1.430 albertel 948: my ($topic,$component_help,$faq,$bug,$stayOnPage,$width,$height,$text)
1.552 banghart 949: = @_;
1.430 albertel 950: $stayOnPage = 0 if (not defined $stayOnPage);
1.572 banghart 951: # only use pop-up help (stayOnPage == 0)
1.552 banghart 952: # if environment.remote is on (using remote control UI)
1.572 banghart 953: if ($env{'browser.interface'} eq 'textual' ||
954: $env{'environment.remote'} eq 'off' ) {
1.552 banghart 955: $stayOnPage=1;
1.430 albertel 956: }
957: my $output;
958: if ($component_help) {
959: if (!$text) {
960: $output=&help_open_topic($component_help,undef,$stayOnPage,
961: $width,$height);
962: } else {
963: my $help_text;
964: $help_text=&unescape($topic);
965: $output='<table><tr><td>'.
966: &help_open_topic($component_help,$help_text,$stayOnPage,
967: $width,$height).'</td></tr></table>';
968: }
969: }
970: my $banner_link = &update_help_link($topic,$component_help,$faq,$bug,$stayOnPage);
971: return $output.$banner_link;
972: }
973:
974: sub top_nav_help {
975: my ($text) = @_;
1.436 albertel 976: $text = &mt($text);
1.572 banghart 977: my $stay_on_page =
1.436 albertel 978: ($env{'browser.interface'} eq 'textual' ||
979: $env{'environment.remote'} eq 'off' );
1.572 banghart 980: my $link = ($stay_on_page) ? "javascript:helpMenu('display')"
1.436 albertel 981: : "javascript:helpMenu('open')";
1.572 banghart 982: my $banner_link = &update_help_link(undef,undef,undef,undef,$stay_on_page);
1.436 albertel 983:
1.201 raeburn 984: my $title = &mt('Get help');
1.436 albertel 985:
986: return <<"END";
987: $banner_link
988: <a href="$link" title="$title">$text</a>
989: END
990: }
991:
992: sub help_menu_js {
993: my ($text) = @_;
994:
995: my $stayOnPage =
996: ($env{'browser.interface'} eq 'textual' ||
997: $env{'environment.remote'} eq 'off' );
998:
999: my $width = 620;
1000: my $height = 600;
1.430 albertel 1001: my $helptopic=&general_help();
1002: my $details_link = '/adm/help/'.$helptopic.'.hlp';
1.261 albertel 1003: my $nothing=&Apache::lonhtmlcommon::javascript_nothing();
1.331 albertel 1004: my $start_page =
1005: &Apache::loncommon::start_page('Help Menu', undef,
1006: {'frameset' => 1,
1007: 'js_ready' => 1,
1008: 'add_entries' => {
1009: 'border' => '0',
1.579 raeburn 1010: 'rows' => "110,*",},});
1.331 albertel 1011: my $end_page =
1012: &Apache::loncommon::end_page({'frameset' => 1,
1013: 'js_ready' => 1,});
1014:
1.436 albertel 1015: my $template .= <<"ENDTEMPLATE";
1016: <script type="text/javascript">
1.253 albertel 1017: // <!-- BEGIN LON-CAPA Internal
1018: // <![CDATA[
1.430 albertel 1019: var banner_link = '';
1.243 raeburn 1020: function helpMenu(target) {
1021: var caller = this;
1022: if (target == 'open') {
1023: var newWindow = null;
1024: try {
1.262 albertel 1025: newWindow = window.open($nothing,"helpmenu","HEIGHT=$height,WIDTH=$width,resizable=yes,scrollbars=yes" )
1.243 raeburn 1026: }
1027: catch(error) {
1028: writeHelp(caller);
1029: return;
1030: }
1031: if (newWindow) {
1032: caller = newWindow;
1033: }
1.193 raeburn 1034: }
1.243 raeburn 1035: writeHelp(caller);
1036: return;
1037: }
1038: function writeHelp(caller) {
1.430 albertel 1039: caller.document.writeln('$start_page<frame name="bannerframe" src="'+banner_link+'" /><frame name="bodyframe" src="$details_link" /> $end_page')
1.243 raeburn 1040: caller.document.close()
1041: caller.focus()
1.193 raeburn 1042: }
1.253 albertel 1043: // ]]>
1.219 albertel 1044: // END LON-CAPA Internal -->
1.436 albertel 1045: </script>
1.193 raeburn 1046: ENDTEMPLATE
1047: return $template;
1048: }
1049:
1.172 www 1050: sub help_open_bug {
1051: my ($topic, $text, $stayOnPage, $width, $height) = @_;
1.258 albertel 1052: unless ($env{'user.adv'}) { return ''; }
1.172 www 1053: unless ($Apache::lonnet::perlvar{'BugzillaHost'}) { return ''; }
1054: $text = "" if (not defined $text);
1055: $stayOnPage = 0 if (not defined $stayOnPage);
1.258 albertel 1056: if ($env{'browser.interface'} eq 'textual' ||
1057: $env{'environment.remote'} eq 'off' ) {
1.172 www 1058: $stayOnPage=1;
1059: }
1.184 albertel 1060: $width = 600 if (not defined $width);
1061: $height = 600 if (not defined $height);
1.172 www 1062:
1063: $topic=~s/\W+/\+/g;
1064: my $link='';
1065: my $template='';
1.379 albertel 1066: my $url=$Apache::lonnet::perlvar{'BugzillaHost'}.'enter_bug.cgi?product=LON-CAPA&bug_file_loc='.
1067: &escape($ENV{'REQUEST_URI'}).'&component='.$topic;
1.172 www 1068: if (!$stayOnPage)
1069: {
1070: $link = "javascript:void(open('$url', 'Bugzilla', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))";
1071: }
1072: else
1073: {
1074: $link = $url;
1075: }
1076: # Add the text
1077: if ($text ne "")
1078: {
1079: $template .=
1080: "<table bgcolor='#AA3333' cellspacing='1' cellpadding='1' border='0'><tr>".
1.436 albertel 1081: "<td bgcolor='#FF5555'><a target=\"_top\" href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";
1.172 www 1082: }
1083:
1084: # Add the graphic
1.179 matthew 1085: my $title = &mt('Report a Bug');
1.215 albertel 1086: my $bugicon=&lonhttpdurl("/adm/lonMisc/smallBug.gif");
1.172 www 1087: $template .= <<"ENDTEMPLATE";
1.436 albertel 1088: <a target="_top" href="$link" title="$title"><img src="$bugicon" border="0" alt="(Bug: $topic)" /></a>
1.172 www 1089: ENDTEMPLATE
1090: if ($text ne '') { $template.='</td></tr></table>' };
1091: return $template;
1092:
1093: }
1094:
1095: sub help_open_faq {
1096: my ($topic, $text, $stayOnPage, $width, $height) = @_;
1.258 albertel 1097: unless ($env{'user.adv'}) { return ''; }
1.172 www 1098: unless ($Apache::lonnet::perlvar{'FAQHost'}) { return ''; }
1099: $text = "" if (not defined $text);
1100: $stayOnPage = 0 if (not defined $stayOnPage);
1.258 albertel 1101: if ($env{'browser.interface'} eq 'textual' ||
1102: $env{'environment.remote'} eq 'off' ) {
1.172 www 1103: $stayOnPage=1;
1104: }
1105: $width = 350 if (not defined $width);
1106: $height = 400 if (not defined $height);
1107:
1108: $topic=~s/\W+/\+/g;
1109: my $link='';
1110: my $template='';
1111: my $url=$Apache::lonnet::perlvar{'FAQHost'}.'/fom/cache/'.$topic.'.html';
1112: if (!$stayOnPage)
1113: {
1114: $link = "javascript:void(open('$url', 'FAQ-O-Matic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))";
1115: }
1116: else
1117: {
1118: $link = $url;
1119: }
1120:
1121: # Add the text
1122: if ($text ne "")
1123: {
1124: $template .=
1.173 www 1125: "<table bgcolor='#337733' cellspacing='1' cellpadding='1' border='0'><tr>".
1.436 albertel 1126: "<td bgcolor='#448844'><a target=\"_top\" href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";
1.172 www 1127: }
1128:
1129: # Add the graphic
1.179 matthew 1130: my $title = &mt('View the FAQ');
1.215 albertel 1131: my $faqicon=&lonhttpdurl("/adm/lonMisc/smallFAQ.gif");
1.172 www 1132: $template .= <<"ENDTEMPLATE";
1.436 albertel 1133: <a target="_top" href="$link" title="$title"><img src="$faqicon" border="0" alt="(FAQ: $topic)" /></a>
1.172 www 1134: ENDTEMPLATE
1135: if ($text ne '') { $template.='</td></tr></table>' };
1136: return $template;
1137:
1.44 bowersj2 1138: }
1.37 matthew 1139:
1.180 matthew 1140: ###############################################################
1141: ###############################################################
1142:
1.45 matthew 1143: =pod
1144:
1.648 raeburn 1145: =item * &change_content_javascript():
1.256 matthew 1146:
1147: This and the next function allow you to create small sections of an
1148: otherwise static HTML page that you can update on the fly with
1149: Javascript, even in Netscape 4.
1150:
1151: The Javascript fragment returned by this function (no E<lt>scriptE<gt> tag)
1152: must be written to the HTML page once. It will prove the Javascript
1153: function "change(name, content)". Calling the change function with the
1154: name of the section
1155: you want to update, matching the name passed to C<changable_area>, and
1156: the new content you want to put in there, will put the content into
1157: that area.
1158:
1159: B<Note>: Netscape 4 only reserves enough space for the changable area
1160: to contain room for the original contents. You need to "make space"
1161: for whatever changes you wish to make, and be B<sure> to check your
1162: code in Netscape 4. This feature in Netscape 4 is B<not> powerful;
1163: it's adequate for updating a one-line status display, but little more.
1164: This script will set the space to 100% width, so you only need to
1165: worry about height in Netscape 4.
1166:
1167: Modern browsers are much less limiting, and if you can commit to the
1168: user not using Netscape 4, this feature may be used freely with
1169: pretty much any HTML.
1170:
1171: =cut
1172:
1173: sub change_content_javascript {
1174: # If we're on Netscape 4, we need to use Layer-based code
1.258 albertel 1175: if ($env{'browser.type'} eq 'netscape' &&
1176: $env{'browser.version'} =~ /^4\./) {
1.256 matthew 1177: return (<<NETSCAPE4);
1178: function change(name, content) {
1179: doc = document.layers[name+"___escape"].layers[0].document;
1180: doc.open();
1181: doc.write(content);
1182: doc.close();
1183: }
1184: NETSCAPE4
1185: } else {
1186: # Otherwise, we need to use semi-standards-compliant code
1187: # (technically, "innerHTML" isn't standard but the equivalent
1188: # is really scary, and every useful browser supports it
1189: return (<<DOMBASED);
1190: function change(name, content) {
1191: element = document.getElementById(name);
1192: element.innerHTML = content;
1193: }
1194: DOMBASED
1195: }
1196: }
1197:
1198: =pod
1199:
1.648 raeburn 1200: =item * &changable_area($name,$origContent):
1.256 matthew 1201:
1202: This provides a "changable area" that can be modified on the fly via
1203: the Javascript code provided in C<change_content_javascript>. $name is
1204: the name you will use to reference the area later; do not repeat the
1205: same name on a given HTML page more then once. $origContent is what
1206: the area will originally contain, which can be left blank.
1207:
1208: =cut
1209:
1210: sub changable_area {
1211: my ($name, $origContent) = @_;
1212:
1.258 albertel 1213: if ($env{'browser.type'} eq 'netscape' &&
1214: $env{'browser.version'} =~ /^4\./) {
1.256 matthew 1215: # If this is netscape 4, we need to use the Layer tag
1216: return "<ilayer width='100%' id='${name}___escape' overflow='none'><layer width='100%' id='$name' overflow='none'>$origContent</layer></ilayer>";
1217: } else {
1218: return "<span id='$name'>$origContent</span>";
1219: }
1220: }
1221:
1222: =pod
1223:
1.648 raeburn 1224: =item * &viewport_geometry_js
1.590 raeburn 1225:
1226: Provides javascript object (Geometry) which can provide information about the viewport geometry for the client browser.
1227:
1228: =cut
1229:
1230:
1231: sub viewport_geometry_js {
1232: return <<"GEOMETRY";
1233: var Geometry = {};
1234: function init_geometry() {
1235: if (Geometry.init) { return };
1236: Geometry.init=1;
1237: if (window.innerHeight) {
1238: Geometry.getViewportHeight = function() { return window.innerHeight; };
1239: Geometry.getViewportWidth = function() { return window.innerWidth; };
1240: Geometry.getHorizontalScroll = function() { return window.pageXOffset; };
1241: Geometry.getVerticalScroll = function() { return window.pageYOffset; };
1242: }
1243: else if (document.documentElement && document.documentElement.clientHeight) {
1244: Geometry.getViewportHeight =
1245: function() { return document.documentElement.clientHeight; };
1246: Geometry.getViewportWidth =
1247: function() { return document.documentElement.clientWidth; };
1248:
1249: Geometry.getHorizontalScroll =
1250: function() { return document.documentElement.scrollLeft; };
1251: Geometry.getVerticalScroll =
1252: function() { return document.documentElement.scrollTop; };
1253: }
1254: else if (document.body.clientHeight) {
1255: Geometry.getViewportHeight =
1256: function() { return document.body.clientHeight; };
1257: Geometry.getViewportWidth =
1258: function() { return document.body.clientWidth; };
1259: Geometry.getHorizontalScroll =
1260: function() { return document.body.scrollLeft; };
1261: Geometry.getVerticalScroll =
1262: function() { return document.body.scrollTop; };
1263: }
1264: }
1265:
1266: GEOMETRY
1267: }
1268:
1269: =pod
1270:
1.648 raeburn 1271: =item * &viewport_size_js()
1.590 raeburn 1272:
1273: 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.
1274:
1275: =cut
1276:
1277: sub viewport_size_js {
1278: my $geometry = &viewport_geometry_js();
1279: return <<"DIMS";
1280:
1281: $geometry
1282:
1283: function getViewportDims(width,height) {
1284: init_geometry();
1285: width.value = Geometry.getViewportWidth();
1286: height.value = Geometry.getViewportHeight();
1287: return;
1288: }
1289:
1290: DIMS
1291: }
1292:
1293: =pod
1294:
1.648 raeburn 1295: =item * &resize_textarea_js()
1.565 albertel 1296:
1297: emits the needed javascript to resize a textarea to be as big as possible
1298:
1299: creates a function resize_textrea that takes two IDs first should be
1300: the id of the element to resize, second should be the id of a div that
1301: surrounds everything that comes after the textarea, this routine needs
1302: to be attached to the <body> for the onload and onresize events.
1303:
1.648 raeburn 1304: =back
1.565 albertel 1305:
1306: =cut
1307:
1308: sub resize_textarea_js {
1.590 raeburn 1309: my $geometry = &viewport_geometry_js();
1.565 albertel 1310: return <<"RESIZE";
1311: <script type="text/javascript">
1.590 raeburn 1312: $geometry
1.565 albertel 1313:
1.588 albertel 1314: function getX(element) {
1315: var x = 0;
1316: while (element) {
1317: x += element.offsetLeft;
1318: element = element.offsetParent;
1319: }
1320: return x;
1321: }
1322: function getY(element) {
1323: var y = 0;
1324: while (element) {
1325: y += element.offsetTop;
1326: element = element.offsetParent;
1327: }
1328: return y;
1329: }
1330:
1331:
1.565 albertel 1332: function resize_textarea(textarea_id,bottom_id) {
1333: init_geometry();
1334: var textarea = document.getElementById(textarea_id);
1335: //alert(textarea);
1336:
1.588 albertel 1337: var textarea_top = getY(textarea);
1.565 albertel 1338: var textarea_height = textarea.offsetHeight;
1339: var bottom = document.getElementById(bottom_id);
1.588 albertel 1340: var bottom_top = getY(bottom);
1.565 albertel 1341: var bottom_height = bottom.offsetHeight;
1342: var window_height = Geometry.getViewportHeight();
1.588 albertel 1343: var fudge = 23;
1.565 albertel 1344: var new_height = window_height-fudge-textarea_top-bottom_height;
1345: if (new_height < 300) {
1346: new_height = 300;
1347: }
1348: textarea.style.height=new_height+'px';
1349: }
1350: </script>
1351: RESIZE
1352:
1353: }
1354:
1355: =pod
1356:
1.256 matthew 1357: =head1 Excel and CSV file utility routines
1358:
1359: =over 4
1360:
1361: =cut
1362:
1363: ###############################################################
1364: ###############################################################
1365:
1366: =pod
1367:
1.648 raeburn 1368: =item * &csv_translate($text)
1.37 matthew 1369:
1.185 www 1370: Translate $text to allow it to be output as a 'comma separated values'
1.37 matthew 1371: format.
1372:
1373: =cut
1374:
1.180 matthew 1375: ###############################################################
1376: ###############################################################
1.37 matthew 1377: sub csv_translate {
1378: my $text = shift;
1379: $text =~ s/\"/\"\"/g;
1.209 albertel 1380: $text =~ s/\n/ /g;
1.37 matthew 1381: return $text;
1382: }
1.180 matthew 1383:
1384: ###############################################################
1385: ###############################################################
1386:
1387: =pod
1388:
1.648 raeburn 1389: =item * &define_excel_formats()
1.180 matthew 1390:
1391: Define some commonly used Excel cell formats.
1392:
1393: Currently supported formats:
1394:
1395: =over 4
1396:
1397: =item header
1398:
1399: =item bold
1400:
1401: =item h1
1402:
1403: =item h2
1404:
1405: =item h3
1406:
1.256 matthew 1407: =item h4
1408:
1409: =item i
1410:
1.180 matthew 1411: =item date
1412:
1413: =back
1414:
1415: Inputs: $workbook
1416:
1417: Returns: $format, a hash reference.
1418:
1419: =cut
1420:
1421: ###############################################################
1422: ###############################################################
1423: sub define_excel_formats {
1424: my ($workbook) = @_;
1425: my $format;
1426: $format->{'header'} = $workbook->add_format(bold => 1,
1427: bottom => 1,
1428: align => 'center');
1429: $format->{'bold'} = $workbook->add_format(bold=>1);
1430: $format->{'h1'} = $workbook->add_format(bold=>1, size=>18);
1431: $format->{'h2'} = $workbook->add_format(bold=>1, size=>16);
1432: $format->{'h3'} = $workbook->add_format(bold=>1, size=>14);
1.255 matthew 1433: $format->{'h4'} = $workbook->add_format(bold=>1, size=>12);
1.246 matthew 1434: $format->{'i'} = $workbook->add_format(italic=>1);
1.180 matthew 1435: $format->{'date'} = $workbook->add_format(num_format=>
1.207 matthew 1436: 'mm/dd/yyyy hh:mm:ss');
1.180 matthew 1437: return $format;
1438: }
1439:
1440: ###############################################################
1441: ###############################################################
1.113 bowersj2 1442:
1443: =pod
1444:
1.648 raeburn 1445: =item * &create_workbook()
1.255 matthew 1446:
1447: Create an Excel worksheet. If it fails, output message on the
1448: request object and return undefs.
1449:
1450: Inputs: Apache request object
1451:
1452: Returns (undef) on failure,
1453: Excel worksheet object, scalar with filename, and formats
1454: from &Apache::loncommon::define_excel_formats on success
1455:
1456: =cut
1457:
1458: ###############################################################
1459: ###############################################################
1460: sub create_workbook {
1461: my ($r) = @_;
1462: #
1463: # Create the excel spreadsheet
1464: my $filename = '/prtspool/'.
1.258 albertel 1465: $env{'user.name'}.'_'.$env{'user.domain'}.'_'.
1.255 matthew 1466: time.'_'.rand(1000000000).'.xls';
1467: my $workbook = Spreadsheet::WriteExcel->new('/home/httpd'.$filename);
1468: if (! defined($workbook)) {
1469: $r->log_error("Error creating excel spreadsheet $filename: $!");
1470: $r->print('<p>'.&mt("Unable to create new Excel file. ".
1471: "This error has been logged. ".
1472: "Please alert your LON-CAPA administrator").
1473: '</p>');
1474: return (undef);
1475: }
1476: #
1477: $workbook->set_tempdir('/home/httpd/perl/tmp');
1478: #
1479: my $format = &Apache::loncommon::define_excel_formats($workbook);
1480: return ($workbook,$filename,$format);
1481: }
1482:
1483: ###############################################################
1484: ###############################################################
1485:
1486: =pod
1487:
1.648 raeburn 1488: =item * &create_text_file()
1.113 bowersj2 1489:
1.542 raeburn 1490: Create a file to write to and eventually make available to the user.
1.256 matthew 1491: If file creation fails, outputs an error message on the request object and
1492: return undefs.
1.113 bowersj2 1493:
1.256 matthew 1494: Inputs: Apache request object, and file suffix
1.113 bowersj2 1495:
1.256 matthew 1496: Returns (undef) on failure,
1497: Filehandle and filename on success.
1.113 bowersj2 1498:
1499: =cut
1500:
1.256 matthew 1501: ###############################################################
1502: ###############################################################
1503: sub create_text_file {
1504: my ($r,$suffix) = @_;
1505: if (! defined($suffix)) { $suffix = 'txt'; };
1506: my $fh;
1507: my $filename = '/prtspool/'.
1.258 albertel 1508: $env{'user.name'}.'_'.$env{'user.domain'}.'_'.
1.256 matthew 1509: time.'_'.rand(1000000000).'.'.$suffix;
1510: $fh = Apache::File->new('>/home/httpd'.$filename);
1511: if (! defined($fh)) {
1512: $r->log_error("Couldn't open $filename for output $!");
1513: $r->print("Problems occured in creating the output file. ".
1514: "This error has been logged. ".
1515: "Please alert your LON-CAPA administrator.");
1.113 bowersj2 1516: }
1.256 matthew 1517: return ($fh,$filename)
1.113 bowersj2 1518: }
1519:
1520:
1.256 matthew 1521: =pod
1.113 bowersj2 1522:
1523: =back
1524:
1525: =cut
1.37 matthew 1526:
1527: ###############################################################
1.33 matthew 1528: ## Home server <option> list generating code ##
1529: ###############################################################
1.35 matthew 1530:
1.169 www 1531: # ------------------------------------------
1532:
1533: sub domain_select {
1534: my ($name,$value,$multiple)=@_;
1535: my %domains=map {
1.514 albertel 1536: $_ => $_.' '. &Apache::lonnet::domain($_,'description')
1.512 albertel 1537: } &Apache::lonnet::all_domains();
1.169 www 1538: if ($multiple) {
1539: $domains{''}=&mt('Any domain');
1.550 albertel 1540: $domains{'select_form_order'} = [sort {lc($a) cmp lc($b) } (keys(%domains))];
1.287 albertel 1541: return &multiple_select_form($name,$value,4,\%domains);
1.169 www 1542: } else {
1.550 albertel 1543: $domains{'select_form_order'} = [sort {lc($a) cmp lc($b) } (keys(%domains))];
1.169 www 1544: return &select_form($name,$value,%domains);
1545: }
1546: }
1547:
1.282 albertel 1548: #-------------------------------------------
1549:
1550: =pod
1551:
1.519 raeburn 1552: =head1 Routines for form select boxes
1553:
1554: =over 4
1555:
1.648 raeburn 1556: =item * &multiple_select_form($name,$value,$size,$hash,$order)
1.282 albertel 1557:
1558: Returns a string containing a <select> element int multiple mode
1559:
1560:
1561: Args:
1562: $name - name of the <select> element
1.506 raeburn 1563: $value - scalar or array ref of values that should already be selected
1.282 albertel 1564: $size - number of rows long the select element is
1.283 albertel 1565: $hash - the elements should be 'option' => 'shown text'
1.282 albertel 1566: (shown text should already have been &mt())
1.506 raeburn 1567: $order - (optional) array ref of the order to show the elements in
1.283 albertel 1568:
1.282 albertel 1569: =cut
1570:
1571: #-------------------------------------------
1.169 www 1572: sub multiple_select_form {
1.284 albertel 1573: my ($name,$value,$size,$hash,$order)=@_;
1.169 www 1574: my %selected = map { $_ => 1 } ref($value)?@{$value}:($value);
1575: my $output='';
1.191 matthew 1576: if (! defined($size)) {
1577: $size = 4;
1.283 albertel 1578: if (scalar(keys(%$hash))<4) {
1579: $size = scalar(keys(%$hash));
1.191 matthew 1580: }
1581: }
1.169 www 1582: $output.="\n<select name='$name' size='$size' multiple='1'>";
1.501 banghart 1583: my @order;
1.506 raeburn 1584: if (ref($order) eq 'ARRAY') {
1585: @order = @{$order};
1586: } else {
1587: @order = sort(keys(%$hash));
1.501 banghart 1588: }
1589: if (exists($$hash{'select_form_order'})) {
1590: @order = @{$$hash{'select_form_order'}};
1591: }
1592:
1.284 albertel 1593: foreach my $key (@order) {
1.356 albertel 1594: $output.='<option value="'.&HTML::Entities::encode($key,'"<>&').'" ';
1.284 albertel 1595: $output.='selected="selected" ' if ($selected{$key});
1596: $output.='>'.$hash->{$key}."</option>\n";
1.169 www 1597: }
1598: $output.="</select>\n";
1599: return $output;
1600: }
1601:
1.88 www 1602: #-------------------------------------------
1603:
1604: =pod
1605:
1.648 raeburn 1606: =item * &select_form($defdom,$name,%hash)
1.88 www 1607:
1608: Returns a string containing a <select name='$name' size='1'> form to
1609: allow a user to select options from a hash option_name => displayed text.
1610: See lonrights.pm for an example invocation and use.
1611:
1612: =cut
1613:
1614: #-------------------------------------------
1615: sub select_form {
1616: my ($def,$name,%hash) = @_;
1617: my $selectform = "<select name=\"$name\" size=\"1\">\n";
1.128 albertel 1618: my @keys;
1619: if (exists($hash{'select_form_order'})) {
1620: @keys=@{$hash{'select_form_order'}};
1621: } else {
1622: @keys=sort(keys(%hash));
1623: }
1.356 albertel 1624: foreach my $key (@keys) {
1625: $selectform.=
1626: '<option value="'.&HTML::Entities::encode($key,'"<>&').'" '.
1627: ($key eq $def ? 'selected="selected" ' : '').
1628: ">".&mt($hash{$key})."</option>\n";
1.88 www 1629: }
1630: $selectform.="</select>";
1631: return $selectform;
1632: }
1633:
1.475 www 1634: # For display filters
1635:
1636: sub display_filter {
1637: if (!$env{'form.show'}) { $env{'form.show'}=10; }
1.477 www 1638: if (!$env{'form.displayfilter'}) { $env{'form.displayfilter'}='currentfolder'; }
1.475 www 1639: return '<nobr><label>'.&mt('Records [_1]',
1640: &Apache::lonmeta::selectbox('show',$env{'form.show'},undef,
1641: (&mt('all'),10,20,50,100,1000,10000))).
1.478 www 1642: '</label></nobr> <nobr>'.
1.475 www 1643: &mt('Filter [_1]',
1.477 www 1644: &select_form($env{'form.displayfilter'},
1645: 'displayfilter',
1646: ('currentfolder' => 'Current folder/page',
1647: 'containing' => 'Containing phrase',
1648: 'none' => 'None'))).
1.478 www 1649: '<input type="text" name="containingphrase" size="30" value="'.&HTML::Entities::encode($env{'form.containingphrase'}).'" /></nobr>';
1.475 www 1650: }
1651:
1.167 www 1652: sub gradeleveldescription {
1653: my $gradelevel=shift;
1654: my %gradelevels=(0 => 'Not specified',
1655: 1 => 'Grade 1',
1656: 2 => 'Grade 2',
1657: 3 => 'Grade 3',
1658: 4 => 'Grade 4',
1659: 5 => 'Grade 5',
1660: 6 => 'Grade 6',
1661: 7 => 'Grade 7',
1662: 8 => 'Grade 8',
1663: 9 => 'Grade 9',
1664: 10 => 'Grade 10',
1665: 11 => 'Grade 11',
1666: 12 => 'Grade 12',
1667: 13 => 'Grade 13',
1668: 14 => '100 Level',
1669: 15 => '200 Level',
1670: 16 => '300 Level',
1671: 17 => '400 Level',
1672: 18 => 'Graduate Level');
1673: return &mt($gradelevels{$gradelevel});
1674: }
1675:
1.163 www 1676: sub select_level_form {
1677: my ($deflevel,$name)=@_;
1678: unless ($deflevel) { $deflevel=0; }
1.167 www 1679: my $selectform = "<select name=\"$name\" size=\"1\">\n";
1680: for (my $i=0; $i<=18; $i++) {
1681: $selectform.="<option value=\"$i\" ".
1.253 albertel 1682: ($i==$deflevel ? 'selected="selected" ' : '').
1.167 www 1683: ">".&gradeleveldescription($i)."</option>\n";
1684: }
1685: $selectform.="</select>";
1686: return $selectform;
1.163 www 1687: }
1.167 www 1688:
1.35 matthew 1689: #-------------------------------------------
1690:
1.45 matthew 1691: =pod
1692:
1.648 raeburn 1693: =item * &select_dom_form($defdom,$name,$includeempty,$showdomdesc)
1.35 matthew 1694:
1695: Returns a string containing a <select name='$name' size='1'> form to
1696: allow a user to select the domain to preform an operation in.
1697: See loncreateuser.pm for an example invocation and use.
1698:
1.90 www 1699: If the $includeempty flag is set, it also includes an empty choice ("no domain
1700: selected");
1701:
1.563 raeburn 1702: If the $showdomdesc flag is set, the domain name is followed by the domain description.
1703:
1.35 matthew 1704: =cut
1705:
1706: #-------------------------------------------
1.34 matthew 1707: sub select_dom_form {
1.563 raeburn 1708: my ($defdom,$name,$includeempty,$showdomdesc) = @_;
1.550 albertel 1709: my @domains = sort {lc($a) cmp lc($b)} (&Apache::lonnet::all_domains());
1.90 www 1710: if ($includeempty) { @domains=('',@domains); }
1.34 matthew 1711: my $selectdomain = "<select name=\"$name\" size=\"1\">\n";
1.356 albertel 1712: foreach my $dom (@domains) {
1713: $selectdomain.="<option value=\"$dom\" ".
1.563 raeburn 1714: ($dom eq $defdom ? 'selected="selected" ' : '').'>'.$dom;
1715: if ($showdomdesc) {
1716: if ($dom ne '') {
1717: my $domdesc = &Apache::lonnet::domain($dom,'description');
1718: if ($domdesc ne '') {
1719: $selectdomain .= ' ('.$domdesc.')';
1720: }
1721: }
1722: }
1723: $selectdomain .= "</option>\n";
1.34 matthew 1724: }
1725: $selectdomain.="</select>";
1726: return $selectdomain;
1727: }
1728:
1.35 matthew 1729: #-------------------------------------------
1730:
1.45 matthew 1731: =pod
1732:
1.648 raeburn 1733: =item * &home_server_form_item($domain,$name,$defaultflag)
1.35 matthew 1734:
1.586 raeburn 1735: input: 4 arguments (two required, two optional) -
1736: $domain - domain of new user
1737: $name - name of form element
1738: $default - Value of 'default' causes a default item to be first
1739: option, and selected by default.
1740: $hide - Value of 'hide' causes hiding of the name of the server,
1741: if 1 server found, or default, if 0 found.
1.594 raeburn 1742: output: returns 2 items:
1.586 raeburn 1743: (a) form element which contains either:
1744: (i) <select name="$name">
1745: <option value="$hostid1">$hostid $servers{$hostid}</option>
1746: <option value="$hostid2">$hostid $servers{$hostid}</option>
1747: </select>
1748: form item if there are multiple library servers in $domain, or
1749: (ii) an <input type="hidden" name="$name" value="$hostid" /> form item
1750: if there is only one library server in $domain.
1751:
1752: (b) number of library servers found.
1753:
1754: See loncreateuser.pm for example of use.
1.35 matthew 1755:
1756: =cut
1757:
1758: #-------------------------------------------
1.586 raeburn 1759: sub home_server_form_item {
1760: my ($domain,$name,$default,$hide) = @_;
1.513 albertel 1761: my %servers = &Apache::lonnet::get_servers($domain,'library');
1.586 raeburn 1762: my $result;
1763: my $numlib = keys(%servers);
1764: if ($numlib > 1) {
1765: $result .= '<select name="'.$name.'" />'."\n";
1766: if ($default) {
1767: $result .= '<option value="default" selected>'.&mt('default').
1768: '</option>'."\n";
1769: }
1770: foreach my $hostid (sort(keys(%servers))) {
1771: $result.= '<option value="'.$hostid.'">'.
1772: $hostid.' '.$servers{$hostid}."</option>\n";
1773: }
1774: $result .= '</select>'."\n";
1775: } elsif ($numlib == 1) {
1776: my $hostid;
1777: foreach my $item (keys(%servers)) {
1778: $hostid = $item;
1779: }
1780: $result .= '<input type="hidden" name="'.$name.'" value="'.
1781: $hostid.'" />';
1782: if (!$hide) {
1783: $result .= $hostid.' '.$servers{$hostid};
1784: }
1785: $result .= "\n";
1786: } elsif ($default) {
1787: $result .= '<input type="hidden" name="'.$name.
1788: '" value="default" />';
1789: if (!$hide) {
1790: $result .= &mt('default');
1791: }
1792: $result .= "\n";
1.33 matthew 1793: }
1.586 raeburn 1794: return ($result,$numlib);
1.33 matthew 1795: }
1.112 bowersj2 1796:
1797: =pod
1798:
1.534 albertel 1799: =back
1800:
1.112 bowersj2 1801: =cut
1.87 matthew 1802:
1803: ###############################################################
1.112 bowersj2 1804: ## Decoding User Agent ##
1.87 matthew 1805: ###############################################################
1806:
1807: =pod
1808:
1.112 bowersj2 1809: =head1 Decoding the User Agent
1810:
1811: =over 4
1812:
1813: =item * &decode_user_agent()
1.87 matthew 1814:
1815: Inputs: $r
1816:
1817: Outputs:
1818:
1819: =over 4
1820:
1.112 bowersj2 1821: =item * $httpbrowser
1.87 matthew 1822:
1.112 bowersj2 1823: =item * $clientbrowser
1.87 matthew 1824:
1.112 bowersj2 1825: =item * $clientversion
1.87 matthew 1826:
1.112 bowersj2 1827: =item * $clientmathml
1.87 matthew 1828:
1.112 bowersj2 1829: =item * $clientunicode
1.87 matthew 1830:
1.112 bowersj2 1831: =item * $clientos
1.87 matthew 1832:
1833: =back
1834:
1.157 matthew 1835: =back
1836:
1.87 matthew 1837: =cut
1838:
1839: ###############################################################
1840: ###############################################################
1841: sub decode_user_agent {
1.247 albertel 1842: my ($r)=@_;
1.87 matthew 1843: my @browsertype=split(/\&/,$Apache::lonnet::perlvar{"lonBrowsDet"});
1844: my %mathcap=split(/\&/,$$Apache::lonnet::perlvar{"lonMathML"});
1845: my $httpbrowser=$ENV{"HTTP_USER_AGENT"};
1.247 albertel 1846: if (!$httpbrowser && $r) { $httpbrowser=$r->header_in('User-Agent'); }
1.87 matthew 1847: my $clientbrowser='unknown';
1848: my $clientversion='0';
1849: my $clientmathml='';
1850: my $clientunicode='0';
1851: for (my $i=0;$i<=$#browsertype;$i++) {
1852: my ($bname,$match,$notmatch,$vreg,$minv,$univ)=split(/\:/,$browsertype[$i]);
1853: if (($httpbrowser=~/$match/i) && ($httpbrowser!~/$notmatch/i)) {
1854: $clientbrowser=$bname;
1855: $httpbrowser=~/$vreg/i;
1856: $clientversion=$1;
1857: $clientmathml=($clientversion>=$minv);
1858: $clientunicode=($clientversion>=$univ);
1859: }
1860: }
1861: my $clientos='unknown';
1862: if (($httpbrowser=~/linux/i) ||
1863: ($httpbrowser=~/unix/i) ||
1864: ($httpbrowser=~/ux/i) ||
1865: ($httpbrowser=~/solaris/i)) { $clientos='unix'; }
1866: if (($httpbrowser=~/vax/i) ||
1867: ($httpbrowser=~/vms/i)) { $clientos='vms'; }
1868: if ($httpbrowser=~/next/i) { $clientos='next'; }
1869: if (($httpbrowser=~/mac/i) ||
1870: ($httpbrowser=~/powerpc/i)) { $clientos='mac'; }
1871: if ($httpbrowser=~/win/i) { $clientos='win'; }
1872: if ($httpbrowser=~/embed/i) { $clientos='pda'; }
1873: return ($httpbrowser,$clientbrowser,$clientversion,$clientmathml,
1874: $clientunicode,$clientos,);
1875: }
1876:
1.32 matthew 1877: ###############################################################
1878: ## Authentication changing form generation subroutines ##
1879: ###############################################################
1880: ##
1881: ## All of the authform_xxxxxxx subroutines take their inputs in a
1882: ## hash, and have reasonable default values.
1883: ##
1884: ## formname = the name given in the <form> tag.
1.35 matthew 1885: #-------------------------------------------
1886:
1.45 matthew 1887: =pod
1888:
1.112 bowersj2 1889: =head1 Authentication Routines
1890:
1891: =over 4
1892:
1.648 raeburn 1893: =item * &authform_xxxxxx()
1.35 matthew 1894:
1895: The authform_xxxxxx subroutines provide javascript and html forms which
1896: handle some of the conveniences required for authentication forms.
1897: This is not an optimal method, but it works.
1898:
1899: =over 4
1900:
1.112 bowersj2 1901: =item * authform_header
1.35 matthew 1902:
1.112 bowersj2 1903: =item * authform_authorwarning
1.35 matthew 1904:
1.112 bowersj2 1905: =item * authform_nochange
1.35 matthew 1906:
1.112 bowersj2 1907: =item * authform_kerberos
1.35 matthew 1908:
1.112 bowersj2 1909: =item * authform_internal
1.35 matthew 1910:
1.112 bowersj2 1911: =item * authform_filesystem
1.35 matthew 1912:
1913: =back
1914:
1.648 raeburn 1915: See loncreateuser.pm for invocation and use examples.
1.157 matthew 1916:
1.35 matthew 1917: =cut
1918:
1919: #-------------------------------------------
1.32 matthew 1920: sub authform_header{
1921: my %in = (
1922: formname => 'cu',
1.80 albertel 1923: kerb_def_dom => '',
1.32 matthew 1924: @_,
1925: );
1926: $in{'formname'} = 'document.' . $in{'formname'};
1927: my $result='';
1.80 albertel 1928:
1929: #---------------------------------------------- Code for upper case translation
1930: my $Javascript_toUpperCase;
1931: unless ($in{kerb_def_dom}) {
1932: $Javascript_toUpperCase =<<"END";
1933: switch (choice) {
1934: case 'krb': currentform.elements[choicearg].value =
1935: currentform.elements[choicearg].value.toUpperCase();
1936: break;
1937: default:
1938: }
1939: END
1940: } else {
1941: $Javascript_toUpperCase = "";
1942: }
1943:
1.165 raeburn 1944: my $radioval = "'nochange'";
1.591 raeburn 1945: if (defined($in{'curr_authtype'})) {
1946: if ($in{'curr_authtype'} ne '') {
1947: $radioval = "'".$in{'curr_authtype'}."arg'";
1948: }
1.174 matthew 1949: }
1.165 raeburn 1950: my $argfield = 'null';
1.591 raeburn 1951: if (defined($in{'mode'})) {
1.165 raeburn 1952: if ($in{'mode'} eq 'modifycourse') {
1.591 raeburn 1953: if (defined($in{'curr_autharg'})) {
1954: if ($in{'curr_autharg'} ne '') {
1.165 raeburn 1955: $argfield = "'$in{'curr_autharg'}'";
1956: }
1957: }
1958: }
1959: }
1960:
1.32 matthew 1961: $result.=<<"END";
1962: var current = new Object();
1.165 raeburn 1963: current.radiovalue = $radioval;
1964: current.argfield = $argfield;
1.32 matthew 1965:
1966: function changed_radio(choice,currentform) {
1967: var choicearg = choice + 'arg';
1968: // If a radio button in changed, we need to change the argfield
1969: if (current.radiovalue != choice) {
1970: current.radiovalue = choice;
1971: if (current.argfield != null) {
1972: currentform.elements[current.argfield].value = '';
1973: }
1974: if (choice == 'nochange') {
1975: current.argfield = null;
1976: } else {
1977: current.argfield = choicearg;
1978: switch(choice) {
1979: case 'krb':
1980: currentform.elements[current.argfield].value =
1981: "$in{'kerb_def_dom'}";
1982: break;
1983: default:
1984: break;
1985: }
1986: }
1987: }
1988: return;
1989: }
1.22 www 1990:
1.32 matthew 1991: function changed_text(choice,currentform) {
1992: var choicearg = choice + 'arg';
1993: if (currentform.elements[choicearg].value !='') {
1.80 albertel 1994: $Javascript_toUpperCase
1.32 matthew 1995: // clear old field
1996: if ((current.argfield != choicearg) && (current.argfield != null)) {
1997: currentform.elements[current.argfield].value = '';
1998: }
1999: current.argfield = choicearg;
2000: }
2001: set_auth_radio_buttons(choice,currentform);
2002: return;
1.20 www 2003: }
1.32 matthew 2004:
2005: function set_auth_radio_buttons(newvalue,currentform) {
2006: var i=0;
2007: while (i < currentform.login.length) {
2008: if (currentform.login[i].value == newvalue) { break; }
2009: i++;
2010: }
2011: if (i == currentform.login.length) {
2012: return;
2013: }
2014: current.radiovalue = newvalue;
2015: currentform.login[i].checked = true;
2016: return;
2017: }
2018: END
2019: return $result;
2020: }
2021:
2022: sub authform_authorwarning{
2023: my $result='';
1.144 matthew 2024: $result='<i>'.
2025: &mt('As a general rule, only authors or co-authors should be '.
2026: 'filesystem authenticated '.
2027: '(which allows access to the server filesystem).')."</i>\n";
1.32 matthew 2028: return $result;
2029: }
2030:
2031: sub authform_nochange{
2032: my %in = (
2033: formname => 'document.cu',
2034: kerb_def_dom => 'MSU.EDU',
2035: @_,
2036: );
1.586 raeburn 2037: my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'});
2038: my $result;
2039: if (keys(%can_assign) == 0) {
2040: $result = &mt('Under you current role you are not permitted to change login settings for this user');
2041: } else {
2042: $result = '<label>'.&mt('[_1] Do not change login data',
2043: '<input type="radio" name="login" value="nochange" '.
2044: 'checked="checked" onclick="'.
1.281 albertel 2045: "javascript:changed_radio('nochange',$in{'formname'});".'" />').
2046: '</label>';
1.586 raeburn 2047: }
1.32 matthew 2048: return $result;
2049: }
2050:
1.591 raeburn 2051: sub authform_kerberos {
1.32 matthew 2052: my %in = (
2053: formname => 'document.cu',
2054: kerb_def_dom => 'MSU.EDU',
1.80 albertel 2055: kerb_def_auth => 'krb4',
1.32 matthew 2056: @_,
2057: );
1.586 raeburn 2058: my ($check4,$check5,$krbcheck,$krbarg,$krbver,$result,$authtype,
2059: $autharg,$jscall);
2060: my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'});
1.80 albertel 2061: if ($in{'kerb_def_auth'} eq 'krb5') {
1.586 raeburn 2062: $check5 = ' checked="on"';
1.80 albertel 2063: } else {
1.586 raeburn 2064: $check4 = ' checked="on"';
1.80 albertel 2065: }
1.165 raeburn 2066: $krbarg = $in{'kerb_def_dom'};
1.591 raeburn 2067: if (defined($in{'curr_authtype'})) {
2068: if ($in{'curr_authtype'} eq 'krb') {
1.586 raeburn 2069: $krbcheck = ' checked="on"';
1.623 raeburn 2070: if (defined($in{'mode'})) {
2071: if ($in{'mode'} eq 'modifyuser') {
2072: $krbcheck = '';
2073: }
2074: }
1.591 raeburn 2075: if (defined($in{'curr_kerb_ver'})) {
2076: if ($in{'curr_krb_ver'} eq '5') {
2077: $check5 = ' checked="on"';
2078: $check4 = '';
2079: } else {
2080: $check4 = ' checked="on"';
2081: $check5 = '';
2082: }
1.586 raeburn 2083: }
1.591 raeburn 2084: if (defined($in{'curr_autharg'})) {
1.165 raeburn 2085: $krbarg = $in{'curr_autharg'};
2086: }
1.586 raeburn 2087: if (!$can_assign{'krb4'} && !$can_assign{'krb5'}) {
1.591 raeburn 2088: if (defined($in{'curr_autharg'})) {
1.586 raeburn 2089: $result =
2090: &mt('Currently Kerberos authenticated with domain [_1] Version [_2].',
2091: $in{'curr_autharg'},$krbver);
2092: } else {
2093: $result =
2094: &mt('Currently Kerberos authenticated, Version [_1].',$krbver);
2095: }
2096: return $result;
2097: }
2098: }
2099: } else {
2100: if ($authnum == 1) {
2101: $authtype = '<input type="hidden" name="login" value="krb">';
1.165 raeburn 2102: }
2103: }
1.586 raeburn 2104: if (!$can_assign{'krb4'} && !$can_assign{'krb5'}) {
2105: return;
1.587 raeburn 2106: } elsif ($authtype eq '') {
1.591 raeburn 2107: if (defined($in{'mode'})) {
1.587 raeburn 2108: if ($in{'mode'} eq 'modifycourse') {
2109: if ($authnum == 1) {
2110: $authtype = '<input type="hidden" name="login" value="krb">';
2111: }
2112: }
2113: }
1.586 raeburn 2114: }
2115: $jscall = "javascript:changed_radio('krb',$in{'formname'});";
2116: if ($authtype eq '') {
2117: $authtype = '<input type="radio" name="login" value="krb" '.
2118: 'onclick="'.$jscall.'" onchange="'.$jscall.'"'.
2119: $krbcheck.' />';
2120: }
2121: if (($can_assign{'krb4'} && $can_assign{'krb5'}) ||
2122: ($can_assign{'krb4'} && !$can_assign{'krb5'} &&
2123: $in{'curr_authtype'} eq 'krb5') ||
2124: (!$can_assign{'krb4'} && $can_assign{'krb5'} &&
2125: $in{'curr_authtype'} eq 'krb4')) {
2126: $result .= &mt
1.144 matthew 2127: ('[_1] Kerberos authenticated with domain [_2] '.
1.281 albertel 2128: '[_3] Version 4 [_4] Version 5 [_5]',
1.586 raeburn 2129: '<label>'.$authtype,
1.281 albertel 2130: '</label><input type="text" size="10" name="krbarg" '.
1.165 raeburn 2131: 'value="'.$krbarg.'" '.
1.144 matthew 2132: 'onchange="'.$jscall.'" />',
1.281 albertel 2133: '<label><input type="radio" name="krbver" value="4" '.$check4.' />',
2134: '</label><label><input type="radio" name="krbver" value="5" '.$check5.' />',
2135: '</label>');
1.586 raeburn 2136: } elsif ($can_assign{'krb4'}) {
2137: $result .= &mt
2138: ('[_1] Kerberos authenticated with domain [_2] '.
2139: '[_3] Version 4 [_4]',
2140: '<label>'.$authtype,
2141: '</label><input type="text" size="10" name="krbarg" '.
2142: 'value="'.$krbarg.'" '.
2143: 'onchange="'.$jscall.'" />',
2144: '<label><input type="hidden" name="krbver" value="4" />',
2145: '</label>');
2146: } elsif ($can_assign{'krb5'}) {
2147: $result .= &mt
2148: ('[_1] Kerberos authenticated with domain [_2] '.
2149: '[_3] Version 5 [_4]',
2150: '<label>'.$authtype,
2151: '</label><input type="text" size="10" name="krbarg" '.
2152: 'value="'.$krbarg.'" '.
2153: 'onchange="'.$jscall.'" />',
2154: '<label><input type="hidden" name="krbver" value="5" />',
2155: '</label>');
2156: }
1.32 matthew 2157: return $result;
2158: }
2159:
2160: sub authform_internal{
1.586 raeburn 2161: my %in = (
1.32 matthew 2162: formname => 'document.cu',
2163: kerb_def_dom => 'MSU.EDU',
2164: @_,
2165: );
1.586 raeburn 2166: my ($intcheck,$intarg,$result,$authtype,$autharg,$jscall);
2167: my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'});
1.591 raeburn 2168: if (defined($in{'curr_authtype'})) {
2169: if ($in{'curr_authtype'} eq 'int') {
1.586 raeburn 2170: if ($can_assign{'int'}) {
2171: $intcheck = 'checked="on" ';
1.623 raeburn 2172: if (defined($in{'mode'})) {
2173: if ($in{'mode'} eq 'modifyuser') {
2174: $intcheck = '';
2175: }
2176: }
1.591 raeburn 2177: if (defined($in{'curr_autharg'})) {
1.586 raeburn 2178: $intarg = $in{'curr_autharg'};
2179: }
2180: } else {
2181: $result = &mt('Currently internally authenticated.');
2182: return $result;
1.165 raeburn 2183: }
2184: }
1.586 raeburn 2185: } else {
2186: if ($authnum == 1) {
2187: $authtype = '<input type="hidden" name="login" value="int">';
2188: }
2189: }
2190: if (!$can_assign{'int'}) {
2191: return;
1.587 raeburn 2192: } elsif ($authtype eq '') {
1.591 raeburn 2193: if (defined($in{'mode'})) {
1.587 raeburn 2194: if ($in{'mode'} eq 'modifycourse') {
2195: if ($authnum == 1) {
2196: $authtype = '<input type="hidden" name="login" value="int">';
2197: }
2198: }
2199: }
1.165 raeburn 2200: }
1.586 raeburn 2201: $jscall = "javascript:changed_radio('int',$in{'formname'});";
2202: if ($authtype eq '') {
2203: $authtype = '<input type="radio" name="login" value="int" '.$intcheck.
2204: ' onchange="'.$jscall.'" onclick="'.$jscall.'" />';
2205: }
1.605 bisitz 2206: $autharg = '<input type="password" size="10" name="intarg" value="'.
1.586 raeburn 2207: $intarg.'" onchange="'.$jscall.'" />';
2208: $result = &mt
1.144 matthew 2209: ('[_1] Internally authenticated (with initial password [_2])',
1.586 raeburn 2210: '<label>'.$authtype,'</label>'.$autharg);
1.620 www 2211: $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 2212: return $result;
2213: }
2214:
2215: sub authform_local{
2216: my %in = (
2217: formname => 'document.cu',
2218: kerb_def_dom => 'MSU.EDU',
2219: @_,
2220: );
1.586 raeburn 2221: my ($loccheck,$locarg,$result,$authtype,$autharg,$jscall);
2222: my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'});
1.591 raeburn 2223: if (defined($in{'curr_authtype'})) {
2224: if ($in{'curr_authtype'} eq 'loc') {
1.586 raeburn 2225: if ($can_assign{'loc'}) {
2226: $loccheck = 'checked="on" ';
1.623 raeburn 2227: if (defined($in{'mode'})) {
2228: if ($in{'mode'} eq 'modifyuser') {
2229: $loccheck = '';
2230: }
2231: }
1.591 raeburn 2232: if (defined($in{'curr_autharg'})) {
1.586 raeburn 2233: $locarg = $in{'curr_autharg'};
2234: }
2235: } else {
2236: $result = &mt('Currently using local (institutional) authentication.');
2237: return $result;
1.165 raeburn 2238: }
2239: }
1.586 raeburn 2240: } else {
2241: if ($authnum == 1) {
2242: $authtype = '<input type="hidden" name="login" value="loc">';
2243: }
2244: }
2245: if (!$can_assign{'loc'}) {
2246: return;
1.587 raeburn 2247: } elsif ($authtype eq '') {
1.591 raeburn 2248: if (defined($in{'mode'})) {
1.587 raeburn 2249: if ($in{'mode'} eq 'modifycourse') {
2250: if ($authnum == 1) {
2251: $authtype = '<input type="hidden" name="login" value="loc">';
2252: }
2253: }
2254: }
1.165 raeburn 2255: }
1.586 raeburn 2256: $jscall = "javascript:changed_radio('loc',$in{'formname'});";
2257: if ($authtype eq '') {
2258: $authtype = '<input type="radio" name="login" value="loc" '.
2259: $loccheck.' onchange="'.$jscall.'" onclick="'.
2260: $jscall.'" />';
2261: }
2262: $autharg = '<input type="text" size="10" name="locarg" value="'.
2263: $locarg.'" onchange="'.$jscall.'" />';
2264: $result = &mt('[_1] Local Authentication with argument [_2]',
2265: '<label>'.$authtype,'</label>'.$autharg);
1.32 matthew 2266: return $result;
2267: }
2268:
2269: sub authform_filesystem{
2270: my %in = (
2271: formname => 'document.cu',
2272: kerb_def_dom => 'MSU.EDU',
2273: @_,
2274: );
1.586 raeburn 2275: my ($fsyscheck,$result,$authtype,$autharg,$jscall);
2276: my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'});
1.591 raeburn 2277: if (defined($in{'curr_authtype'})) {
2278: if ($in{'curr_authtype'} eq 'fsys') {
1.586 raeburn 2279: if ($can_assign{'fsys'}) {
2280: $fsyscheck = 'checked="on" ';
1.623 raeburn 2281: if (defined($in{'mode'})) {
2282: if ($in{'mode'} eq 'modifyuser') {
2283: $fsyscheck = '';
2284: }
2285: }
1.586 raeburn 2286: } else {
2287: $result = &mt('Currently Filesystem Authenticated.');
2288: return $result;
2289: }
2290: }
2291: } else {
2292: if ($authnum == 1) {
2293: $authtype = '<input type="hidden" name="login" value="fsys">';
2294: }
2295: }
2296: if (!$can_assign{'fsys'}) {
2297: return;
1.587 raeburn 2298: } elsif ($authtype eq '') {
1.591 raeburn 2299: if (defined($in{'mode'})) {
1.587 raeburn 2300: if ($in{'mode'} eq 'modifycourse') {
2301: if ($authnum == 1) {
2302: $authtype = '<input type="hidden" name="login" value="fsys">';
2303: }
2304: }
2305: }
1.586 raeburn 2306: }
2307: $jscall = "javascript:changed_radio('fsys',$in{'formname'});";
2308: if ($authtype eq '') {
2309: $authtype = '<input type="radio" name="login" value="fsys" '.
2310: $fsyscheck.' onchange="'.$jscall.'" onclick="'.
2311: $jscall.'" />';
2312: }
2313: $autharg = '<input type="text" size="10" name="fsysarg" value=""'.
2314: ' onchange="'.$jscall.'" />';
2315: $result = &mt
1.144 matthew 2316: ('[_1] Filesystem Authenticated (with initial password [_2])',
1.281 albertel 2317: '<label><input type="radio" name="login" value="fsys" '.
1.586 raeburn 2318: $fsyscheck.'onchange="'.$jscall.'" onclick="'.$jscall.'" />',
1.605 bisitz 2319: '</label><input type="password" size="10" name="fsysarg" value="" '.
1.144 matthew 2320: 'onchange="'.$jscall.'" />');
1.32 matthew 2321: return $result;
2322: }
2323:
1.586 raeburn 2324: sub get_assignable_auth {
2325: my ($dom) = @_;
2326: if ($dom eq '') {
2327: $dom = $env{'request.role.domain'};
2328: }
2329: my %can_assign = (
2330: krb4 => 1,
2331: krb5 => 1,
2332: int => 1,
2333: loc => 1,
2334: );
2335: my %domconfig = &Apache::lonnet::get_dom('configuration',['usercreation'],$dom);
2336: if (ref($domconfig{'usercreation'}) eq 'HASH') {
2337: if (ref($domconfig{'usercreation'}{'authtypes'}) eq 'HASH') {
2338: my $authhash = $domconfig{'usercreation'}{'authtypes'};
2339: my $context;
2340: if ($env{'request.role'} =~ /^au/) {
2341: $context = 'author';
2342: } elsif ($env{'request.role'} =~ /^dc/) {
2343: $context = 'domain';
2344: } elsif ($env{'request.course.id'}) {
2345: $context = 'course';
2346: }
2347: if ($context) {
2348: if (ref($authhash->{$context}) eq 'HASH') {
2349: %can_assign = %{$authhash->{$context}};
2350: }
2351: }
2352: }
2353: }
2354: my $authnum = 0;
2355: foreach my $key (keys(%can_assign)) {
2356: if ($can_assign{$key}) {
2357: $authnum ++;
2358: }
2359: }
2360: if ($can_assign{'krb4'} && $can_assign{'krb5'}) {
2361: $authnum --;
2362: }
2363: return ($authnum,%can_assign);
2364: }
2365:
1.80 albertel 2366: ###############################################################
2367: ## Get Kerberos Defaults for Domain ##
2368: ###############################################################
2369: ##
2370: ## Returns default kerberos version and an associated argument
2371: ## as listed in file domain.tab. If not listed, provides
2372: ## appropriate default domain and kerberos version.
2373: ##
2374: #-------------------------------------------
2375:
2376: =pod
2377:
1.648 raeburn 2378: =item * &get_kerberos_defaults()
1.80 albertel 2379:
2380: get_kerberos_defaults($target_domain) returns the default kerberos
1.641 raeburn 2381: version and domain. If not found, it defaults to version 4 and the
2382: domain of the server.
1.80 albertel 2383:
1.648 raeburn 2384: =over 4
2385:
1.80 albertel 2386: ($def_version, $def_krb_domain) = &get_kerberos_defaults($target_domain);
2387:
1.648 raeburn 2388: =back
2389:
2390: =back
2391:
1.80 albertel 2392: =cut
2393:
2394: #-------------------------------------------
2395: sub get_kerberos_defaults {
2396: my $domain=shift;
1.641 raeburn 2397: my ($krbdef,$krbdefdom);
2398: my %domdefaults = &Apache::lonnet::get_domain_defaults($domain);
2399: if (($domdefaults{'auth_def'} =~/^krb(4|5)$/) && ($domdefaults{'auth_arg_def'} ne '')) {
2400: $krbdef = $domdefaults{'auth_def'};
2401: $krbdefdom = $domdefaults{'auth_arg_def'};
2402: } else {
1.80 albertel 2403: $ENV{'SERVER_NAME'}=~/(\w+\.\w+)$/;
2404: my $krbdefdom=$1;
2405: $krbdefdom=~tr/a-z/A-Z/;
2406: $krbdef = "krb4";
2407: }
2408: return ($krbdef,$krbdefdom);
2409: }
1.112 bowersj2 2410:
1.32 matthew 2411:
1.46 matthew 2412: ###############################################################
2413: ## Thesaurus Functions ##
2414: ###############################################################
1.20 www 2415:
1.46 matthew 2416: =pod
1.20 www 2417:
1.112 bowersj2 2418: =head1 Thesaurus Functions
2419:
2420: =over 4
2421:
1.648 raeburn 2422: =item * &initialize_keywords()
1.46 matthew 2423:
2424: Initializes the package variable %Keywords if it is empty. Uses the
2425: package variable $thesaurus_db_file.
2426:
2427: =cut
2428:
2429: ###################################################
2430:
2431: sub initialize_keywords {
2432: return 1 if (scalar keys(%Keywords));
2433: # If we are here, %Keywords is empty, so fill it up
2434: # Make sure the file we need exists...
2435: if (! -e $thesaurus_db_file) {
2436: &Apache::lonnet::logthis("Attempt to access $thesaurus_db_file".
2437: " failed because it does not exist");
2438: return 0;
2439: }
2440: # Set up the hash as a database
2441: my %thesaurus_db;
2442: if (! tie(%thesaurus_db,'GDBM_File',
1.53 albertel 2443: $thesaurus_db_file,&GDBM_READER(),0640)){
1.46 matthew 2444: &Apache::lonnet::logthis("Could not tie \%thesaurus_db to ".
2445: $thesaurus_db_file);
2446: return 0;
2447: }
2448: # Get the average number of appearances of a word.
2449: my $avecount = $thesaurus_db{'average.count'};
2450: # Put keywords (those that appear > average) into %Keywords
2451: while (my ($word,$data)=each (%thesaurus_db)) {
2452: my ($count,undef) = split /:/,$data;
2453: $Keywords{$word}++ if ($count > $avecount);
2454: }
2455: untie %thesaurus_db;
2456: # Remove special values from %Keywords.
1.356 albertel 2457: foreach my $value ('total.count','average.count') {
2458: delete($Keywords{$value}) if (exists($Keywords{$value}));
1.586 raeburn 2459: }
1.46 matthew 2460: return 1;
2461: }
2462:
2463: ###################################################
2464:
2465: =pod
2466:
1.648 raeburn 2467: =item * &keyword($word)
1.46 matthew 2468:
2469: Returns true if $word is a keyword. A keyword is a word that appears more
2470: than the average number of times in the thesaurus database. Calls
2471: &initialize_keywords
2472:
2473: =cut
2474:
2475: ###################################################
1.20 www 2476:
2477: sub keyword {
1.46 matthew 2478: return if (!&initialize_keywords());
2479: my $word=lc(shift());
2480: $word=~s/\W//g;
2481: return exists($Keywords{$word});
1.20 www 2482: }
1.46 matthew 2483:
2484: ###############################################################
2485:
2486: =pod
1.20 www 2487:
1.648 raeburn 2488: =item * &get_related_words()
1.46 matthew 2489:
1.160 matthew 2490: Look up a word in the thesaurus. Takes a scalar argument and returns
1.46 matthew 2491: an array of words. If the keyword is not in the thesaurus, an empty array
2492: will be returned. The order of the words returned is determined by the
2493: database which holds them.
2494:
2495: Uses global $thesaurus_db_file.
2496:
2497: =cut
2498:
2499: ###############################################################
2500: sub get_related_words {
2501: my $keyword = shift;
2502: my %thesaurus_db;
2503: if (! -e $thesaurus_db_file) {
2504: &Apache::lonnet::logthis("Attempt to access $thesaurus_db_file ".
2505: "failed because the file does not exist");
2506: return ();
2507: }
2508: if (! tie(%thesaurus_db,'GDBM_File',
1.53 albertel 2509: $thesaurus_db_file,&GDBM_READER(),0640)){
1.46 matthew 2510: return ();
2511: }
2512: my @Words=();
1.429 www 2513: my $count=0;
1.46 matthew 2514: if (exists($thesaurus_db{$keyword})) {
1.356 albertel 2515: # The first element is the number of times
2516: # the word appears. We do not need it now.
1.429 www 2517: my (undef,@RelatedWords) = (split(/:/,$thesaurus_db{$keyword}));
2518: my (undef,$mostfrequentcount)=split(/\,/,$RelatedWords[0]);
2519: my $threshold=$mostfrequentcount/10;
2520: foreach my $possibleword (@RelatedWords) {
2521: my ($word,$wordcount)=split(/\,/,$possibleword);
2522: if ($wordcount>$threshold) {
2523: push(@Words,$word);
2524: $count++;
2525: if ($count>10) { last; }
2526: }
1.20 www 2527: }
2528: }
1.46 matthew 2529: untie %thesaurus_db;
2530: return @Words;
1.14 harris41 2531: }
1.46 matthew 2532:
1.112 bowersj2 2533: =pod
2534:
2535: =back
2536:
2537: =cut
1.61 www 2538:
2539: # -------------------------------------------------------------- Plaintext name
1.81 albertel 2540: =pod
2541:
1.112 bowersj2 2542: =head1 User Name Functions
2543:
2544: =over 4
2545:
1.648 raeburn 2546: =item * &plainname($uname,$udom,$first)
1.81 albertel 2547:
1.112 bowersj2 2548: Takes a users logon name and returns it as a string in
1.226 albertel 2549: "first middle last generation" form
2550: if $first is set to 'lastname' then it returns it as
2551: 'lastname generation, firstname middlename' if their is a lastname
1.81 albertel 2552:
2553: =cut
1.61 www 2554:
1.295 www 2555:
1.81 albertel 2556: ###############################################################
1.61 www 2557: sub plainname {
1.226 albertel 2558: my ($uname,$udom,$first)=@_;
1.537 albertel 2559: return if (!defined($uname) || !defined($udom));
1.295 www 2560: my %names=&getnames($uname,$udom);
1.226 albertel 2561: my $name=&Apache::lonnet::format_name($names{'firstname'},
2562: $names{'middlename'},
2563: $names{'lastname'},
2564: $names{'generation'},$first);
2565: $name=~s/^\s+//;
1.62 www 2566: $name=~s/\s+$//;
2567: $name=~s/\s+/ /g;
1.353 albertel 2568: if ($name !~ /\S/) { $name=$uname.':'.$udom; }
1.62 www 2569: return $name;
1.61 www 2570: }
1.66 www 2571:
2572: # -------------------------------------------------------------------- Nickname
1.81 albertel 2573: =pod
2574:
1.648 raeburn 2575: =item * &nickname($uname,$udom)
1.81 albertel 2576:
2577: Gets a users name and returns it as a string as
2578:
2579: ""nickname""
1.66 www 2580:
1.81 albertel 2581: if the user has a nickname or
2582:
2583: "first middle last generation"
2584:
2585: if the user does not
2586:
2587: =cut
1.66 www 2588:
2589: sub nickname {
2590: my ($uname,$udom)=@_;
1.537 albertel 2591: return if (!defined($uname) || !defined($udom));
1.295 www 2592: my %names=&getnames($uname,$udom);
1.68 albertel 2593: my $name=$names{'nickname'};
1.66 www 2594: if ($name) {
2595: $name='"'.$name.'"';
2596: } else {
2597: $name=$names{'firstname'}.' '.$names{'middlename'}.' '.
2598: $names{'lastname'}.' '.$names{'generation'};
2599: $name=~s/\s+$//;
2600: $name=~s/\s+/ /g;
2601: }
2602: return $name;
2603: }
2604:
1.295 www 2605: sub getnames {
2606: my ($uname,$udom)=@_;
1.537 albertel 2607: return if (!defined($uname) || !defined($udom));
1.433 albertel 2608: if ($udom eq 'public' && $uname eq 'public') {
2609: return ('lastname' => &mt('Public'));
2610: }
1.295 www 2611: my $id=$uname.':'.$udom;
2612: my ($names,$cached)=&Apache::lonnet::is_cached_new('namescache',$id);
2613: if ($cached) {
2614: return %{$names};
2615: } else {
2616: my %loadnames=&Apache::lonnet::get('environment',
2617: ['firstname','middlename','lastname','generation','nickname'],
2618: $udom,$uname);
2619: &Apache::lonnet::do_cache_new('namescache',$id,\%loadnames);
2620: return %loadnames;
2621: }
2622: }
1.61 www 2623:
1.542 raeburn 2624: # -------------------------------------------------------------------- getemails
1.648 raeburn 2625:
1.542 raeburn 2626: =pod
2627:
1.648 raeburn 2628: =item * &getemails($uname,$udom)
1.542 raeburn 2629:
2630: Gets a user's email information and returns it as a hash with keys:
2631: notification, critnotification, permanentemail
2632:
2633: For notification and critnotification, values are comma-separated lists
1.648 raeburn 2634: of e-mail addresses; for permanentemail, value is a single e-mail address.
1.542 raeburn 2635:
1.648 raeburn 2636:
1.542 raeburn 2637: =cut
2638:
1.648 raeburn 2639:
1.466 albertel 2640: sub getemails {
2641: my ($uname,$udom)=@_;
2642: if ($udom eq 'public' && $uname eq 'public') {
2643: return;
2644: }
1.467 www 2645: if (!$udom) { $udom=$env{'user.domain'}; }
2646: if (!$uname) { $uname=$env{'user.name'}; }
1.466 albertel 2647: my $id=$uname.':'.$udom;
2648: my ($names,$cached)=&Apache::lonnet::is_cached_new('emailscache',$id);
2649: if ($cached) {
2650: return %{$names};
2651: } else {
2652: my %loadnames=&Apache::lonnet::get('environment',
2653: ['notification','critnotification',
2654: 'permanentemail'],
2655: $udom,$uname);
2656: &Apache::lonnet::do_cache_new('emailscache',$id,\%loadnames);
2657: return %loadnames;
2658: }
2659: }
2660:
1.551 albertel 2661: sub flush_email_cache {
2662: my ($uname,$udom)=@_;
2663: if (!$udom) { $udom =$env{'user.domain'}; }
2664: if (!$uname) { $uname=$env{'user.name'}; }
2665: return if ($udom eq 'public' && $uname eq 'public');
2666: my $id=$uname.':'.$udom;
2667: &Apache::lonnet::devalidate_cache_new('emailscache',$id);
2668: }
2669:
1.61 www 2670: # ------------------------------------------------------------------ Screenname
1.81 albertel 2671:
2672: =pod
2673:
1.648 raeburn 2674: =item * &screenname($uname,$udom)
1.81 albertel 2675:
2676: Gets a users screenname and returns it as a string
2677:
2678: =cut
1.61 www 2679:
2680: sub screenname {
2681: my ($uname,$udom)=@_;
1.258 albertel 2682: if ($uname eq $env{'user.name'} &&
2683: $udom eq $env{'user.domain'}) {return $env{'environment.screenname'};}
1.212 albertel 2684: my %names=&Apache::lonnet::get('environment',['screenname'],$udom,$uname);
1.68 albertel 2685: return $names{'screenname'};
1.62 www 2686: }
2687:
1.212 albertel 2688:
1.62 www 2689: # ------------------------------------------------------------- Message Wrapper
2690:
2691: sub messagewrapper {
1.369 www 2692: my ($link,$username,$domain,$subject,$text)=@_;
1.62 www 2693: return
1.441 albertel 2694: '<a href="/adm/email?compose=individual&'.
2695: 'recname='.$username.'&recdom='.$domain.
2696: '&subject='.&escape($subject).'&text='.&escape($text).'" '.
1.200 matthew 2697: 'title="'.&mt('Send message').'">'.$link.'</a>';
1.74 www 2698: }
2699: # --------------------------------------------------------------- Notes Wrapper
2700:
2701: sub noteswrapper {
2702: my ($link,$un,$do)=@_;
2703: return
2704: "<a href='/adm/email?recordftf=retrieve&recname=$un&recdom=$do'>$link</a>";
1.62 www 2705: }
2706: # ------------------------------------------------------------- Aboutme Wrapper
2707:
2708: sub aboutmewrapper {
1.166 www 2709: my ($link,$username,$domain,$target)=@_;
1.447 raeburn 2710: if (!defined($username) && !defined($domain)) {
2711: return;
2712: }
1.205 www 2713: return '<a href="/adm/'.$domain.'/'.$username.'/aboutme"'.
1.454 banghart 2714: ($target?' target="$target"':'').' title="'.&mt("View this user's personal page").'">'.$link.'</a>';
1.62 www 2715: }
2716:
2717: # ------------------------------------------------------------ Syllabus Wrapper
2718:
2719:
2720: sub syllabuswrapper {
1.109 matthew 2721: my ($linktext,$coursedir,$domain,$fontcolor)=@_;
2722: if ($fontcolor) {
2723: $linktext='<font color="'.$fontcolor.'">'.$linktext.'</font>';
2724: }
1.208 matthew 2725: return qq{<a href="/public/$domain/$coursedir/syllabus">$linktext</a>};
1.61 www 2726: }
1.14 harris41 2727:
1.208 matthew 2728: sub track_student_link {
1.268 albertel 2729: my ($linktext,$sname,$sdom,$target,$start) = @_;
2730: my $link ="/adm/trackstudent?";
1.208 matthew 2731: my $title = 'View recent activity';
2732: if (defined($sname) && $sname !~ /^\s*$/ &&
2733: defined($sdom) && $sdom !~ /^\s*$/) {
1.268 albertel 2734: $link .= "selected_student=$sname:$sdom";
1.208 matthew 2735: $title .= ' of this student';
1.268 albertel 2736: }
1.208 matthew 2737: if (defined($target) && $target !~ /^\s*$/) {
2738: $target = qq{target="$target"};
2739: } else {
2740: $target = '';
2741: }
1.268 albertel 2742: if ($start) { $link.='&start='.$start; }
1.554 albertel 2743: $title = &mt($title);
2744: $linktext = &mt($linktext);
1.448 albertel 2745: return qq{<a href="$link" title="$title" $target>$linktext</a>}.
2746: &help_open_topic('View_recent_activity');
1.208 matthew 2747: }
2748:
1.508 www 2749: # ===================================================== Display a student photo
2750:
2751:
1.509 albertel 2752: sub student_image_tag {
1.508 www 2753: my ($domain,$user)=@_;
2754: my $imgsrc=&Apache::lonnet::studentphoto($domain,$user,'jpg');
2755: if (($imgsrc) && ($imgsrc ne '/adm/lonKaputt/lonlogo_broken.gif')) {
2756: return '<img src="'.$imgsrc.'" align="right" />';
2757: } else {
2758: return '';
2759: }
2760: }
2761:
1.112 bowersj2 2762: =pod
2763:
2764: =back
2765:
2766: =head1 Access .tab File Data
2767:
2768: =over 4
2769:
1.648 raeburn 2770: =item * &languageids()
1.112 bowersj2 2771:
2772: returns list of all language ids
2773:
2774: =cut
2775:
1.14 harris41 2776: sub languageids {
1.16 harris41 2777: return sort(keys(%language));
1.14 harris41 2778: }
2779:
1.112 bowersj2 2780: =pod
2781:
1.648 raeburn 2782: =item * &languagedescription()
1.112 bowersj2 2783:
2784: returns description of a specified language id
2785:
2786: =cut
2787:
1.14 harris41 2788: sub languagedescription {
1.125 www 2789: my $code=shift;
2790: return ($supported_language{$code}?'* ':'').
2791: $language{$code}.
1.126 www 2792: ($supported_language{$code}?' ('.&mt('interface available').')':'');
1.145 www 2793: }
2794:
2795: sub plainlanguagedescription {
2796: my $code=shift;
2797: return $language{$code};
2798: }
2799:
2800: sub supportedlanguagecode {
2801: my $code=shift;
2802: return $supported_language{$code};
1.97 www 2803: }
2804:
1.112 bowersj2 2805: =pod
2806:
1.648 raeburn 2807: =item * ©rightids()
1.112 bowersj2 2808:
2809: returns list of all copyrights
2810:
2811: =cut
2812:
2813: sub copyrightids {
2814: return sort(keys(%cprtag));
2815: }
2816:
2817: =pod
2818:
1.648 raeburn 2819: =item * ©rightdescription()
1.112 bowersj2 2820:
2821: returns description of a specified copyright id
2822:
2823: =cut
2824:
2825: sub copyrightdescription {
1.166 www 2826: return &mt($cprtag{shift(@_)});
1.112 bowersj2 2827: }
1.197 matthew 2828:
2829: =pod
2830:
1.648 raeburn 2831: =item * &source_copyrightids()
1.192 taceyjo1 2832:
2833: returns list of all source copyrights
2834:
2835: =cut
2836:
2837: sub source_copyrightids {
2838: return sort(keys(%scprtag));
2839: }
2840:
2841: =pod
2842:
1.648 raeburn 2843: =item * &source_copyrightdescription()
1.192 taceyjo1 2844:
2845: returns description of a specified source copyright id
2846:
2847: =cut
2848:
2849: sub source_copyrightdescription {
2850: return &mt($scprtag{shift(@_)});
2851: }
1.112 bowersj2 2852:
2853: =pod
2854:
1.648 raeburn 2855: =item * &filecategories()
1.112 bowersj2 2856:
2857: returns list of all file categories
2858:
2859: =cut
2860:
2861: sub filecategories {
2862: return sort(keys(%category_extensions));
2863: }
2864:
2865: =pod
2866:
1.648 raeburn 2867: =item * &filecategorytypes()
1.112 bowersj2 2868:
2869: returns list of file types belonging to a given file
2870: category
2871:
2872: =cut
2873:
2874: sub filecategorytypes {
1.356 albertel 2875: my ($cat) = @_;
2876: return @{$category_extensions{lc($cat)}};
1.112 bowersj2 2877: }
2878:
2879: =pod
2880:
1.648 raeburn 2881: =item * &fileembstyle()
1.112 bowersj2 2882:
2883: returns embedding style for a specified file type
2884:
2885: =cut
2886:
2887: sub fileembstyle {
2888: return $fe{lc(shift(@_))};
1.169 www 2889: }
2890:
1.351 www 2891: sub filemimetype {
2892: return $fm{lc(shift(@_))};
2893: }
2894:
1.169 www 2895:
2896: sub filecategoryselect {
2897: my ($name,$value)=@_;
1.189 matthew 2898: return &select_form($value,$name,
1.169 www 2899: '' => &mt('Any category'),
2900: map { $_,$_ } sort(keys(%category_extensions)));
1.112 bowersj2 2901: }
2902:
2903: =pod
2904:
1.648 raeburn 2905: =item * &filedescription()
1.112 bowersj2 2906:
2907: returns description for a specified file type
2908:
2909: =cut
2910:
2911: sub filedescription {
1.188 matthew 2912: my $file_description = $fd{lc(shift())};
2913: $file_description =~ s:([\[\]]):~$1:g;
2914: return &mt($file_description);
1.112 bowersj2 2915: }
2916:
2917: =pod
2918:
1.648 raeburn 2919: =item * &filedescriptionex()
1.112 bowersj2 2920:
2921: returns description for a specified file type with
2922: extra formatting
2923:
2924: =cut
2925:
2926: sub filedescriptionex {
2927: my $ex=shift;
1.188 matthew 2928: my $file_description = $fd{lc($ex)};
2929: $file_description =~ s:([\[\]]):~$1:g;
2930: return '.'.$ex.' '.&mt($file_description);
1.112 bowersj2 2931: }
2932:
2933: # End of .tab access
2934: =pod
2935:
2936: =back
2937:
2938: =cut
2939:
2940: # ------------------------------------------------------------------ File Types
2941: sub fileextensions {
2942: return sort(keys(%fe));
2943: }
2944:
1.97 www 2945: # ----------------------------------------------------------- Display Languages
2946: # returns a hash with all desired display languages
2947: #
2948:
2949: sub display_languages {
2950: my %languages=();
1.356 albertel 2951: foreach my $lang (&preferred_languages()) {
2952: $languages{$lang}=1;
1.97 www 2953: }
2954: &get_unprocessed_cgi($ENV{'QUERY_STRING'},['displaylanguage']);
1.258 albertel 2955: if ($env{'form.displaylanguage'}) {
1.356 albertel 2956: foreach my $lang (split(/\s*(\,|\;|\:)\s*/,$env{'form.displaylanguage'})) {
2957: $languages{$lang}=1;
1.97 www 2958: }
2959: }
2960: return %languages;
1.14 harris41 2961: }
2962:
1.117 www 2963: sub preferred_languages {
2964: my @languages=();
1.654 www 2965: if (($env{'request.role.adv'}) && ($env{'form.languages'})) {
2966: @languages=(@languages,split(/\s*(\,|\;|\:)\s*/,$env{'form.languages'}));
2967: }
1.258 albertel 2968: if ($env{'course.'.$env{'request.course.id'}.'.languages'}) {
1.117 www 2969: @languages=(@languages,split(/\s*(\,|\;|\:)\s*/,
1.258 albertel 2970: $env{'course.'.$env{'request.course.id'}.'.languages'}));
1.177 www 2971: }
1.654 www 2972:
1.258 albertel 2973: if ($env{'environment.languages'}) {
1.459 albertel 2974: @languages=(@languages,
2975: split(/\s*(\,|\;|\:)\s*/,$env{'environment.languages'}));
1.118 www 2976: }
1.583 albertel 2977: my $browser=$ENV{'HTTP_ACCEPT_LANGUAGE'};
1.162 www 2978: if ($browser) {
1.583 albertel 2979: my @browser =
2980: map { (split(/\s*;\s*/,$_))[0] } (split(/\s*,\s*/,$browser));
2981: push(@languages,@browser);
1.162 www 2982: }
1.641 raeburn 2983:
2984: foreach my $domtype ($env{'user.domain'},$env{'request.role.domain'},
2985: $Apache::lonnet::perlvar{'lonDefDomain'}) {
2986: if ($domtype ne '') {
2987: my %domdefs = &Apache::lonnet::get_domain_defaults($domtype);
2988: if ($domdefs{'lang_def'} ne '') {
2989: push(@languages,$domdefs{'lang_def'});
2990: }
2991: }
1.118 www 2992: }
2993: # turn "en-ca" into "en-ca,en"
2994: my @genlanguages;
1.356 albertel 2995: foreach my $lang (@languages) {
2996: unless ($lang=~/\w/) { next; }
1.583 albertel 2997: push(@genlanguages,$lang);
1.356 albertel 2998: if ($lang=~/(\-|\_)/) {
2999: push(@genlanguages,(split(/(\-|\_)/,$lang))[0]);
1.118 www 3000: }
3001: }
1.583 albertel 3002: #uniqueify the languages list
3003: my %count;
3004: @genlanguages = map { $count{$_}++ == 0 ? $_ : () } @genlanguages;
1.118 www 3005: return @genlanguages;
1.117 www 3006: }
3007:
1.582 albertel 3008: sub languages {
3009: my ($possible_langs) = @_;
3010: my @preferred_langs = &preferred_languages();
3011: if (!ref($possible_langs)) {
3012: if( wantarray ) {
3013: return @preferred_langs;
3014: } else {
3015: return $preferred_langs[0];
3016: }
3017: }
3018: my %possibilities = map { $_ => 1 } (@$possible_langs);
3019: my @preferred_possibilities;
3020: foreach my $preferred_lang (@preferred_langs) {
3021: if (exists($possibilities{$preferred_lang})) {
3022: push(@preferred_possibilities, $preferred_lang);
3023: }
3024: }
3025: if( wantarray ) {
3026: return @preferred_possibilities;
3027: }
3028: return $preferred_possibilities[0];
3029: }
3030:
1.112 bowersj2 3031: ###############################################################
3032: ## Student Answer Attempts ##
3033: ###############################################################
3034:
3035: =pod
3036:
3037: =head1 Alternate Problem Views
3038:
3039: =over 4
3040:
1.648 raeburn 3041: =item * &get_previous_attempt($symb, $username, $domain, $course,
1.112 bowersj2 3042: $getattempt, $regexp, $gradesub)
3043:
3044: Return string with previous attempt on problem. Arguments:
3045:
3046: =over 4
3047:
3048: =item * $symb: Problem, including path
3049:
3050: =item * $username: username of the desired student
3051:
3052: =item * $domain: domain of the desired student
1.14 harris41 3053:
1.112 bowersj2 3054: =item * $course: Course ID
1.14 harris41 3055:
1.112 bowersj2 3056: =item * $getattempt: Leave blank for all attempts, otherwise put
3057: something
1.14 harris41 3058:
1.112 bowersj2 3059: =item * $regexp: if string matches this regexp, the string will be
3060: sent to $gradesub
1.14 harris41 3061:
1.112 bowersj2 3062: =item * $gradesub: routine that processes the string if it matches $regexp
1.14 harris41 3063:
1.112 bowersj2 3064: =back
1.14 harris41 3065:
1.112 bowersj2 3066: The output string is a table containing all desired attempts, if any.
1.16 harris41 3067:
1.112 bowersj2 3068: =cut
1.1 albertel 3069:
3070: sub get_previous_attempt {
1.43 ng 3071: my ($symb,$username,$domain,$course,$getattempt,$regexp,$gradesub)=@_;
1.1 albertel 3072: my $prevattempts='';
1.43 ng 3073: no strict 'refs';
1.1 albertel 3074: if ($symb) {
1.3 albertel 3075: my (%returnhash)=
3076: &Apache::lonnet::restore($symb,$course,$domain,$username);
1.1 albertel 3077: if ($returnhash{'version'}) {
3078: my %lasthash=();
3079: my $version;
3080: for ($version=1;$version<=$returnhash{'version'};$version++) {
1.356 albertel 3081: foreach my $key (sort(split(/\:/,$returnhash{$version.':keys'}))) {
3082: $lasthash{$key}=$returnhash{$version.':'.$key};
1.19 harris41 3083: }
1.1 albertel 3084: }
1.596 albertel 3085: $prevattempts=&start_data_table().&start_data_table_header_row();
3086: $prevattempts.='<th>'.&mt('History').'</th>';
1.356 albertel 3087: foreach my $key (sort(keys(%lasthash))) {
3088: my ($ign,@parts) = split(/\./,$key);
1.41 ng 3089: if ($#parts > 0) {
1.31 albertel 3090: my $data=$parts[-1];
3091: pop(@parts);
1.596 albertel 3092: $prevattempts.='<th>'.&mt('Part ').join('.',@parts).'<br />'.$data.' </th>';
1.31 albertel 3093: } else {
1.41 ng 3094: if ($#parts == 0) {
3095: $prevattempts.='<th>'.$parts[0].'</th>';
3096: } else {
3097: $prevattempts.='<th>'.$ign.'</th>';
3098: }
1.31 albertel 3099: }
1.16 harris41 3100: }
1.596 albertel 3101: $prevattempts.=&end_data_table_header_row();
1.40 ng 3102: if ($getattempt eq '') {
3103: for ($version=1;$version<=$returnhash{'version'};$version++) {
1.596 albertel 3104: $prevattempts.=&start_data_table_row().
3105: '<td>'.&mt('Transaction [_1]',$version).'</td>';
1.356 albertel 3106: foreach my $key (sort(keys(%lasthash))) {
1.581 albertel 3107: my $value = &format_previous_attempt_value($key,
3108: $returnhash{$version.':'.$key});
3109: $prevattempts.='<td>'.$value.' </td>';
1.40 ng 3110: }
1.596 albertel 3111: $prevattempts.=&end_data_table_row();
1.40 ng 3112: }
1.1 albertel 3113: }
1.596 albertel 3114: $prevattempts.=&start_data_table_row().'<td>'.&mt('Current').'</td>';
1.356 albertel 3115: foreach my $key (sort(keys(%lasthash))) {
1.581 albertel 3116: my $value = &format_previous_attempt_value($key,$lasthash{$key});
1.356 albertel 3117: if ($key =~/$regexp$/ && (defined &$gradesub)) {$value = &$gradesub($value)}
1.40 ng 3118: $prevattempts.='<td>'.$value.' </td>';
1.16 harris41 3119: }
1.596 albertel 3120: $prevattempts.= &end_data_table_row().&end_data_table();
1.1 albertel 3121: } else {
1.596 albertel 3122: $prevattempts=
3123: &start_data_table().&start_data_table_row().
3124: '<td>'.&mt('Nothing submitted - no attempts.').'</td>'.
3125: &end_data_table_row().&end_data_table();
1.1 albertel 3126: }
3127: } else {
1.596 albertel 3128: $prevattempts=
3129: &start_data_table().&start_data_table_row().
3130: '<td>'.&mt('No data.').'</td>'.
3131: &end_data_table_row().&end_data_table();
1.1 albertel 3132: }
1.10 albertel 3133: }
3134:
1.581 albertel 3135: sub format_previous_attempt_value {
3136: my ($key,$value) = @_;
3137: if ($key =~ /timestamp/) {
3138: $value = &Apache::lonlocal::locallocaltime($value);
3139: } elsif (ref($value) eq 'ARRAY') {
3140: $value = '('.join(', ', @{ $value }).')';
3141: } else {
3142: $value = &unescape($value);
3143: }
3144: return $value;
3145: }
3146:
3147:
1.107 albertel 3148: sub relative_to_absolute {
3149: my ($url,$output)=@_;
3150: my $parser=HTML::TokeParser->new(\$output);
3151: my $token;
3152: my $thisdir=$url;
3153: my @rlinks=();
3154: while ($token=$parser->get_token) {
3155: if ($token->[0] eq 'S') {
3156: if ($token->[1] eq 'a') {
3157: if ($token->[2]->{'href'}) {
3158: $rlinks[$#rlinks+1]=$token->[2]->{'href'};
3159: }
3160: } elsif ($token->[1] eq 'img' || $token->[1] eq 'embed' ) {
3161: $rlinks[$#rlinks+1]=$token->[2]->{'src'};
3162: } elsif ($token->[1] eq 'base') {
3163: $thisdir=$token->[2]->{'href'};
3164: }
3165: }
3166: }
3167: $thisdir=~s-/[^/]*$--;
1.356 albertel 3168: foreach my $link (@rlinks) {
3169: unless (($link=~/^http:\/\//i) ||
3170: ($link=~/^\//) ||
3171: ($link=~/^javascript:/i) ||
3172: ($link=~/^mailto:/i) ||
3173: ($link=~/^\#/)) {
3174: my $newlocation=&Apache::lonnet::hreflocation($thisdir,$link);
3175: $output=~s/(\"|\'|\=\s*)\Q$link\E(\"|\'|\s|\>)/$1$newlocation$2/;
1.107 albertel 3176: }
3177: }
3178: # -------------------------------------------------- Deal with Applet codebases
3179: $output=~s/(\<applet[^\>]+)(codebase\=[^\S\>]+)*([^\>]*)\>/$1.($2?$2:' codebase="'.$thisdir.'"').$3.'>'/gei;
3180: return $output;
3181: }
3182:
1.112 bowersj2 3183: =pod
3184:
1.648 raeburn 3185: =item * &get_student_view()
1.112 bowersj2 3186:
3187: show a snapshot of what student was looking at
3188:
3189: =cut
3190:
1.10 albertel 3191: sub get_student_view {
1.186 albertel 3192: my ($symb,$username,$domain,$courseid,$target,$moreenv) = @_;
1.114 www 3193: my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb);
1.186 albertel 3194: my (%form);
1.10 albertel 3195: my @elements=('symb','courseid','domain','username');
3196: foreach my $element (@elements) {
1.186 albertel 3197: $form{'grade_'.$element}=eval '$'.$element #'
1.10 albertel 3198: }
1.186 albertel 3199: if (defined($moreenv)) {
3200: %form=(%form,%{$moreenv});
3201: }
1.236 albertel 3202: if (defined($target)) { $form{'grade_target'} = $target; }
1.107 albertel 3203: $feedurl=&Apache::lonnet::clutter($feedurl);
1.650 www 3204: my ($userview,$response)=&Apache::lonnet::ssi_body($feedurl,%form);
1.11 albertel 3205: $userview=~s/\<body[^\>]*\>//gi;
3206: $userview=~s/\<\/body\>//gi;
3207: $userview=~s/\<html\>//gi;
3208: $userview=~s/\<\/html\>//gi;
3209: $userview=~s/\<head\>//gi;
3210: $userview=~s/\<\/head\>//gi;
3211: $userview=~s/action\s*\=/would_be_action\=/gi;
1.107 albertel 3212: $userview=&relative_to_absolute($feedurl,$userview);
1.650 www 3213: if (wantarray) {
3214: return ($userview,$response);
3215: } else {
3216: return $userview;
3217: }
3218: }
3219:
3220: sub get_student_view_with_retries {
3221: my ($symb,$retries,$username,$domain,$courseid,$target,$moreenv) = @_;
3222:
3223: my $ok = 0; # True if we got a good response.
3224: my $content;
3225: my $response;
3226:
3227: # Try to get the student_view done. within the retries count:
3228:
3229: do {
3230: ($content, $response) = &get_student_view($symb,$username,$domain,$courseid,$target,$moreenv);
3231: $ok = $response->is_success;
3232: if (!$ok) {
3233: &Apache::lonnet::logthis("Failed get_student_view_with_retries on $symb: ".$response->is_success.', '.$response->code.', '.$response->message);
3234: }
3235: $retries--;
3236: } while (!$ok && ($retries > 0));
3237:
3238: if (!$ok) {
3239: $content = ''; # On error return an empty content.
3240: }
1.651 www 3241: if (wantarray) {
3242: return ($content, $response);
3243: } else {
3244: return $content;
3245: }
1.11 albertel 3246: }
3247:
1.112 bowersj2 3248: =pod
3249:
1.648 raeburn 3250: =item * &get_student_answers()
1.112 bowersj2 3251:
3252: show a snapshot of how student was answering problem
3253:
3254: =cut
3255:
1.11 albertel 3256: sub get_student_answers {
1.100 sakharuk 3257: my ($symb,$username,$domain,$courseid,%form) = @_;
1.114 www 3258: my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb);
1.186 albertel 3259: my (%moreenv);
1.11 albertel 3260: my @elements=('symb','courseid','domain','username');
3261: foreach my $element (@elements) {
1.186 albertel 3262: $moreenv{'grade_'.$element}=eval '$'.$element #'
1.10 albertel 3263: }
1.186 albertel 3264: $moreenv{'grade_target'}='answer';
3265: %moreenv=(%form,%moreenv);
1.497 raeburn 3266: $feedurl = &Apache::lonnet::clutter($feedurl);
3267: my $userview=&Apache::lonnet::ssi($feedurl,%moreenv);
1.10 albertel 3268: return $userview;
1.1 albertel 3269: }
1.116 albertel 3270:
3271: =pod
3272:
3273: =item * &submlink()
3274:
1.242 albertel 3275: Inputs: $text $uname $udom $symb $target
1.116 albertel 3276:
3277: Returns: A link to grades.pm such as to see the SUBM view of a student
3278:
3279: =cut
3280:
3281: ###############################################
3282: sub submlink {
1.242 albertel 3283: my ($text,$uname,$udom,$symb,$target)=@_;
1.116 albertel 3284: if (!($uname && $udom)) {
3285: (my $cursymb, my $courseid,$udom,$uname)=
1.463 albertel 3286: &Apache::lonnet::whichuser($symb);
1.116 albertel 3287: if (!$symb) { $symb=$cursymb; }
3288: }
1.254 matthew 3289: if (!$symb) { $symb=&Apache::lonnet::symbread(); }
1.369 www 3290: $symb=&escape($symb);
1.242 albertel 3291: if ($target) { $target="target=\"$target\""; }
3292: return '<a href="/adm/grades?&command=submission&'.
3293: 'symb='.$symb.'&student='.$uname.
3294: '&userdom='.$udom.'" '.$target.'>'.$text.'</a>';
3295: }
3296: ##############################################
3297:
3298: =pod
3299:
3300: =item * &pgrdlink()
3301:
3302: Inputs: $text $uname $udom $symb $target
3303:
3304: Returns: A link to grades.pm such as to see the PGRD view of a student
3305:
3306: =cut
3307:
3308: ###############################################
3309: sub pgrdlink {
3310: my $link=&submlink(@_);
3311: $link=~s/(&command=submission)/$1&showgrading=yes/;
3312: return $link;
3313: }
3314: ##############################################
3315:
3316: =pod
3317:
3318: =item * &pprmlink()
3319:
3320: Inputs: $text $uname $udom $symb $target
3321:
3322: Returns: A link to parmset.pm such as to see the PPRM view of a
1.283 albertel 3323: student and a specific resource
1.242 albertel 3324:
3325: =cut
3326:
3327: ###############################################
3328: sub pprmlink {
3329: my ($text,$uname,$udom,$symb,$target)=@_;
3330: if (!($uname && $udom)) {
3331: (my $cursymb, my $courseid,$udom,$uname)=
1.463 albertel 3332: &Apache::lonnet::whichuser($symb);
1.242 albertel 3333: if (!$symb) { $symb=$cursymb; }
3334: }
1.254 matthew 3335: if (!$symb) { $symb=&Apache::lonnet::symbread(); }
1.369 www 3336: $symb=&escape($symb);
1.242 albertel 3337: if ($target) { $target="target=\"$target\""; }
1.595 albertel 3338: return '<a href="/adm/parmset?command=set&'.
3339: 'symb='.$symb.'&uname='.$uname.
3340: '&udom='.$udom.'" '.$target.'>'.$text.'</a>';
1.116 albertel 3341: }
3342: ##############################################
1.37 matthew 3343:
1.112 bowersj2 3344: =pod
3345:
3346: =back
3347:
3348: =cut
3349:
1.37 matthew 3350: ###############################################
1.51 www 3351:
3352:
3353: sub timehash {
3354: my @ltime=localtime(shift);
3355: return ( 'seconds' => $ltime[0],
3356: 'minutes' => $ltime[1],
3357: 'hours' => $ltime[2],
3358: 'day' => $ltime[3],
3359: 'month' => $ltime[4]+1,
3360: 'year' => $ltime[5]+1900,
3361: 'weekday' => $ltime[6],
3362: 'dayyear' => $ltime[7]+1,
3363: 'dlsav' => $ltime[8] );
3364: }
3365:
1.370 www 3366: sub utc_string {
3367: my ($date)=@_;
1.371 www 3368: return strftime("%Y%m%dT%H%M%SZ",gmtime($date));
1.370 www 3369: }
3370:
1.51 www 3371: sub maketime {
3372: my %th=@_;
3373: return POSIX::mktime(
3374: ($th{'seconds'},$th{'minutes'},$th{'hours'},
1.210 www 3375: $th{'day'},$th{'month'}-1,$th{'year'}-1900,0,0,-1));
1.70 www 3376: }
3377:
3378: #########################################
1.51 www 3379:
3380: sub findallcourses {
1.482 raeburn 3381: my ($roles,$uname,$udom) = @_;
1.355 albertel 3382: my %roles;
3383: if (ref($roles)) { %roles = map { $_ => 1 } @{$roles}; }
1.348 albertel 3384: my %courses;
1.51 www 3385: my $now=time;
1.482 raeburn 3386: if (!defined($uname)) {
3387: $uname = $env{'user.name'};
3388: }
3389: if (!defined($udom)) {
3390: $udom = $env{'user.domain'};
3391: }
3392: if (($uname ne $env{'user.name'}) || ($udom ne $env{'user.domain'})) {
3393: my %roleshash = &Apache::lonnet::dump('roles',$udom,$uname);
3394: if (!%roles) {
3395: %roles = (
3396: cc => 1,
3397: in => 1,
3398: ep => 1,
3399: ta => 1,
3400: cr => 1,
3401: st => 1,
3402: );
3403: }
3404: foreach my $entry (keys(%roleshash)) {
3405: my ($trole,$tend,$tstart) = split(/_/,$roleshash{$entry});
3406: if ($trole =~ /^cr/) {
3407: next if (!exists($roles{$trole}) && !exists($roles{'cr'}));
3408: } else {
3409: next if (!exists($roles{$trole}));
3410: }
3411: if ($tend) {
3412: next if ($tend < $now);
3413: }
3414: if ($tstart) {
3415: next if ($tstart > $now);
3416: }
3417: my ($cdom,$cnum,$sec,$cnumpart,$secpart,$role,$realsec);
3418: (undef,$cdom,$cnumpart,$secpart) = split(/\//,$entry);
3419: if ($secpart eq '') {
3420: ($cnum,$role) = split(/_/,$cnumpart);
3421: $sec = 'none';
3422: $realsec = '';
3423: } else {
3424: $cnum = $cnumpart;
3425: ($sec,$role) = split(/_/,$secpart);
3426: $realsec = $sec;
1.490 raeburn 3427: }
1.482 raeburn 3428: $courses{$cdom.'_'.$cnum}{$sec} = $trole.'/'.$cdom.'/'.$cnum.'/'.$realsec;
3429: }
3430: } else {
3431: foreach my $key (keys(%env)) {
1.483 albertel 3432: if ( $key=~m{^user\.role\.(\w+)\./($match_domain)/($match_courseid)/?(\w*)$} ||
3433: $key=~m{^user\.role\.(cr/$match_domain/$match_username/\w+)\./($match_domain)/($match_courseid)/?(\w*)$}) {
1.482 raeburn 3434: my ($role,$cdom,$cnum,$sec) = ($1,$2,$3,$4);
3435: next if ($role eq 'ca' || $role eq 'aa');
3436: next if (%roles && !exists($roles{$role}));
3437: my ($starttime,$endtime)=split(/\./,$env{$key});
3438: my $active=1;
3439: if ($starttime) {
3440: if ($now<$starttime) { $active=0; }
3441: }
3442: if ($endtime) {
3443: if ($now>$endtime) { $active=0; }
3444: }
3445: if ($active) {
3446: if ($sec eq '') {
3447: $sec = 'none';
3448: }
3449: $courses{$cdom.'_'.$cnum}{$sec} =
3450: $role.'/'.$cdom.'/'.$cnum.'/'.$sec;
1.474 raeburn 3451: }
3452: }
1.51 www 3453: }
3454: }
1.474 raeburn 3455: return %courses;
1.51 www 3456: }
1.37 matthew 3457:
1.54 www 3458: ###############################################
1.474 raeburn 3459:
3460: sub blockcheck {
1.482 raeburn 3461: my ($setters,$activity,$uname,$udom) = @_;
1.490 raeburn 3462:
3463: if (!defined($udom)) {
3464: $udom = $env{'user.domain'};
3465: }
3466: if (!defined($uname)) {
3467: $uname = $env{'user.name'};
3468: }
3469:
3470: # If uname and udom are for a course, check for blocks in the course.
3471:
3472: if (&Apache::lonnet::is_course($udom,$uname)) {
3473: my %records = &Apache::lonnet::dump('comm_block',$udom,$uname);
1.502 raeburn 3474: my ($startblock,$endblock)=&get_blocks($setters,$activity,$udom,$uname);
1.490 raeburn 3475: return ($startblock,$endblock);
3476: }
1.474 raeburn 3477:
1.502 raeburn 3478: my $startblock = 0;
3479: my $endblock = 0;
1.482 raeburn 3480: my %live_courses = &findallcourses(undef,$uname,$udom);
1.474 raeburn 3481:
1.490 raeburn 3482: # If uname is for a user, and activity is course-specific, i.e.,
3483: # boards, chat or groups, check for blocking in current course only.
1.474 raeburn 3484:
1.490 raeburn 3485: if (($activity eq 'boards' || $activity eq 'chat' ||
3486: $activity eq 'groups') && ($env{'request.course.id'})) {
3487: foreach my $key (keys(%live_courses)) {
3488: if ($key ne $env{'request.course.id'}) {
3489: delete($live_courses{$key});
3490: }
3491: }
3492: }
3493:
3494: my $otheruser = 0;
3495: my %own_courses;
3496: if ((($uname ne $env{'user.name'})) || ($udom ne $env{'user.domain'})) {
3497: # Resource belongs to user other than current user.
3498: $otheruser = 1;
3499: # Gather courses for current user
3500: %own_courses =
3501: &findallcourses(undef,$env{'user.name'},$env{'user.domain'});
3502: }
3503:
3504: # Gather active course roles - course coordinator, instructor,
3505: # exam proctor, ta, student, or custom role.
1.474 raeburn 3506:
3507: foreach my $course (keys(%live_courses)) {
1.482 raeburn 3508: my ($cdom,$cnum);
3509: if ((defined($env{'course.'.$course.'.domain'})) && (defined($env{'course.'.$course.'.num'}))) {
3510: $cdom = $env{'course.'.$course.'.domain'};
3511: $cnum = $env{'course.'.$course.'.num'};
3512: } else {
1.490 raeburn 3513: ($cdom,$cnum) = split(/_/,$course);
1.482 raeburn 3514: }
3515: my $no_ownblock = 0;
3516: my $no_userblock = 0;
1.533 raeburn 3517: if ($otheruser && $activity ne 'com') {
1.490 raeburn 3518: # Check if current user has 'evb' priv for this
3519: if (defined($own_courses{$course})) {
3520: foreach my $sec (keys(%{$own_courses{$course}})) {
3521: my $checkrole = 'cm./'.$cdom.'/'.$cnum;
3522: if ($sec ne 'none') {
3523: $checkrole .= '/'.$sec;
3524: }
3525: if (&Apache::lonnet::allowed('evb',undef,undef,$checkrole)) {
3526: $no_ownblock = 1;
3527: last;
3528: }
3529: }
3530: }
3531: # if they have 'evb' priv and are currently not playing student
3532: next if (($no_ownblock) &&
3533: ($env{'request.role'} !~ m{^st\./$cdom/$cnum}));
3534: }
1.474 raeburn 3535: foreach my $sec (keys(%{$live_courses{$course}})) {
1.482 raeburn 3536: my $checkrole = 'cm./'.$cdom.'/'.$cnum;
1.474 raeburn 3537: if ($sec ne 'none') {
1.482 raeburn 3538: $checkrole .= '/'.$sec;
1.474 raeburn 3539: }
1.490 raeburn 3540: if ($otheruser) {
3541: # Resource belongs to user other than current user.
3542: # Assemble privs for that user, and check for 'evb' priv.
1.482 raeburn 3543: my ($trole,$tdom,$tnum,$tsec);
3544: my $entry = $live_courses{$course}{$sec};
3545: if ($entry =~ /^cr/) {
3546: ($trole,$tdom,$tnum,$tsec) =
3547: ($entry =~ m|^(cr/$match_domain/$match_username/\w+)\./($match_domain)/($match_username)/?(\w*)$|);
3548: } else {
3549: ($trole,$tdom,$tnum,$tsec) = split(/\//,$entry);
3550: }
3551: my ($spec,$area,$trest,%allroles,%userroles);
3552: $area = '/'.$tdom.'/'.$tnum;
3553: $trest = $tnum;
3554: if ($tsec ne '') {
3555: $area .= '/'.$tsec;
3556: $trest .= '/'.$tsec;
3557: }
3558: $spec = $trole.'.'.$area;
3559: if ($trole =~ /^cr/) {
3560: &Apache::lonnet::custom_roleprivs(\%allroles,$trole,
3561: $tdom,$spec,$trest,$area);
3562: } else {
3563: &Apache::lonnet::standard_roleprivs(\%allroles,$trole,
3564: $tdom,$spec,$trest,$area);
3565: }
3566: my ($author,$adv) = &Apache::lonnet::set_userprivs(\%userroles,\%allroles);
1.486 raeburn 3567: if ($userroles{'user.priv.'.$checkrole} =~ /evb\&([^\:]*)/) {
3568: if ($1) {
3569: $no_userblock = 1;
3570: last;
3571: }
3572: }
1.490 raeburn 3573: } else {
3574: # Resource belongs to current user
3575: # Check for 'evb' priv via lonnet::allowed().
1.482 raeburn 3576: if (&Apache::lonnet::allowed('evb',undef,undef,$checkrole)) {
3577: $no_ownblock = 1;
3578: last;
3579: }
1.474 raeburn 3580: }
3581: }
3582: # if they have the evb priv and are currently not playing student
1.482 raeburn 3583: next if (($no_ownblock) &&
1.491 albertel 3584: ($env{'request.role'} !~ m{^st\./\Q$cdom\E/\Q$cnum\E}));
1.482 raeburn 3585: next if ($no_userblock);
1.474 raeburn 3586:
1.490 raeburn 3587: # Retrieve blocking times and identity of blocker for course
3588: # of specified user, unless user has 'evb' privilege.
1.502 raeburn 3589:
3590: my ($start,$end)=&get_blocks($setters,$activity,$cdom,$cnum);
3591: if (($start != 0) &&
3592: (($startblock == 0) || ($startblock > $start))) {
3593: $startblock = $start;
3594: }
3595: if (($end != 0) &&
3596: (($endblock == 0) || ($endblock < $end))) {
3597: $endblock = $end;
3598: }
1.490 raeburn 3599: }
3600: return ($startblock,$endblock);
3601: }
3602:
3603: sub get_blocks {
3604: my ($setters,$activity,$cdom,$cnum) = @_;
3605: my $startblock = 0;
3606: my $endblock = 0;
3607: my $course = $cdom.'_'.$cnum;
3608: $setters->{$course} = {};
3609: $setters->{$course}{'staff'} = [];
3610: $setters->{$course}{'times'} = [];
3611: my %records = &Apache::lonnet::dump('comm_block',$cdom,$cnum);
3612: foreach my $record (keys(%records)) {
3613: my ($start,$end) = ($record =~ m/^(\d+)____(\d+)$/);
3614: if ($start <= time && $end >= time) {
3615: my ($staff_name,$staff_dom,$title,$blocks) =
3616: &parse_block_record($records{$record});
3617: if ($blocks->{$activity} eq 'on') {
3618: push(@{$$setters{$course}{'staff'}},[$staff_name,$staff_dom]);
3619: push(@{$$setters{$course}{'times'}}, [$start,$end]);
1.491 albertel 3620: if ( ($startblock == 0) || ($startblock > $start) ) {
3621: $startblock = $start;
1.490 raeburn 3622: }
1.491 albertel 3623: if ( ($endblock == 0) || ($endblock < $end) ) {
3624: $endblock = $end;
1.474 raeburn 3625: }
3626: }
3627: }
3628: }
3629: return ($startblock,$endblock);
3630: }
3631:
3632: sub parse_block_record {
3633: my ($record) = @_;
3634: my ($setuname,$setudom,$title,$blocks);
3635: if (ref($record) eq 'HASH') {
3636: ($setuname,$setudom) = split(/:/,$record->{'setter'});
3637: $title = &unescape($record->{'event'});
3638: $blocks = $record->{'blocks'};
3639: } else {
3640: my @data = split(/:/,$record,3);
3641: if (scalar(@data) eq 2) {
3642: $title = $data[1];
3643: ($setuname,$setudom) = split(/@/,$data[0]);
3644: } else {
3645: ($setuname,$setudom,$title) = @data;
3646: }
3647: $blocks = { 'com' => 'on' };
3648: }
3649: return ($setuname,$setudom,$title,$blocks);
3650: }
3651:
3652: sub build_block_table {
3653: my ($startblock,$endblock,$setters) = @_;
3654: my %lt = &Apache::lonlocal::texthash(
3655: 'cacb' => 'Currently active communication blocks',
3656: 'cour' => 'Course',
3657: 'dura' => 'Duration',
3658: 'blse' => 'Block set by'
3659: );
3660: my $output;
1.476 raeburn 3661: $output = '<br />'.$lt{'cacb'}.':<br />';
1.474 raeburn 3662: $output .= &start_data_table();
3663: $output .= '
3664: <tr>
3665: <th>'.$lt{'cour'}.'</th>
3666: <th>'.$lt{'dura'}.'</th>
3667: <th>'.$lt{'blse'}.'</th>
3668: </tr>
3669: ';
3670: foreach my $course (keys(%{$setters})) {
3671: my %courseinfo=&Apache::lonnet::coursedescription($course);
3672: for (my $i=0; $i<@{$$setters{$course}{staff}}; $i++) {
3673: my ($uname,$udom) = @{$$setters{$course}{staff}[$i]};
1.490 raeburn 3674: my $fullname = &plainname($uname,$udom);
3675: if (defined($env{'user.name'}) && defined($env{'user.domain'})
3676: && $env{'user.name'} ne 'public'
3677: && $env{'user.domain'} ne 'public') {
3678: $fullname = &aboutmewrapper($fullname,$uname,$udom);
3679: }
1.474 raeburn 3680: my ($openblock,$closeblock) = @{$$setters{$course}{times}[$i]};
3681: $openblock = &Apache::lonlocal::locallocaltime($openblock);
3682: $closeblock= &Apache::lonlocal::locallocaltime($closeblock);
3683: $output .= &Apache::loncommon::start_data_table_row().
3684: '<td>'.$courseinfo{'description'}.'</td>'.
3685: '<td>'.$openblock.' to '.$closeblock.'</td>'.
1.490 raeburn 3686: '<td>'.$fullname.'</td>'.
1.474 raeburn 3687: &Apache::loncommon::end_data_table_row();
3688: }
3689: }
3690: $output .= &end_data_table();
3691: }
3692:
1.490 raeburn 3693: sub blocking_status {
3694: my ($activity,$uname,$udom) = @_;
3695: my %setters;
3696: my ($blocked,$output,$ownitem,$is_course);
3697: my ($startblock,$endblock)=&blockcheck(\%setters,$activity,$uname,$udom);
3698: if ($startblock && $endblock) {
3699: $blocked = 1;
3700: if (wantarray) {
3701: my $category;
3702: if ($activity eq 'boards') {
3703: $category = 'Discussion posts in this course';
3704: } elsif ($activity eq 'blogs') {
3705: $category = 'Blogs';
3706: } elsif ($activity eq 'port') {
3707: if (defined($uname) && defined($udom)) {
3708: if ($uname eq $env{'user.name'} &&
3709: $udom eq $env{'user.domain'}) {
3710: $ownitem = 1;
3711: }
3712: }
3713: $is_course = &Apache::lonnet::is_course($udom,$uname);
3714: if ($ownitem) {
3715: $category = 'Your portfolio files';
3716: } elsif ($is_course) {
3717: my $coursedesc;
3718: foreach my $course (keys(%setters)) {
3719: my %courseinfo =
3720: &Apache::lonnet::coursedescription($course);
3721: $coursedesc = $courseinfo{'description'};
3722: }
3723: $category = "Group files in the course '$coursedesc'";
3724: } else {
3725: $category = 'Portfolio files belonging to ';
3726: if ($env{'user.name'} eq 'public' &&
3727: $env{'user.domain'} eq 'public') {
3728: $category .= &plainname($uname,$udom);
3729: } else {
3730: $category .= &aboutmewrapper(&plainname($uname,$udom),$uname,$udom);
3731: }
3732: }
3733: } elsif ($activity eq 'groups') {
3734: $category = 'Groups in this course';
3735: }
3736: my $showstart = &Apache::lonlocal::locallocaltime($startblock);
3737: my $showend = &Apache::lonlocal::locallocaltime($endblock);
3738: $output = '<br />'.&mt('[_1] will be inaccessible between [_2] and [_3] because communication is being blocked.',$category,$showstart,$showend).'<br />';
3739: if (!($activity eq 'port' && !($ownitem) && !($is_course))) {
3740: $output .= &build_block_table($startblock,$endblock,\%setters);
3741: }
3742: }
3743: }
3744: if (wantarray) {
3745: return ($blocked,$output);
3746: } else {
3747: return $blocked;
3748: }
3749: }
3750:
1.60 matthew 3751: ###############################################
3752:
3753: =pod
3754:
1.112 bowersj2 3755: =head1 Domain Template Functions
3756:
3757: =over 4
3758:
3759: =item * &determinedomain()
1.60 matthew 3760:
3761: Inputs: $domain (usually will be undef)
3762:
1.63 www 3763: Returns: Determines which domain should be used for designs
1.60 matthew 3764:
3765: =cut
1.54 www 3766:
1.60 matthew 3767: ###############################################
1.63 www 3768: sub determinedomain {
3769: my $domain=shift;
1.531 albertel 3770: if (! $domain) {
1.60 matthew 3771: # Determine domain if we have not been given one
3772: $domain = $Apache::lonnet::perlvar{'lonDefDomain'};
1.258 albertel 3773: if ($env{'user.domain'}) { $domain=$env{'user.domain'}; }
3774: if ($env{'request.role.domain'}) {
3775: $domain=$env{'request.role.domain'};
1.60 matthew 3776: }
3777: }
1.63 www 3778: return $domain;
3779: }
3780: ###############################################
1.517 raeburn 3781:
1.518 albertel 3782: sub devalidate_domconfig_cache {
3783: my ($udom)=@_;
3784: &Apache::lonnet::devalidate_cache_new('domainconfig',$udom);
3785: }
3786:
3787: # ---------------------- Get domain configuration for a domain
3788: sub get_domainconf {
3789: my ($udom) = @_;
3790: my $cachetime=1800;
3791: my ($result,$cached)=&Apache::lonnet::is_cached_new('domainconfig',$udom);
3792: if (defined($cached)) { return %{$result}; }
3793:
3794: my %domconfig = &Apache::lonnet::get_dom('configuration',
3795: ['login','rolecolors'],$udom);
1.632 raeburn 3796: my (%designhash,%legacy);
1.518 albertel 3797: if (keys(%domconfig) > 0) {
3798: if (ref($domconfig{'login'}) eq 'HASH') {
1.632 raeburn 3799: if (keys(%{$domconfig{'login'}})) {
3800: foreach my $key (keys(%{$domconfig{'login'}})) {
3801: $designhash{$udom.'.login.'.$key}=$domconfig{'login'}{$key};
3802: }
3803: } else {
3804: $legacy{'login'} = 1;
1.518 albertel 3805: }
1.632 raeburn 3806: } else {
3807: $legacy{'login'} = 1;
1.518 albertel 3808: }
3809: if (ref($domconfig{'rolecolors'}) eq 'HASH') {
1.632 raeburn 3810: if (keys(%{$domconfig{'rolecolors'}})) {
3811: foreach my $role (keys(%{$domconfig{'rolecolors'}})) {
3812: if (ref($domconfig{'rolecolors'}{$role}) eq 'HASH') {
3813: foreach my $item (keys(%{$domconfig{'rolecolors'}{$role}})) {
3814: $designhash{$udom.'.'.$role.'.'.$item}=$domconfig{'rolecolors'}{$role}{$item};
3815: }
1.518 albertel 3816: }
3817: }
1.632 raeburn 3818: } else {
3819: $legacy{'rolecolors'} = 1;
1.518 albertel 3820: }
1.632 raeburn 3821: } else {
3822: $legacy{'rolecolors'} = 1;
1.518 albertel 3823: }
1.632 raeburn 3824: if (keys(%legacy) > 0) {
3825: my %legacyhash = &get_legacy_domconf($udom);
3826: foreach my $item (keys(%legacyhash)) {
3827: if ($item =~ /^\Q$udom\E\.login/) {
3828: if ($legacy{'login'}) {
3829: $designhash{$item} = $legacyhash{$item};
3830: }
3831: } else {
3832: if ($legacy{'rolecolors'}) {
3833: $designhash{$item} = $legacyhash{$item};
3834: }
1.518 albertel 3835: }
3836: }
3837: }
1.632 raeburn 3838: } else {
3839: %designhash = &get_legacy_domconf($udom);
1.518 albertel 3840: }
3841: &Apache::lonnet::do_cache_new('domainconfig',$udom,\%designhash,
3842: $cachetime);
3843: return %designhash;
3844: }
3845:
1.632 raeburn 3846: sub get_legacy_domconf {
3847: my ($udom) = @_;
3848: my %legacyhash;
3849: my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors';
3850: my $designfile = $designdir.'/'.$udom.'.tab';
3851: if (-e $designfile) {
3852: if ( open (my $fh,"<$designfile") ) {
3853: while (my $line = <$fh>) {
3854: next if ($line =~ /^\#/);
3855: chomp($line);
3856: my ($key,$val)=(split(/\=/,$line));
3857: if ($val) { $legacyhash{$udom.'.'.$key}=$val; }
3858: }
3859: close($fh);
3860: }
3861: }
3862: if (-e '/home/httpd/html/adm/lonDomLogos/'.$udom.'.gif') {
3863: $legacyhash{$udom.'.login.domlogo'} = "/adm/lonDomLogos/$udom.gif";
3864: }
3865: return %legacyhash;
3866: }
3867:
1.63 www 3868: =pod
3869:
1.112 bowersj2 3870: =item * &domainlogo()
1.63 www 3871:
3872: Inputs: $domain (usually will be undef)
3873:
3874: Returns: A link to a domain logo, if the domain logo exists.
3875: If the domain logo does not exist, a description of the domain.
3876:
3877: =cut
1.112 bowersj2 3878:
1.63 www 3879: ###############################################
3880: sub domainlogo {
1.517 raeburn 3881: my $domain = &determinedomain(shift);
1.518 albertel 3882: my %designhash = &get_domainconf($domain);
1.517 raeburn 3883: # See if there is a logo
3884: if ($designhash{$domain.'.login.domlogo'} ne '') {
1.519 raeburn 3885: my $imgsrc = $designhash{$domain.'.login.domlogo'};
1.538 albertel 3886: if ($imgsrc =~ m{^/(adm|res)/}) {
3887: if ($imgsrc =~ m{^/res/}) {
3888: my $local_name = &Apache::lonnet::filelocation('',$imgsrc);
3889: &Apache::lonnet::repcopy($local_name);
3890: }
3891: $imgsrc = &lonhttpdurl($imgsrc);
1.519 raeburn 3892: }
3893: return '<img src="'.$imgsrc.'" alt="'.$domain.'" />';
1.514 albertel 3894: } elsif (defined(&Apache::lonnet::domain($domain,'description'))) {
3895: return &Apache::lonnet::domain($domain,'description');
1.59 www 3896: } else {
1.60 matthew 3897: return '';
1.59 www 3898: }
3899: }
1.63 www 3900: ##############################################
3901:
3902: =pod
3903:
1.112 bowersj2 3904: =item * &designparm()
1.63 www 3905:
3906: Inputs: $which parameter; $domain (usually will be undef)
3907:
3908: Returns: value of designparamter $which
3909:
3910: =cut
1.112 bowersj2 3911:
1.397 albertel 3912:
1.400 albertel 3913: ##############################################
1.397 albertel 3914: sub designparm {
3915: my ($which,$domain)=@_;
1.258 albertel 3916: if ($env{'browser.blackwhite'} eq 'on') {
1.635 raeburn 3917: if ($which=~/\.(font|alink|vlink|link|textcol)$/) {
1.110 www 3918: return '#000000';
3919: }
1.635 raeburn 3920: if ($which=~/\.(pgbg|sidebg|bgcol)$/) {
1.110 www 3921: return '#FFFFFF';
3922: }
3923: if ($which=~/\.tabbg$/) {
3924: return '#CCCCCC';
3925: }
3926: }
1.397 albertel 3927: if (exists($env{'environment.color.'.$which})) {
1.258 albertel 3928: return $env{'environment.color.'.$which};
1.96 www 3929: }
1.63 www 3930: $domain=&determinedomain($domain);
1.518 albertel 3931: my %domdesign = &get_domainconf($domain);
1.520 raeburn 3932: my $output;
1.517 raeburn 3933: if ($domdesign{$domain.'.'.$which} ne '') {
1.520 raeburn 3934: $output = $domdesign{$domain.'.'.$which};
1.63 www 3935: } else {
1.520 raeburn 3936: $output = $defaultdesign{$which};
3937: }
3938: if (($which =~ /^(student|coordinator|author|admin)\.img$/) ||
1.635 raeburn 3939: ($which =~ /login\.(img|logo|domlogo|login)/)) {
1.538 albertel 3940: if ($output =~ m{^/(adm|res)/}) {
3941: if ($output =~ m{^/res/}) {
3942: my $local_name = &Apache::lonnet::filelocation('',$output);
3943: &Apache::lonnet::repcopy($local_name);
3944: }
1.520 raeburn 3945: $output = &lonhttpdurl($output);
3946: }
1.63 www 3947: }
1.520 raeburn 3948: return $output;
1.63 www 3949: }
1.59 www 3950:
1.60 matthew 3951: ###############################################
3952: ###############################################
3953:
3954: =pod
3955:
1.112 bowersj2 3956: =back
3957:
1.549 albertel 3958: =head1 HTML Helpers
1.112 bowersj2 3959:
3960: =over 4
3961:
3962: =item * &bodytag()
1.60 matthew 3963:
3964: Returns a uniform header for LON-CAPA web pages.
3965:
3966: Inputs:
3967:
1.112 bowersj2 3968: =over 4
3969:
3970: =item * $title, A title to be displayed on the page.
3971:
3972: =item * $function, the current role (can be undef).
3973:
3974: =item * $addentries, extra parameters for the <body> tag.
3975:
3976: =item * $bodyonly, if defined, only return the <body> tag.
3977:
3978: =item * $domain, if defined, force a given domain.
3979:
3980: =item * $forcereg, if page should register as content page (relevant for
1.86 www 3981: text interface only)
1.60 matthew 3982:
1.326 albertel 3983: =item * $customtitle, alternate text to use instead of $title
3984: in the title box that appears, this text
3985: is not auto translated like the $title is
1.309 albertel 3986:
3987: =item * $notopbar, if true, keep the 'what is this' info but remove the
3988: navigational links
1.317 albertel 3989:
1.338 albertel 3990: =item * $bgcolor, used to override the bgcolor on a webpage to a specific value
3991:
3992: =item * $notitle, if true keep the nav controls, but remove the title bar
3993:
1.361 albertel 3994: =item * $no_inline_link, if true and in remote mode, don't show the
3995: 'Switch To Inline Menu' link
3996:
1.460 albertel 3997: =item * $args, optional argument valid values are
3998: no_auto_mt_title -> prevents &mt()ing the title arg
1.562 albertel 3999: inherit_jsmath -> when creating popup window in a page,
4000: should it have jsmath forced on by the
4001: current page
1.460 albertel 4002:
1.112 bowersj2 4003: =back
4004:
1.60 matthew 4005: Returns: A uniform header for LON-CAPA web pages.
4006: If $bodyonly is nonzero, a string containing a <body> tag will be returned.
4007: If $bodyonly is undef or zero, an html string containing a <body> tag and
4008: other decorations will be returned.
4009:
4010: =cut
4011:
1.54 www 4012: sub bodytag {
1.309 albertel 4013: my ($title,$function,$addentries,$bodyonly,$domain,$forcereg,$customtitle,
1.460 albertel 4014: $notopbar,$bgcolor,$notitle,$no_inline_link,$args)=@_;
1.339 albertel 4015:
1.460 albertel 4016: if (!$args->{'no_auto_mt_title'}) { $title = &mt($title); }
1.339 albertel 4017:
1.183 matthew 4018: $function = &get_users_function() if (!$function);
1.339 albertel 4019: my $img = &designparm($function.'.img',$domain);
4020: my $font = &designparm($function.'.font',$domain);
4021: my $pgbg = $bgcolor || &designparm($function.'.pgbg',$domain);
4022:
4023: my %design = ( 'style' => 'margin-top: 0px',
1.535 albertel 4024: 'bgcolor' => $pgbg,
1.339 albertel 4025: 'text' => $font,
4026: 'alink' => &designparm($function.'.alink',$domain),
4027: 'vlink' => &designparm($function.'.vlink',$domain),
4028: 'link' => &designparm($function.'.link',$domain),);
1.438 albertel 4029: @design{keys(%$addentries)} = @$addentries{keys(%$addentries)};
1.339 albertel 4030:
1.63 www 4031: # role and realm
1.378 raeburn 4032: my ($role,$realm) = split(/\./,$env{'request.role'},2);
4033: if ($role eq 'ca') {
1.479 albertel 4034: my ($rdom,$rname) = ($realm =~ m{^/($match_domain)/($match_username)$});
1.500 albertel 4035: $realm = &plainname($rname,$rdom);
1.378 raeburn 4036: }
1.55 www 4037: # realm
1.258 albertel 4038: if ($env{'request.course.id'}) {
1.378 raeburn 4039: if ($env{'request.role'} !~ /^cr/) {
4040: $role = &Apache::lonnet::plaintext($role,&course_type());
4041: }
1.359 albertel 4042: $realm = $env{'course.'.$env{'request.course.id'}.'.description'};
1.378 raeburn 4043: } else {
4044: $role = &Apache::lonnet::plaintext($role);
1.54 www 4045: }
1.433 albertel 4046:
1.359 albertel 4047: if (!$realm) { $realm=' '; }
1.55 www 4048: # Set messages
1.60 matthew 4049: my $messages=&domainlogo($domain);
1.330 albertel 4050:
1.438 albertel 4051: my $extra_body_attr = &make_attr_string($forcereg,\%design);
1.329 albertel 4052:
1.101 www 4053: # construct main body tag
1.359 albertel 4054: my $bodytag = "<body $extra_body_attr>".
1.562 albertel 4055: &Apache::lontexconvert::init_math_support($args->{'inherit_jsmath'});
1.252 albertel 4056:
1.530 albertel 4057: if ($bodyonly) {
1.60 matthew 4058: return $bodytag;
1.258 albertel 4059: } elsif ($env{'browser.interface'} eq 'textual') {
1.95 www 4060: # Accessibility
1.224 raeburn 4061:
1.337 albertel 4062: $bodytag.=&Apache::lonmenu::menubuttons($forcereg,$forcereg);
1.338 albertel 4063: if (!$notitle) {
1.337 albertel 4064: $bodytag.='<h1>LON-CAPA: '.$title.'</h1>';
4065: }
4066: return $bodytag;
1.359 albertel 4067: }
4068:
1.410 albertel 4069: my $name = &plainname($env{'user.name'},$env{'user.domain'});
1.433 albertel 4070: if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
4071: undef($role);
1.434 albertel 4072: } else {
4073: $name = &aboutmewrapper($name,$env{'user.name'},$env{'user.domain'});
1.433 albertel 4074: }
1.359 albertel 4075:
4076: my $roleinfo=(<<ENDROLE);
4077: <td class="LC_title_bar_who">
4078: <div class="LC_title_bar_name">
1.410 albertel 4079: $name
1.361 albertel 4080:
1.359 albertel 4081: </div>
4082: <div class="LC_title_bar_role">
1.361 albertel 4083: $role
1.359 albertel 4084: </div>
4085: <div class="LC_title_bar_realm">
1.361 albertel 4086: $realm
1.359 albertel 4087: </div>
1.206 albertel 4088: </td>
4089: ENDROLE
1.235 raeburn 4090:
1.359 albertel 4091: my $titleinfo = '<span class="LC_title_bar_title">'.$title.'</span>';
4092: if ($customtitle) {
4093: $titleinfo = $customtitle;
4094: }
4095: #
4096: # Extra info if you are the DC
4097: my $dc_info = '';
4098: if ($env{'user.adv'} && exists($env{'user.role.dc./'.
4099: $env{'course.'.$env{'request.course.id'}.
4100: '.domain'}.'/'})) {
4101: my $cid = $env{'request.course.id'};
4102: $dc_info.= $cid.' '.$env{'course.'.$cid.'.internal.coursecode'};
1.380 www 4103: $dc_info =~ s/\s+$//;
1.359 albertel 4104: $dc_info = '('.$dc_info.')';
4105: }
4106:
1.644 www 4107: if (($env{'environment.remote'} eq 'off') || ($args->{'suppress_header_logos'})) {
1.359 albertel 4108: # No Remote
1.258 albertel 4109: if ($env{'request.state'} eq 'construct') {
1.359 albertel 4110: $forcereg=1;
4111: }
4112:
4113: if (!$customtitle && $env{'request.state'} eq 'construct') {
4114: # this is for resources; directories have customtitle, and crumbs
4115: # and select recent are created in lonpubdir.pm
1.229 albertel 4116: my ($uname,$thisdisfn)=
1.258 albertel 4117: ($env{'request.filename'} =~ m|^/home/([^/]+)/public_html/(.*)|);
1.229 albertel 4118: my $formaction='/priv/'.$uname.'/'.$thisdisfn;
4119: $formaction=~s/\/+/\//g;
4120:
1.359 albertel 4121: my $parentpath = '';
4122: my $lastitem = '';
4123: if ($thisdisfn =~ m-(.+/)([^/]*)$-) {
4124: $parentpath = $1;
4125: $lastitem = $2;
4126: } else {
4127: $lastitem = $thisdisfn;
4128: }
4129: $titleinfo =
1.640 bisitz 4130: &Apache::loncommon::help_open_menu('','',3,'Authoring')
4131: .'<b>'.&mt('Construction Space').'</b>: '
4132: .'<form name="dirs" method="post" action="'.$formaction
1.359 albertel 4133: .'" target="_top"><tt><b>'
4134: .&Apache::lonhtmlcommon::crumbs($uname.'/'.$parentpath,'_top','/priv','','+1',1)."<font size=\"+1\">$lastitem</font></b></tt><br />"
4135: .&Apache::lonhtmlcommon::select_recent('construct','recent','this.form.action=this.form.recent.value;this.form.submit()')
4136: .'</form>'
4137: .&Apache::lonmenu::constspaceform();
1.235 raeburn 4138: }
1.359 albertel 4139:
1.337 albertel 4140: my $titletable;
1.338 albertel 4141: if (!$notitle) {
1.337 albertel 4142: $titletable =
1.359 albertel 4143: '<table id="LC_title_bar">'.
4144: "<tr><td> $titleinfo $dc_info</td>".$roleinfo.
4145: '</tr></table>';
1.337 albertel 4146: }
1.359 albertel 4147: if ($notopbar) {
4148: $bodytag .= $titletable;
4149: } else {
4150: if ($env{'request.state'} eq 'construct') {
1.337 albertel 4151: $bodytag .= &Apache::lonmenu::menubuttons($forcereg,$forcereg,
4152: $titletable);
1.272 raeburn 4153: } else {
1.336 albertel 4154: $bodytag .= &Apache::lonmenu::menubuttons($forcereg,$forcereg).
1.359 albertel 4155: $titletable;
1.272 raeburn 4156: }
1.235 raeburn 4157: }
4158: return $bodytag;
1.94 www 4159: }
1.95 www 4160:
1.93 www 4161: #
1.95 www 4162: # Top frame rendering, Remote is up
1.93 www 4163: #
1.359 albertel 4164:
1.517 raeburn 4165: my $imgsrc = $img;
4166: if ($img =~ /^\/adm/) {
1.575 albertel 4167: $imgsrc = &lonhttpdurl($img);
1.517 raeburn 4168: }
4169: my $upperleft='<img src="'.$imgsrc.'" alt="'.$function.'" />';
1.359 albertel 4170:
1.305 www 4171: # Explicit link to get inline menu
1.361 albertel 4172: my $menu= ($no_inline_link?''
4173: :'<br /><a href="/adm/remote?action=collapse">'.&mt('Switch to Inline Menu Mode').'</a>');
1.245 matthew 4174: #
1.338 albertel 4175: if ($notitle) {
1.337 albertel 4176: return $bodytag;
4177: }
1.94 www 4178: return(<<ENDBODY);
1.60 matthew 4179: $bodytag
1.359 albertel 4180: <table id="LC_title_bar" class="LC_with_remote">
1.368 albertel 4181: <tr><td class="LC_title_bar_role_logo">$upperleft</td>
1.359 albertel 4182: <td class="LC_title_bar_domain_logo">$messages </td>
1.54 www 4183: </tr>
1.359 albertel 4184: <tr><td>$titleinfo $dc_info $menu</td>
4185: $roleinfo
1.368 albertel 4186: </tr>
1.356 albertel 4187: </table>
1.54 www 4188: ENDBODY
1.182 matthew 4189: }
4190:
1.330 albertel 4191: sub make_attr_string {
4192: my ($register,$attr_ref) = @_;
4193:
4194: if ($attr_ref && !ref($attr_ref)) {
4195: die("addentries Must be a hash ref ".
4196: join(':',caller(1))." ".
4197: join(':',caller(0))." ");
4198: }
4199:
4200: if ($register) {
1.339 albertel 4201: my ($on_load,$on_unload);
4202: foreach my $key (keys(%{$attr_ref})) {
4203: if (lc($key) eq 'onload') {
4204: $on_load.=$attr_ref->{$key}.';';
4205: delete($attr_ref->{$key});
4206:
4207: } elsif (lc($key) eq 'onunload') {
4208: $on_unload.=$attr_ref->{$key}.';';
4209: delete($attr_ref->{$key});
4210: }
4211: }
4212: $attr_ref->{'onload'} =
4213: &Apache::lonmenu::loadevents(). $on_load;
4214: $attr_ref->{'onunload'}=
4215: &Apache::lonmenu::unloadevents().$on_unload;
4216: }
4217:
4218: # Accessibility font enhance
4219: if ($env{'browser.fontenhance'} eq 'on') {
4220: my $style;
4221: foreach my $key (keys(%{$attr_ref})) {
4222: if (lc($key) eq 'style') {
4223: $style.=$attr_ref->{$key}.';';
4224: delete($attr_ref->{$key});
4225: }
4226: }
4227: $attr_ref->{'style'}=$style.'; font-size: x-large;';
1.330 albertel 4228: }
1.339 albertel 4229:
4230: if ($env{'browser.blackwhite'} eq 'on') {
4231: delete($attr_ref->{'font'});
4232: delete($attr_ref->{'link'});
4233: delete($attr_ref->{'alink'});
4234: delete($attr_ref->{'vlink'});
4235: delete($attr_ref->{'bgcolor'});
4236: delete($attr_ref->{'background'});
4237: }
4238:
1.330 albertel 4239: my $attr_string;
4240: foreach my $attr (keys(%$attr_ref)) {
4241: $attr_string .= " $attr=\"".$attr_ref->{$attr}.'" ';
4242: }
4243: return $attr_string;
4244: }
4245:
4246:
1.182 matthew 4247: ###############################################
1.251 albertel 4248: ###############################################
4249:
4250: =pod
4251:
4252: =item * &endbodytag()
4253:
4254: Returns a uniform footer for LON-CAPA web pages.
4255:
1.635 raeburn 4256: Inputs: 1 - optional reference to an args hash
4257: If in the hash, key for noredirectlink has a value which evaluates to true,
4258: a 'Continue' link is not displayed if the page contains an
4259: internal redirect in the <head></head> section,
4260: i.e., $env{'internal.head.redirect'} exists
1.251 albertel 4261:
4262: =cut
4263:
4264: sub endbodytag {
1.635 raeburn 4265: my ($args) = @_;
1.251 albertel 4266: my $endbodytag='</body>';
1.269 albertel 4267: $endbodytag=&Apache::lontexconvert::jsMath_process()."\n".$endbodytag;
1.315 albertel 4268: if ( exists( $env{'internal.head.redirect'} ) ) {
1.635 raeburn 4269: if (!(ref($args) eq 'HASH' && $args->{'noredirectlink'})) {
4270: $endbodytag=
4271: "<br /><a href=\"$env{'internal.head.redirect'}\">".
4272: &mt('Continue').'</a>'.
4273: $endbodytag;
4274: }
1.315 albertel 4275: }
1.251 albertel 4276: return $endbodytag;
4277: }
4278:
1.352 albertel 4279: =pod
4280:
4281: =item * &standard_css()
4282:
4283: Returns a style sheet
4284:
4285: Inputs: (all optional)
4286: domain -> force to color decorate a page for a specific
4287: domain
4288: function -> force usage of a specific rolish color scheme
4289: bgcolor -> override the default page bgcolor
4290:
4291: =cut
4292:
1.343 albertel 4293: sub standard_css {
1.345 albertel 4294: my ($function,$domain,$bgcolor) = @_;
1.352 albertel 4295: $function = &get_users_function() if (!$function);
4296: my $img = &designparm($function.'.img', $domain);
4297: my $tabbg = &designparm($function.'.tabbg', $domain);
4298: my $font = &designparm($function.'.font', $domain);
1.345 albertel 4299: my $sidebg = &designparm($function.'.sidebg',$domain);
1.382 albertel 4300: my $pgbg_or_bgcolor =
4301: $bgcolor ||
1.352 albertel 4302: &designparm($function.'.pgbg', $domain);
1.382 albertel 4303: my $pgbg = &designparm($function.'.pgbg', $domain);
1.352 albertel 4304: my $alink = &designparm($function.'.alink', $domain);
4305: my $vlink = &designparm($function.'.vlink', $domain);
4306: my $link = &designparm($function.'.link', $domain);
4307:
1.602 albertel 4308: my $sans = 'Verdana,Arial,Helvetica,sans-serif';
1.395 albertel 4309: my $mono = 'monospace';
1.352 albertel 4310: my $data_table_head = $tabbg;
4311: my $data_table_light = '#EEEEEE';
1.470 banghart 4312: my $data_table_dark = '#DDDDDD';
4313: my $data_table_darker = '#CCCCCC';
1.349 albertel 4314: my $data_table_highlight = '#FFFF00';
1.352 albertel 4315: my $mail_new = '#FFBB77';
4316: my $mail_new_hover = '#DD9955';
4317: my $mail_read = '#BBBB77';
4318: my $mail_read_hover = '#999944';
4319: my $mail_replied = '#AAAA88';
4320: my $mail_replied_hover = '#888855';
4321: my $mail_other = '#99BBBB';
4322: my $mail_other_hover = '#669999';
1.391 albertel 4323: my $table_header = '#DDDDDD';
1.489 raeburn 4324: my $feedback_link_bg = '#BBBBBB';
1.392 albertel 4325:
1.608 albertel 4326: my $border = ($env{'browser.type'} eq 'explorer' ||
4327: $env{'browser.type'} eq 'safari' ) ? '0px 2px 0px 2px'
4328: : '0px 3px 0px 4px';
1.448 albertel 4329:
1.523 albertel 4330:
1.343 albertel 4331: return <<END;
1.345 albertel 4332: h1, h2, h3, th { font-family: $sans }
1.343 albertel 4333: a:focus { color: red; background: yellow }
1.510 albertel 4334: table.thinborder,
1.523 albertel 4335:
1.510 albertel 4336: table.thinborder tr th {
4337: border-style: solid;
4338: border-width: 1px;
4339: background: $tabbg;
4340: }
1.523 albertel 4341: table.thinborder tr td {
1.510 albertel 4342: border-style: solid;
4343: border-width: 1px
4344: }
1.426 albertel 4345:
1.343 albertel 4346: form, .inline { display: inline; }
4347: .center { text-align: center; }
1.593 albertel 4348: .LC_filename {font-family: $mono; white-space:pre;}
1.350 albertel 4349: .LC_error {
4350: color: red;
4351: font-size: larger;
4352: }
1.457 albertel 4353: .LC_warning,
4354: .LC_diff_removed {
1.394 albertel 4355: color: red;
4356: }
1.532 albertel 4357:
4358: .LC_info,
1.457 albertel 4359: .LC_success,
4360: .LC_diff_added {
1.350 albertel 4361: color: green;
4362: }
1.543 albertel 4363: .LC_unknown {
4364: color: yellow;
4365: }
4366:
1.440 albertel 4367: .LC_icon {
4368: border: 0px;
4369: }
1.539 albertel 4370: .LC_indexer_icon {
4371: border: 0px;
4372: height: 22px;
4373: }
1.543 albertel 4374: .LC_docs_spacer {
4375: width: 25px;
4376: height: 1px;
4377: border: 0px;
4378: }
1.346 albertel 4379:
1.532 albertel 4380: .LC_internal_info {
4381: color: #999;
4382: }
4383:
1.458 albertel 4384: table.LC_pastsubmission {
4385: border: 1px solid black;
4386: margin: 2px;
4387: }
4388:
1.606 albertel 4389: table#LC_top_nav, table#LC_menubuttons,table#LC_nav_location {
1.345 albertel 4390: width: 100%;
4391: background: $pgbg;
1.392 albertel 4392: border: 2px;
1.402 albertel 4393: border-collapse: separate;
1.403 albertel 4394: padding: 0px;
1.345 albertel 4395: }
1.392 albertel 4396:
1.606 albertel 4397: table#LC_title_bar, table.LC_breadcrumbs,
1.393 albertel 4398: table#LC_title_bar.LC_with_remote {
1.359 albertel 4399: width: 100%;
1.392 albertel 4400: border-color: $pgbg;
4401: border-style: solid;
4402: border-width: $border;
4403:
1.379 albertel 4404: background: $pgbg;
4405: font-family: $sans;
1.392 albertel 4406: border-collapse: collapse;
1.403 albertel 4407: padding: 0px;
1.359 albertel 4408: }
1.392 albertel 4409:
1.409 albertel 4410: table.LC_docs_path {
4411: width: 100%;
4412: border: 0;
4413: background: $pgbg;
4414: font-family: $sans;
4415: border-collapse: collapse;
4416: padding: 0px;
4417: }
4418:
1.359 albertel 4419: table#LC_title_bar td {
4420: background: $tabbg;
4421: }
4422: table#LC_title_bar td.LC_title_bar_who {
4423: background: $tabbg;
4424: color: $font;
1.427 albertel 4425: font: small $sans;
1.359 albertel 4426: text-align: right;
4427: }
1.469 banghart 4428: span.LC_metadata {
4429: font-family: $sans;
4430: }
1.359 albertel 4431: span.LC_title_bar_title {
1.416 albertel 4432: font: bold x-large $sans;
1.359 albertel 4433: }
4434: table#LC_title_bar td.LC_title_bar_domain_logo {
4435: background: $sidebg;
4436: text-align: right;
1.368 albertel 4437: padding: 0px;
4438: }
4439: table#LC_title_bar td.LC_title_bar_role_logo {
4440: background: $sidebg;
4441: padding: 0px;
1.359 albertel 4442: }
4443:
1.346 albertel 4444: table#LC_menubuttons_mainmenu {
1.526 www 4445: width: 100%;
1.346 albertel 4446: border: 0px;
4447: border-spacing: 1px;
1.372 albertel 4448: padding: 0px 1px;
1.346 albertel 4449: margin: 0px;
4450: border-collapse: separate;
4451: }
4452: table#LC_menubuttons img, table#LC_menubuttons_mainmenu img {
4453: border: 0px;
4454: }
1.345 albertel 4455: table#LC_top_nav td {
4456: background: $tabbg;
1.392 albertel 4457: border: 0px;
1.407 albertel 4458: font-size: small;
1.345 albertel 4459: }
4460: table#LC_top_nav td a, div#LC_top_nav a {
4461: color: $font;
4462: font-family: $sans;
4463: }
1.364 albertel 4464: table#LC_top_nav td.LC_top_nav_logo {
4465: background: $tabbg;
1.432 albertel 4466: text-align: left;
1.408 albertel 4467: white-space: nowrap;
1.432 albertel 4468: width: 31px;
1.408 albertel 4469: }
4470: table#LC_top_nav td.LC_top_nav_logo img {
1.432 albertel 4471: border: 0px;
1.408 albertel 4472: vertical-align: bottom;
1.364 albertel 4473: }
1.432 albertel 4474: table#LC_top_nav td.LC_top_nav_exit,
4475: table#LC_top_nav td.LC_top_nav_help {
4476: width: 2.0em;
4477: }
1.442 albertel 4478: table#LC_top_nav td.LC_top_nav_login {
4479: width: 4.0em;
4480: text-align: center;
4481: }
1.409 albertel 4482: table.LC_breadcrumbs td, table.LC_docs_path td {
1.357 albertel 4483: background: $tabbg;
4484: color: $font;
4485: font-family: $sans;
1.358 albertel 4486: font-size: smaller;
1.357 albertel 4487: }
1.411 albertel 4488: table.LC_breadcrumbs td.LC_breadcrumbs_component,
1.409 albertel 4489: table.LC_docs_path td.LC_docs_path_component {
1.357 albertel 4490: background: $tabbg;
4491: color: $font;
4492: font-family: $sans;
4493: font-size: larger;
4494: text-align: right;
4495: }
1.383 albertel 4496: td.LC_table_cell_checkbox {
4497: text-align: center;
4498: }
4499:
1.522 albertel 4500: table#LC_mainmenu td.LC_mainmenu_column {
4501: vertical-align: top;
4502: }
4503:
1.346 albertel 4504: .LC_menubuttons_inline_text {
4505: color: $font;
4506: font-family: $sans;
4507: font-size: smaller;
4508: }
4509:
1.526 www 4510: .LC_menubuttons_link {
4511: text-decoration: none;
4512: }
4513:
1.522 albertel 4514: .LC_menubuttons_category {
1.521 www 4515: color: $font;
1.526 www 4516: background: $pgbg;
1.521 www 4517: font-family: $sans;
4518: font-size: larger;
4519: font-weight: bold;
4520: }
4521:
1.346 albertel 4522: td.LC_menubuttons_text {
1.526 www 4523: width: 90%;
1.346 albertel 4524: color: $font;
4525: font-family: $sans;
4526: }
1.526 www 4527:
1.346 albertel 4528: td.LC_menubuttons_img {
4529: }
1.526 www 4530:
1.346 albertel 4531: .LC_current_location {
4532: font-family: $sans;
4533: background: $tabbg;
4534: }
4535: .LC_new_mail {
4536: font-family: $sans;
1.634 www 4537: background: $tabbg;
1.346 albertel 4538: font-weight: bold;
4539: }
1.347 albertel 4540:
1.526 www 4541: .LC_rolesmenu_is {
4542: font-family: $sans;
4543: }
4544:
4545: .LC_rolesmenu_selected {
4546: font-family: $sans;
4547: }
4548:
4549: .LC_rolesmenu_future {
4550: font-family: $sans;
4551: }
4552:
4553:
4554: .LC_rolesmenu_will {
4555: font-family: $sans;
4556: }
4557:
4558: .LC_rolesmenu_will_not {
4559: font-family: $sans;
4560: }
4561:
4562: .LC_rolesmenu_expired {
4563: font-family: $sans;
4564: }
4565:
4566: .LC_rolesinfo {
4567: font-family: $sans;
4568: }
4569:
1.527 www 4570: .LC_dropadd_labeltext {
4571: font-family: $sans;
4572: text-align: right;
4573: }
4574:
4575: .LC_preferences_labeltext {
4576: font-family: $sans;
4577: text-align: right;
4578: }
4579:
1.440 albertel 4580: table.LC_aboutme_port {
4581: border: 0px;
4582: border-collapse: collapse;
4583: border-spacing: 0px;
4584: }
1.349 albertel 4585: table.LC_data_table, table.LC_mail_list {
1.347 albertel 4586: border: 1px solid #000000;
1.402 albertel 4587: border-collapse: separate;
1.426 albertel 4588: border-spacing: 1px;
1.610 albertel 4589: background: $pgbg;
1.347 albertel 4590: }
1.422 albertel 4591: .LC_data_table_dense {
4592: font-size: small;
4593: }
1.507 raeburn 4594: table.LC_nested_outer {
4595: border: 1px solid #000000;
1.589 raeburn 4596: border-collapse: collapse;
1.507 raeburn 4597: border-spacing: 0px;
4598: width: 100%;
4599: }
4600: table.LC_nested {
4601: border: 0px;
1.589 raeburn 4602: border-collapse: collapse;
1.507 raeburn 4603: border-spacing: 0px;
4604: width: 100%;
4605: }
1.523 albertel 4606: table.LC_data_table tr th, table.LC_calendar tr th, table.LC_mail_list tr th,
4607: table.LC_prior_tries tr th {
1.349 albertel 4608: font-weight: bold;
4609: background-color: $data_table_head;
1.421 albertel 4610: font-size: smaller;
1.347 albertel 4611: }
1.610 albertel 4612: table.LC_data_table tr.LC_odd_row > td,
1.440 albertel 4613: table.LC_aboutme_port tr td {
1.349 albertel 4614: background-color: $data_table_light;
1.425 albertel 4615: padding: 2px;
1.347 albertel 4616: }
1.610 albertel 4617: table.LC_data_table tr.LC_even_row > td,
1.440 albertel 4618: table.LC_aboutme_port tr.LC_even_row td {
1.349 albertel 4619: background-color: $data_table_dark;
1.347 albertel 4620: }
1.425 albertel 4621: table.LC_data_table tr.LC_data_table_highlight td {
4622: background-color: $data_table_darker;
4623: }
1.639 raeburn 4624: table.LC_data_table tr td.LC_leftcol_header {
4625: background-color: $data_table_head;
4626: font-weight: bold;
4627: }
1.451 albertel 4628: table.LC_data_table tr.LC_empty_row td,
1.507 raeburn 4629: table.LC_nested tr.LC_empty_row td {
1.347 albertel 4630: background-color: #FFFFFF;
1.421 albertel 4631: font-weight: bold;
4632: font-style: italic;
4633: text-align: center;
4634: padding: 8px;
1.347 albertel 4635: }
1.507 raeburn 4636: table.LC_nested tr.LC_empty_row td {
1.465 albertel 4637: padding: 4ex
4638: }
1.507 raeburn 4639: table.LC_nested_outer tr th {
4640: font-weight: bold;
4641: background-color: $data_table_head;
4642: font-size: smaller;
4643: border-bottom: 1px solid #000000;
4644: }
4645: table.LC_nested_outer tr td.LC_subheader {
4646: background-color: $data_table_head;
4647: font-weight: bold;
4648: font-size: small;
4649: border-bottom: 1px solid #000000;
4650: text-align: right;
1.451 albertel 4651: }
1.507 raeburn 4652: table.LC_nested tr.LC_info_row td {
1.451 albertel 4653: background-color: #CCC;
4654: font-weight: bold;
4655: font-size: small;
1.507 raeburn 4656: text-align: center;
4657: }
1.589 raeburn 4658: table.LC_nested tr.LC_info_row td.LC_left_item,
4659: table.LC_nested_outer tr th.LC_left_item {
1.507 raeburn 4660: text-align: left;
1.451 albertel 4661: }
1.507 raeburn 4662: table.LC_nested td {
1.451 albertel 4663: background-color: #FFF;
4664: font-size: small;
1.507 raeburn 4665: }
4666: table.LC_nested_outer tr th.LC_right_item,
4667: table.LC_nested tr.LC_info_row td.LC_right_item,
4668: table.LC_nested tr.LC_odd_row td.LC_right_item,
4669: table.LC_nested tr td.LC_right_item {
1.451 albertel 4670: text-align: right;
4671: }
4672:
1.507 raeburn 4673: table.LC_nested tr.LC_odd_row td {
1.451 albertel 4674: background-color: #EEE;
4675: }
4676:
1.473 raeburn 4677: table.LC_createuser {
4678: }
4679:
4680: table.LC_createuser tr.LC_section_row td {
4681: font-size: smaller;
4682: }
4683:
4684: table.LC_createuser tr.LC_info_row td {
4685: background-color: #CCC;
4686: font-weight: bold;
4687: text-align: center;
4688: }
4689:
1.349 albertel 4690: table.LC_calendar {
4691: border: 1px solid #000000;
4692: border-collapse: collapse;
4693: }
4694: table.LC_calendar_pickdate {
4695: font-size: xx-small;
4696: }
4697: table.LC_calendar tr td {
4698: border: 1px solid #000000;
4699: vertical-align: top;
4700: }
4701: table.LC_calendar tr td.LC_calendar_day_empty {
4702: background-color: $data_table_dark;
4703: }
4704: table.LC_calendar tr td.LC_calendar_day_current {
4705: background-color: $data_table_highlight;
4706: }
4707:
4708: table.LC_mail_list tr.LC_mail_new {
4709: background-color: $mail_new;
4710: }
4711: table.LC_mail_list tr.LC_mail_new:hover {
4712: background-color: $mail_new_hover;
4713: }
4714: table.LC_mail_list tr.LC_mail_read {
4715: background-color: $mail_read;
4716: }
4717: table.LC_mail_list tr.LC_mail_read:hover {
4718: background-color: $mail_read_hover;
4719: }
4720: table.LC_mail_list tr.LC_mail_replied {
4721: background-color: $mail_replied;
4722: }
4723: table.LC_mail_list tr.LC_mail_replied:hover {
4724: background-color: $mail_replied_hover;
4725: }
4726: table.LC_mail_list tr.LC_mail_other {
4727: background-color: $mail_other;
4728: }
4729: table.LC_mail_list tr.LC_mail_other:hover {
4730: background-color: $mail_other_hover;
4731: }
1.494 raeburn 4732: table.LC_mail_list tr.LC_mail_even {
4733: }
4734: table.LC_mail_list tr.LC_mail_odd {
4735: }
4736:
1.385 albertel 4737:
1.386 albertel 4738: table#LC_portfolio_actions {
4739: width: auto;
4740: background: $pgbg;
4741: border: 0px;
4742: border-spacing: 2px 2px;
4743: padding: 0px;
4744: margin: 0px;
4745: border-collapse: separate;
4746: }
4747: table#LC_portfolio_actions td.LC_label {
4748: background: $tabbg;
4749: text-align: right;
4750: }
4751: table#LC_portfolio_actions td.LC_value {
4752: background: $tabbg;
4753: }
1.385 albertel 4754:
1.391 albertel 4755: table#LC_cstr_controls {
4756: width: 100%;
4757: border-collapse: collapse;
4758: }
4759: table#LC_cstr_controls tr td {
4760: border: 4px solid $pgbg;
4761: padding: 4px;
4762: text-align: center;
4763: background: $tabbg;
4764: }
4765: table#LC_cstr_controls tr th {
4766: border: 4px solid $pgbg;
4767: background: $table_header;
4768: text-align: center;
4769: font-family: $sans;
4770: font-size: smaller;
4771: }
4772:
1.389 albertel 4773: table#LC_browser {
4774:
4775: }
4776: table#LC_browser tr th {
1.391 albertel 4777: background: $table_header;
1.389 albertel 4778: }
1.390 albertel 4779: table#LC_browser tr td {
4780: padding: 2px;
4781: }
1.389 albertel 4782: table#LC_browser tr.LC_browser_file,
4783: table#LC_browser tr.LC_browser_file_published {
4784: background: #CCFF88;
4785: }
4786: table#LC_browser tr.LC_browser_file_locked,
4787: table#LC_browser tr.LC_browser_file_unpublished {
4788: background: #FFAA99;
1.387 albertel 4789: }
1.389 albertel 4790: table#LC_browser tr.LC_browser_file_obsolete {
4791: background: #AAAAAA;
1.387 albertel 4792: }
1.455 albertel 4793: table#LC_browser tr.LC_browser_file_modified,
4794: table#LC_browser tr.LC_browser_file_metamodified {
1.389 albertel 4795: background: #FFFF77;
1.387 albertel 4796: }
1.389 albertel 4797: table#LC_browser tr.LC_browser_folder {
4798: background: #CCCCFF;
1.387 albertel 4799: }
1.388 albertel 4800: span.LC_current_location {
4801: font-size: x-large;
4802: background: $pgbg;
4803: }
1.387 albertel 4804:
1.395 albertel 4805: span.LC_parm_menu_item {
4806: font-size: larger;
4807: font-family: $sans;
4808: }
4809: span.LC_parm_scope_all {
4810: color: red;
4811: }
4812: span.LC_parm_scope_folder {
4813: color: green;
4814: }
4815: span.LC_parm_scope_resource {
4816: color: orange;
4817: }
4818: span.LC_parm_part {
4819: color: blue;
4820: }
4821: span.LC_parm_folder, span.LC_parm_symb {
4822: font-size: x-small;
4823: font-family: $mono;
4824: color: #AAAAAA;
4825: }
4826:
1.396 albertel 4827: td.LC_parm_overview_level_menu, td.LC_parm_overview_map_menu,
4828: td.LC_parm_overview_parm_selectors, td.LC_parm_overview_parm_restrictions {
4829: border: 1px solid black;
4830: border-collapse: collapse;
4831: }
4832: table.LC_parm_overview_restrictions td {
4833: border-width: 1px 4px 1px 4px;
4834: border-style: solid;
4835: border-color: $pgbg;
4836: text-align: center;
4837: }
4838: table.LC_parm_overview_restrictions th {
4839: background: $tabbg;
4840: border-width: 1px 4px 1px 4px;
4841: border-style: solid;
4842: border-color: $pgbg;
4843: }
1.398 albertel 4844: table#LC_helpmenu {
4845: border: 0px;
4846: height: 55px;
4847: border-spacing: 0px;
4848: }
4849:
4850: table#LC_helpmenu fieldset legend {
4851: font-size: larger;
4852: font-weight: bold;
4853: }
1.397 albertel 4854: table#LC_helpmenu_links {
4855: width: 100%;
4856: border: 1px solid black;
4857: background: $pgbg;
4858: padding: 0px;
4859: border-spacing: 1px;
4860: }
4861: table#LC_helpmenu_links tr td {
4862: padding: 1px;
4863: background: $tabbg;
1.399 albertel 4864: text-align: center;
4865: font-weight: bold;
1.397 albertel 4866: }
1.396 albertel 4867:
1.397 albertel 4868: table#LC_helpmenu_links a:link, table#LC_helpmenu_links a:visited,
4869: table#LC_helpmenu_links a:active {
4870: text-decoration: none;
4871: color: $font;
4872: }
4873: table#LC_helpmenu_links a:hover {
4874: text-decoration: underline;
4875: color: $vlink;
4876: }
1.396 albertel 4877:
1.417 albertel 4878: .LC_chrt_popup_exists {
4879: border: 1px solid #339933;
4880: margin: -1px;
4881: }
4882: .LC_chrt_popup_up {
4883: border: 1px solid yellow;
4884: margin: -1px;
4885: }
4886: .LC_chrt_popup {
4887: border: 1px solid #8888FF;
4888: background: #CCCCFF;
4889: }
1.421 albertel 4890: table.LC_pick_box {
4891: border-collapse: separate;
4892: background: white;
4893: border: 1px solid black;
4894: border-spacing: 1px;
4895: }
4896: table.LC_pick_box td.LC_pick_box_title {
4897: background: $tabbg;
4898: font-weight: bold;
4899: text-align: right;
4900: width: 184px;
4901: padding: 8px;
4902: }
1.645 raeburn 4903: table.LC_pick_box td.LC_selfenroll_pick_box_title {
4904: background: $tabbg;
4905: font-weight: bold;
4906: text-align: right;
4907: width: 350px;
4908: padding: 8px;
4909: }
4910:
1.579 raeburn 4911: table.LC_pick_box td.LC_pick_box_value {
4912: text-align: left;
4913: padding: 8px;
4914: }
4915: table.LC_pick_box td.LC_pick_box_select {
4916: text-align: left;
4917: padding: 8px;
4918: }
1.424 albertel 4919: table.LC_pick_box td.LC_pick_box_separator {
1.421 albertel 4920: padding: 0px;
4921: height: 1px;
4922: background: black;
4923: }
4924: table.LC_pick_box td.LC_pick_box_submit {
4925: text-align: right;
4926: }
1.579 raeburn 4927: table.LC_pick_box td.LC_evenrow_value {
4928: text-align: left;
4929: padding: 8px;
4930: background-color: $data_table_light;
4931: }
4932: table.LC_pick_box td.LC_oddrow_value {
4933: text-align: left;
4934: padding: 8px;
4935: background-color: $data_table_light;
4936: }
4937: table.LC_helpform_receipt {
4938: width: 620px;
4939: border-collapse: separate;
4940: background: white;
4941: border: 1px solid black;
4942: border-spacing: 1px;
4943: }
4944: table.LC_helpform_receipt td.LC_pick_box_title {
4945: background: $tabbg;
4946: font-weight: bold;
4947: text-align: right;
4948: width: 184px;
4949: padding: 8px;
4950: }
4951: table.LC_helpform_receipt td.LC_evenrow_value {
4952: text-align: left;
4953: padding: 8px;
4954: background-color: $data_table_light;
4955: }
4956: table.LC_helpform_receipt td.LC_oddrow_value {
4957: text-align: left;
4958: padding: 8px;
4959: background-color: $data_table_light;
4960: }
4961: table.LC_helpform_receipt td.LC_pick_box_separator {
4962: padding: 0px;
4963: height: 1px;
4964: background: black;
4965: }
4966: span.LC_helpform_receipt_cat {
4967: font-weight: bold;
4968: }
1.424 albertel 4969: table.LC_group_priv_box {
4970: background: white;
4971: border: 1px solid black;
4972: border-spacing: 1px;
4973: }
4974: table.LC_group_priv_box td.LC_pick_box_title {
4975: background: $tabbg;
4976: font-weight: bold;
4977: text-align: right;
4978: width: 184px;
4979: }
4980: table.LC_group_priv_box td.LC_groups_fixed {
4981: background: $data_table_light;
4982: text-align: center;
4983: }
4984: table.LC_group_priv_box td.LC_groups_optional {
4985: background: $data_table_dark;
4986: text-align: center;
4987: }
4988: table.LC_group_priv_box td.LC_groups_functionality {
4989: background: $data_table_darker;
4990: text-align: center;
4991: font-weight: bold;
4992: }
4993: table.LC_group_priv td {
4994: text-align: left;
4995: padding: 0px;
4996: }
4997:
1.421 albertel 4998: table.LC_notify_front_page {
4999: background: white;
5000: border: 1px solid black;
5001: padding: 8px;
5002: }
5003: table.LC_notify_front_page td {
5004: padding: 8px;
5005: }
1.424 albertel 5006: .LC_navbuttons {
5007: margin: 2ex 0ex 2ex 0ex;
5008: }
1.423 albertel 5009: .LC_topic_bar {
5010: font-family: $sans;
5011: font-weight: bold;
5012: width: 100%;
5013: background: $tabbg;
5014: vertical-align: middle;
5015: margin: 2ex 0ex 2ex 0ex;
5016: }
5017: .LC_topic_bar span {
5018: vertical-align: middle;
5019: }
5020: .LC_topic_bar img {
5021: vertical-align: bottom;
5022: }
5023: table.LC_course_group_status {
5024: margin: 20px;
5025: }
5026: table.LC_status_selector td {
5027: vertical-align: top;
5028: text-align: center;
1.424 albertel 5029: padding: 4px;
5030: }
5031: table.LC_descriptive_input td.LC_description {
5032: vertical-align: top;
5033: text-align: right;
5034: font-weight: bold;
1.423 albertel 5035: }
1.599 albertel 5036: div.LC_feedback_link {
1.616 albertel 5037: clear: both;
1.599 albertel 5038: background: white;
5039: width: 100%;
1.489 raeburn 5040: }
5041: span.LC_feedback_link {
1.599 albertel 5042: background: $feedback_link_bg;
5043: font-size: larger;
5044: }
5045: span.LC_message_link {
5046: background: $feedback_link_bg;
5047: font-size: larger;
5048: position: absolute;
5049: right: 1em;
1.489 raeburn 5050: }
1.421 albertel 5051:
1.515 albertel 5052: table.LC_prior_tries {
1.524 albertel 5053: border: 1px solid #000000;
5054: border-collapse: separate;
5055: border-spacing: 1px;
1.515 albertel 5056: }
1.523 albertel 5057:
1.515 albertel 5058: table.LC_prior_tries td {
1.524 albertel 5059: padding: 2px;
1.515 albertel 5060: }
1.523 albertel 5061:
5062: .LC_answer_correct {
5063: background: #AAFFAA;
5064: color: black;
5065: }
5066: .LC_answer_charged_try {
5067: background: #FFAAAA ! important;
5068: color: black;
5069: }
5070: .LC_answer_not_charged_try,
5071: .LC_answer_no_grade,
5072: .LC_answer_late {
5073: background: #FFFFAA;
5074: color: black;
5075: }
5076: .LC_answer_previous {
5077: background: #AAAAFF;
5078: color: black;
5079: }
5080: .LC_answer_no_message {
5081: background: #FFFFFF;
5082: color: black;
5083: }
5084: .LC_answer_unknown {
5085: background: orange;
5086: color: black;
5087: }
5088:
5089:
1.529 albertel 5090: span.LC_prior_numerical,
5091: span.LC_prior_string,
5092: span.LC_prior_custom,
5093: span.LC_prior_reaction,
5094: span.LC_prior_math {
1.523 albertel 5095: font-family: monospace;
5096: white-space: pre;
5097: }
5098:
1.525 albertel 5099: span.LC_prior_string {
5100: font-family: monospace;
5101: white-space: pre;
5102: }
5103:
1.523 albertel 5104: table.LC_prior_option {
5105: width: 100%;
5106: border-collapse: collapse;
5107: }
1.528 albertel 5108: table.LC_prior_rank, table.LC_prior_match {
5109: border-collapse: collapse;
5110: }
5111: table.LC_prior_option tr td,
5112: table.LC_prior_rank tr td,
5113: table.LC_prior_match tr td {
1.524 albertel 5114: border: 1px solid #000000;
1.515 albertel 5115: }
5116:
1.519 raeburn 5117: span.LC_nobreak {
1.544 albertel 5118: white-space: nowrap;
1.519 raeburn 5119: }
5120:
1.576 raeburn 5121: span.LC_cusr_emph {
5122: font-style: italic;
5123: }
5124:
1.633 raeburn 5125: span.LC_cusr_subheading {
5126: font-weight: normal;
5127: font-size: 85%;
5128: }
5129:
1.545 albertel 5130: table.LC_docs_documents {
5131: background: #BBBBBB;
1.547 albertel 5132: border-width: 0px;
1.545 albertel 5133: border-collapse: collapse;
5134: }
5135:
5136: table.LC_docs_documents td.LC_docs_document {
5137: border: 2px solid black;
5138: padding: 4px;
5139: }
5140:
5141: .LC_docs_course_commands div {
5142: float: left;
5143: border: 4px solid #AAAAAA;
5144: padding: 4px;
5145: background: #DDDDCC;
5146: }
5147:
5148: .LC_docs_entry_move {
5149: border: 0px;
5150: border-collapse: collapse;
1.544 albertel 5151: }
5152:
1.545 albertel 5153: .LC_docs_entry_move td {
5154: border: 2px solid #BBBBBB;
5155: background: #DDDDDD;
5156: }
5157:
5158: .LC_docs_editor td.LC_docs_entry_commands {
5159: background: #DDDDDD;
5160: font-size: x-small;
5161: }
1.544 albertel 5162: .LC_docs_copy {
1.545 albertel 5163: color: #000099;
1.544 albertel 5164: }
5165: .LC_docs_cut {
1.545 albertel 5166: color: #550044;
1.544 albertel 5167: }
5168: .LC_docs_rename {
1.545 albertel 5169: color: #009900;
1.544 albertel 5170: }
5171: .LC_docs_remove {
1.545 albertel 5172: color: #990000;
5173: }
5174:
1.547 albertel 5175: .LC_docs_reinit_warn,
5176: .LC_docs_ext_edit {
5177: font-size: x-small;
5178: }
5179:
1.545 albertel 5180: .LC_docs_editor td.LC_docs_entry_title,
5181: .LC_docs_editor td.LC_docs_entry_icon {
5182: background: #FFFFBB;
5183: }
5184: .LC_docs_editor td.LC_docs_entry_parameter {
5185: background: #BBBBFF;
5186: font-size: x-small;
5187: white-space: nowrap;
5188: }
5189:
5190: table.LC_docs_adddocs td,
5191: table.LC_docs_adddocs th {
5192: border: 1px solid #BBBBBB;
5193: padding: 4px;
5194: background: #DDDDDD;
1.543 albertel 5195: }
5196:
1.584 albertel 5197: table.LC_sty_begin {
5198: background: #BBFFBB;
5199: }
5200: table.LC_sty_end {
5201: background: #FFBBBB;
5202: }
5203:
1.589 raeburn 5204: table.LC_double_column {
5205: border-width: 0px;
5206: border-collapse: collapse;
5207: width: 100%;
5208: padding: 2px;
5209: }
5210:
5211: table.LC_double_column tr td.LC_left_col {
1.590 raeburn 5212: top: 2px;
1.589 raeburn 5213: left: 2px;
5214: width: 47%;
5215: vertical-align: top;
5216: }
5217:
5218: table.LC_double_column tr td.LC_right_col {
5219: top: 2px;
5220: right: 2px;
5221: width: 47%;
5222: vertical-align: top;
5223: }
5224:
1.594 raeburn 5225: span.LC_role_level {
5226: font-weight: bold;
5227: }
5228:
1.591 raeburn 5229: div.LC_left_float {
5230: float: left;
5231: padding-right: 5%;
1.597 albertel 5232: padding-bottom: 4px;
1.591 raeburn 5233: }
5234:
5235: div.LC_clear_float_header {
1.597 albertel 5236: padding-bottom: 2px;
1.591 raeburn 5237: }
5238:
5239: div.LC_clear_float_footer {
1.597 albertel 5240: padding-top: 10px;
1.591 raeburn 5241: clear: both;
5242: }
5243:
1.597 albertel 5244:
1.601 albertel 5245: div.LC_grade_select_mode {
1.604 albertel 5246: font-family: $sans;
1.601 albertel 5247: }
5248: div.LC_grade_select_mode div div {
5249: margin: 5px;
5250: }
5251: div.LC_grade_select_mode_selector {
5252: margin: 5px;
5253: float: left;
5254: }
5255: div.LC_grade_select_mode_selector_header {
5256: font: bold medium $sans;
5257: }
5258: div.LC_grade_select_mode_type {
5259: clear: left;
5260: }
5261:
1.597 albertel 5262: div.LC_grade_show_user {
5263: margin-top: 20px;
5264: border: 1px solid black;
5265: }
5266: div.LC_grade_user_name {
5267: background: #DDDDEE;
5268: border-bottom: 1px solid black;
5269: font: bold large $sans;
5270: }
5271: div.LC_grade_show_user_odd_row div.LC_grade_user_name {
5272: background: #DDEEDD;
5273: }
5274:
5275: div.LC_grade_show_problem,
5276: div.LC_grade_submissions,
5277: div.LC_grade_message_center,
5278: div.LC_grade_info_links,
5279: div.LC_grade_assign {
5280: margin: 5px;
5281: width: 99%;
5282: background: #FFFFFF;
5283: }
5284: div.LC_grade_show_problem_header,
5285: div.LC_grade_submissions_header,
5286: div.LC_grade_message_center_header,
5287: div.LC_grade_assign_header {
5288: font: bold large $sans;
5289: }
5290: div.LC_grade_show_problem_problem,
5291: div.LC_grade_submissions_body,
5292: div.LC_grade_message_center_body,
5293: div.LC_grade_assign_body {
5294: border: 1px solid black;
5295: width: 99%;
5296: background: #FFFFFF;
5297: }
1.598 albertel 5298: span.LC_grade_check_note {
5299: font: normal medium $sans;
5300: display: inline;
5301: position: absolute;
5302: right: 1em;
5303: }
1.597 albertel 5304:
1.613 albertel 5305: table.LC_scantron_action {
5306: width: 100%;
5307: }
5308: table.LC_scantron_action tr th {
5309: font: normal bold $sans;
5310: }
1.600 albertel 5311:
1.614 albertel 5312: div.LC_edit_problem_header,
5313: div.LC_edit_problem_footer {
1.600 albertel 5314: font: normal medium $sans;
1.602 albertel 5315: margin: 2px;
1.600 albertel 5316: }
5317: div.LC_edit_problem_header,
1.602 albertel 5318: div.LC_edit_problem_header div,
1.614 albertel 5319: div.LC_edit_problem_footer,
5320: div.LC_edit_problem_footer div,
1.602 albertel 5321: div.LC_edit_problem_editxml_header,
5322: div.LC_edit_problem_editxml_header div {
1.600 albertel 5323: margin-top: 5px;
5324: }
1.602 albertel 5325: div.LC_edit_problem_header_edit_row {
5326: background: $tabbg;
5327: padding: 3px;
5328: margin-bottom: 5px;
5329: }
1.600 albertel 5330: div.LC_edit_problem_header_title {
1.602 albertel 5331: font: larger bold $sans;
5332: background: $tabbg;
5333: padding: 3px;
5334: }
5335: table.LC_edit_problem_header_title {
5336: font: larger bold $sans;
5337: width: 100%;
5338: border-color: $pgbg;
5339: border-style: solid;
5340: border-width: $border;
5341:
1.600 albertel 5342: background: $tabbg;
1.602 albertel 5343: border-collapse: collapse;
5344: padding: 0px
5345: }
5346:
5347: div.LC_edit_problem_discards {
5348: float: left;
5349: padding-bottom: 5px;
5350: }
5351: div.LC_edit_problem_saves {
5352: float: right;
5353: padding-bottom: 5px;
1.600 albertel 5354: }
5355: hr.LC_edit_problem_divide {
1.602 albertel 5356: clear: both;
1.600 albertel 5357: color: $tabbg;
5358: background-color: $tabbg;
5359: height: 3px;
5360: border: 0px;
5361: }
1.343 albertel 5362: END
5363: }
5364:
1.306 albertel 5365: =pod
5366:
5367: =item * &headtag()
5368:
5369: Returns a uniform footer for LON-CAPA web pages.
5370:
1.307 albertel 5371: Inputs: $title - optional title for the head
5372: $head_extra - optional extra HTML to put inside the <head>
1.315 albertel 5373: $args - optional arguments
1.319 albertel 5374: force_register - if is true call registerurl so the remote is
5375: informed
1.415 albertel 5376: redirect -> array ref of
5377: 1- seconds before redirect occurs
5378: 2- url to redirect to
5379: 3- whether the side effect should occur
1.315 albertel 5380: (side effect of setting
5381: $env{'internal.head.redirect'} to the url
5382: redirected too)
1.352 albertel 5383: domain -> force to color decorate a page for a specific
5384: domain
5385: function -> force usage of a specific rolish color scheme
5386: bgcolor -> override the default page bgcolor
1.460 albertel 5387: no_auto_mt_title
5388: -> prevent &mt()ing the title arg
1.464 albertel 5389:
1.306 albertel 5390: =cut
5391:
5392: sub headtag {
1.313 albertel 5393: my ($title,$head_extra,$args) = @_;
1.306 albertel 5394:
1.363 albertel 5395: my $function = $args->{'function'} || &get_users_function();
5396: my $domain = $args->{'domain'} || &determinedomain();
5397: my $bgcolor = $args->{'bgcolor'} || &designparm($function.'.pgbg',$domain);
1.418 albertel 5398: my $url = join(':',$env{'user.name'},$env{'user.domain'},
1.458 albertel 5399: $Apache::lonnet::perlvar{'lonVersion'},
1.531 albertel 5400: #time(),
1.418 albertel 5401: $env{'environment.color.timestamp'},
1.363 albertel 5402: $function,$domain,$bgcolor);
5403:
1.369 www 5404: $url = '/adm/css/'.&escape($url).'.css';
1.363 albertel 5405:
1.308 albertel 5406: my $result =
5407: '<head>'.
1.461 albertel 5408: &font_settings();
1.319 albertel 5409:
1.461 albertel 5410: if (!$args->{'frameset'}) {
5411: $result .= &Apache::lonhtmlcommon::htmlareaheaders();
5412: }
1.319 albertel 5413: if ($args->{'force_register'}) {
5414: $result .= &Apache::lonmenu::registerurl(1);
5415: }
1.436 albertel 5416: if (!$args->{'no_nav_bar'}
5417: && !$args->{'only_body'}
5418: && !$args->{'frameset'}) {
5419: $result .= &help_menu_js();
5420: }
1.319 albertel 5421:
1.314 albertel 5422: if (ref($args->{'redirect'})) {
1.414 albertel 5423: my ($time,$url,$inhibit_continue) = @{$args->{'redirect'}};
1.315 albertel 5424: $url = &Apache::lonenc::check_encrypt($url);
1.414 albertel 5425: if (!$inhibit_continue) {
5426: $env{'internal.head.redirect'} = $url;
5427: }
1.313 albertel 5428: $result.=<<ADDMETA
5429: <meta http-equiv="pragma" content="no-cache" />
1.344 albertel 5430: <meta http-equiv="Refresh" content="$time; url=$url" />
1.313 albertel 5431: ADDMETA
5432: }
1.306 albertel 5433: if (!defined($title)) {
5434: $title = 'The LearningOnline Network with CAPA';
5435: }
1.460 albertel 5436: if (!$args->{'no_auto_mt_title'}) { $title = &mt($title); }
5437: $result .= '<title> LON-CAPA '.$title.'</title>'
1.414 albertel 5438: .'<link rel="stylesheet" type="text/css" href="'.$url.'" />'
5439: .$head_extra;
1.306 albertel 5440: return $result;
5441: }
5442:
5443: =pod
5444:
1.340 albertel 5445: =item * &font_settings()
5446:
5447: Returns neccessary <meta> to set the proper encoding
5448:
5449: Inputs: none
5450:
5451: =cut
5452:
5453: sub font_settings {
5454: my $headerstring='';
1.647 www 5455: if (!$env{'browser.mathml'} && $env{'browser.unicode'}) {
1.340 albertel 5456: $headerstring.=
5457: '<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />';
5458: }
5459: return $headerstring;
5460: }
5461:
1.341 albertel 5462: =pod
5463:
5464: =item * &xml_begin()
5465:
5466: Returns the needed doctype and <html>
5467:
5468: Inputs: none
5469:
5470: =cut
5471:
5472: sub xml_begin {
5473: my $output='';
5474:
1.592 albertel 5475: if ($env{'internal.start_page'}==1) {
5476: &Apache::lonhtmlcommon::init_htmlareafields();
5477: }
1.342 albertel 5478:
1.341 albertel 5479: if ($env{'browser.mathml'}) {
5480: $output='<?xml version="1.0"?>'
5481: #.'<?xml-stylesheet type="text/css" href="/adm/MathML/mathml.css"?>'."\n"
5482: # .'<!DOCTYPE html SYSTEM "/adm/MathML/mathml.dtd" '
5483:
5484: # .'<!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">] >'
5485: .'<!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">'
5486: .'<html xmlns:math="http://www.w3.org/1998/Math/MathML" '
5487: .'xmlns="http://www.w3.org/1999/xhtml">';
5488: } else {
5489: $output='<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"><html>';
5490: }
5491: return $output;
5492: }
1.340 albertel 5493:
5494: =pod
5495:
1.306 albertel 5496: =item * &endheadtag()
5497:
5498: Returns a uniform </head> for LON-CAPA web pages.
5499:
5500: Inputs: none
5501:
5502: =cut
5503:
5504: sub endheadtag {
5505: return '</head>';
5506: }
5507:
5508: =pod
5509:
5510: =item * &head()
5511:
5512: Returns a uniform complete <head>..</head> section for LON-CAPA web pages.
5513:
1.648 raeburn 5514: Inputs:
5515:
5516: =over 4
5517:
5518: $title - optional title for the page
5519:
5520: $head_extra - optional extra HTML to put inside the <head>
5521:
5522: =back
1.405 albertel 5523:
1.306 albertel 5524: =cut
5525:
5526: sub head {
1.325 albertel 5527: my ($title,$head_extra,$args) = @_;
5528: return &headtag($title,$head_extra,$args).&endheadtag();
1.306 albertel 5529: }
5530:
5531: =pod
5532:
5533: =item * &start_page()
5534:
5535: Returns a complete <html> .. <body> section for LON-CAPA web pages.
5536:
1.648 raeburn 5537: Inputs:
5538:
5539: =over 4
5540:
5541: $title - optional title for the page
5542:
5543: $head_extra - optional extra HTML to incude inside the <head>
5544:
5545: $args - additional optional args supported are:
5546:
5547: =over 8
5548:
5549: only_body -> is true will set &bodytag() onlybodytag
1.317 albertel 5550: arg on
1.648 raeburn 5551: no_nav_bar -> is true will set &bodytag() notopbar arg on
5552: add_entries -> additional attributes to add to the <body>
5553: domain -> force to color decorate a page for a
1.317 albertel 5554: specific domain
1.648 raeburn 5555: function -> force usage of a specific rolish color
1.317 albertel 5556: scheme
1.648 raeburn 5557: redirect -> see &headtag()
5558: bgcolor -> override the default page bg color
5559: js_ready -> return a string ready for being used in
1.317 albertel 5560: a javascript writeln
1.648 raeburn 5561: html_encode -> return a string ready for being used in
1.320 albertel 5562: a html attribute
1.648 raeburn 5563: force_register -> if is true will turn on the &bodytag()
1.317 albertel 5564: $forcereg arg
1.648 raeburn 5565: body_title -> alternate text to use instead of $title
1.326 albertel 5566: in the title box that appears, this text
5567: is not auto translated like the $title is
1.648 raeburn 5568: frameset -> if true will start with a <frameset>
1.330 albertel 5569: rather than <body>
1.648 raeburn 5570: no_title -> if true the title bar won't be shown
5571: skip_phases -> hash ref of
1.338 albertel 5572: head -> skip the <html><head> generation
5573: body -> skip all <body> generation
1.648 raeburn 5574: no_inline_link -> if true and in remote mode, don't show the
1.361 albertel 5575: 'Switch To Inline Menu' link
1.648 raeburn 5576: no_auto_mt_title -> prevent &mt()ing the title arg
5577: inherit_jsmath -> when creating popup window in a page,
5578: should it have jsmath forced on by the
5579: current page
1.361 albertel 5580:
1.648 raeburn 5581: =back
1.460 albertel 5582:
1.648 raeburn 5583: =back
1.562 albertel 5584:
1.306 albertel 5585: =cut
5586:
5587: sub start_page {
1.309 albertel 5588: my ($title,$head_extra,$args) = @_;
1.318 albertel 5589: #&Apache::lonnet::logthis("start_page ".join(':',caller(0)));
1.313 albertel 5590: my %head_args;
1.352 albertel 5591: foreach my $arg ('redirect','force_register','domain','function',
1.460 albertel 5592: 'bgcolor','frameset','no_nav_bar','only_body',
5593: 'no_auto_mt_title') {
1.319 albertel 5594: if (defined($args->{$arg})) {
1.324 raeburn 5595: $head_args{$arg} = $args->{$arg};
1.319 albertel 5596: }
1.313 albertel 5597: }
1.319 albertel 5598:
1.315 albertel 5599: $env{'internal.start_page'}++;
1.338 albertel 5600: my $result;
5601: if (! exists($args->{'skip_phases'}{'head'}) ) {
5602: $result.=
1.341 albertel 5603: &xml_begin().
1.338 albertel 5604: &headtag($title,$head_extra,\%head_args).&endheadtag();
5605: }
5606:
5607: if (! exists($args->{'skip_phases'}{'body'}) ) {
5608: if ($args->{'frameset'}) {
5609: my $attr_string = &make_attr_string($args->{'force_register'},
5610: $args->{'add_entries'});
5611: $result .= "\n<frameset $attr_string>\n";
5612: } else {
5613: $result .=
5614: &bodytag($title,
5615: $args->{'function'}, $args->{'add_entries'},
5616: $args->{'only_body'}, $args->{'domain'},
5617: $args->{'force_register'}, $args->{'body_title'},
5618: $args->{'no_nav_bar'}, $args->{'bgcolor'},
1.460 albertel 5619: $args->{'no_title'}, $args->{'no_inline_link'},
5620: $args);
1.338 albertel 5621: }
1.330 albertel 5622: }
1.338 albertel 5623:
1.315 albertel 5624: if ($args->{'js_ready'}) {
1.317 albertel 5625: $result = &js_ready($result);
1.315 albertel 5626: }
1.320 albertel 5627: if ($args->{'html_encode'}) {
5628: $result = &html_encode($result);
5629: }
1.315 albertel 5630: return $result;
1.306 albertel 5631: }
5632:
1.330 albertel 5633:
1.306 albertel 5634: =pod
5635:
5636: =item * &head()
5637:
5638: Returns a complete </body></html> section for LON-CAPA web pages.
5639:
1.315 albertel 5640: Inputs: $args - additional optional args supported are:
5641: js_ready -> return a string ready for being used in
5642: a javascript writeln
1.320 albertel 5643: html_encode -> return a string ready for being used in
5644: a html attribute
1.330 albertel 5645: frameset -> if true will start with a <frameset>
5646: rather than <body>
1.493 albertel 5647: dicsussion -> if true will get discussion from
5648: lonxml::xmlend
5649: (you can pass the target and parser arguments
5650: through optional 'target' and 'parser' args
5651: to this routine)
1.306 albertel 5652:
5653: =cut
5654:
5655: sub end_page {
1.315 albertel 5656: my ($args) = @_;
5657: $env{'internal.end_page'}++;
1.330 albertel 5658: my $result;
1.335 albertel 5659: if ($args->{'discussion'}) {
5660: my ($target,$parser);
5661: if (ref($args->{'discussion'})) {
5662: ($target,$parser) =($args->{'discussion'}{'target'},
5663: $args->{'discussion'}{'parser'});
5664: }
5665: $result .= &Apache::lonxml::xmlend($target,$parser);
5666: }
5667:
1.330 albertel 5668: if ($args->{'frameset'}) {
5669: $result .= '</frameset>';
5670: } else {
1.635 raeburn 5671: $result .= &endbodytag($args);
1.330 albertel 5672: }
5673: $result .= "\n</html>";
5674:
1.315 albertel 5675: if ($args->{'js_ready'}) {
1.317 albertel 5676: $result = &js_ready($result);
1.315 albertel 5677: }
1.335 albertel 5678:
1.320 albertel 5679: if ($args->{'html_encode'}) {
5680: $result = &html_encode($result);
5681: }
1.335 albertel 5682:
1.315 albertel 5683: return $result;
5684: }
5685:
1.320 albertel 5686: sub html_encode {
5687: my ($result) = @_;
5688:
1.322 albertel 5689: $result = &HTML::Entities::encode($result,'<>&"');
1.320 albertel 5690:
5691: return $result;
5692: }
1.317 albertel 5693: sub js_ready {
5694: my ($result) = @_;
5695:
1.323 albertel 5696: $result =~ s/[\n\r]/ /xmsg;
5697: $result =~ s/\\/\\\\/xmsg;
5698: $result =~ s/'/\\'/xmsg;
1.372 albertel 5699: $result =~ s{</}{<\\/}xmsg;
1.317 albertel 5700:
5701: return $result;
5702: }
5703:
1.315 albertel 5704: sub validate_page {
5705: if ( exists($env{'internal.start_page'})
1.316 albertel 5706: && $env{'internal.start_page'} > 1) {
5707: &Apache::lonnet::logthis('start_page called multiple times '.
1.318 albertel 5708: $env{'internal.start_page'}.' '.
1.316 albertel 5709: $ENV{'request.filename'});
1.315 albertel 5710: }
5711: if ( exists($env{'internal.end_page'})
1.316 albertel 5712: && $env{'internal.end_page'} > 1) {
5713: &Apache::lonnet::logthis('end_page called multiple times '.
1.318 albertel 5714: $env{'internal.end_page'}.' '.
1.316 albertel 5715: $env{'request.filename'});
1.315 albertel 5716: }
5717: if ( exists($env{'internal.start_page'})
5718: && ! exists($env{'internal.end_page'})) {
1.316 albertel 5719: &Apache::lonnet::logthis('start_page called without end_page '.
5720: $env{'request.filename'});
1.315 albertel 5721: }
5722: if ( ! exists($env{'internal.start_page'})
5723: && exists($env{'internal.end_page'})) {
1.316 albertel 5724: &Apache::lonnet::logthis('end_page called without start_page'.
5725: $env{'request.filename'});
1.315 albertel 5726: }
1.306 albertel 5727: }
1.315 albertel 5728:
1.318 albertel 5729: sub simple_error_page {
5730: my ($r,$title,$msg) = @_;
5731: my $page =
5732: &Apache::loncommon::start_page($title).
5733: &mt($msg).
5734: &Apache::loncommon::end_page();
5735: if (ref($r)) {
5736: $r->print($page);
1.327 albertel 5737: return;
1.318 albertel 5738: }
5739: return $page;
5740: }
1.347 albertel 5741:
5742: {
1.610 albertel 5743: my @row_count;
1.347 albertel 5744: sub start_data_table {
1.422 albertel 5745: my ($add_class) = @_;
5746: my $css_class = (join(' ','LC_data_table',$add_class));
1.610 albertel 5747: unshift(@row_count,0);
1.422 albertel 5748: return '<table class="'.$css_class.'">'."\n";
1.347 albertel 5749: }
5750:
5751: sub end_data_table {
1.610 albertel 5752: shift(@row_count);
1.389 albertel 5753: return '</table>'."\n";;
1.347 albertel 5754: }
5755:
5756: sub start_data_table_row {
1.422 albertel 5757: my ($add_class) = @_;
1.610 albertel 5758: $row_count[0]++;
5759: my $css_class = ($row_count[0] % 2)?'LC_odd_row':'LC_even_row';
1.428 albertel 5760: $css_class = (join(' ',$css_class,$add_class));
1.422 albertel 5761: return '<tr class="'.$css_class.'">'."\n";;
1.347 albertel 5762: }
1.471 banghart 5763:
5764: sub continue_data_table_row {
5765: my ($add_class) = @_;
1.610 albertel 5766: my $css_class = ($row_count[0] % 2)?'LC_odd_row':'LC_even_row';
1.471 banghart 5767: $css_class = (join(' ',$css_class,$add_class));
5768: return '<tr class="'.$css_class.'">'."\n";;
5769: }
1.347 albertel 5770:
5771: sub end_data_table_row {
1.389 albertel 5772: return '</tr>'."\n";;
1.347 albertel 5773: }
1.367 www 5774:
1.421 albertel 5775: sub start_data_table_empty_row {
1.610 albertel 5776: $row_count[0]++;
1.421 albertel 5777: return '<tr class="LC_empty_row" >'."\n";;
5778: }
5779:
5780: sub end_data_table_empty_row {
5781: return '</tr>'."\n";;
5782: }
5783:
1.367 www 5784: sub start_data_table_header_row {
1.389 albertel 5785: return '<tr class="LC_header_row">'."\n";;
1.367 www 5786: }
5787:
5788: sub end_data_table_header_row {
1.389 albertel 5789: return '</tr>'."\n";;
1.367 www 5790: }
1.347 albertel 5791: }
5792:
1.548 albertel 5793: =pod
5794:
5795: =item * &inhibit_menu_check($arg)
5796:
5797: Checks for a inhibitmenu state and generates output to preserve it
5798:
5799: Inputs: $arg - can be any of
5800: - undef - in which case the return value is a string
5801: to add into arguments list of a uri
5802: - 'input' - in which case the return value is a HTML
5803: <form> <input> field of type hidden to
5804: preserve the value
5805: - a url - in which case the return value is the url with
5806: the neccesary cgi args added to preserve the
5807: inhibitmenu state
5808: - a ref to a url - no return value, but the string is
5809: updated to include the neccessary cgi
5810: args to preserve the inhibitmenu state
5811:
5812: =cut
5813:
5814: sub inhibit_menu_check {
5815: my ($arg) = @_;
5816: &get_unprocessed_cgi($ENV{'QUERY_STRING'}, ['inhibitmenu']);
5817: if ($arg eq 'input') {
5818: if ($env{'form.inhibitmenu'}) {
5819: return '<input type="hidden" name="inhibitmenu" value="'.$env{'form.inhibitmenu'}.'" />';
5820: } else {
5821: return
5822: }
5823: }
5824: if ($env{'form.inhibitmenu'}) {
5825: if (ref($arg)) {
5826: $$arg .= '?inhibitmenu='.$env{'form.inhibitmenu'};
5827: } elsif ($arg eq '') {
5828: $arg .= 'inhibitmenu='.$env{'form.inhibitmenu'};
5829: } else {
5830: $arg .= '?inhibitmenu='.$env{'form.inhibitmenu'};
5831: }
5832: }
5833: if (!ref($arg)) {
5834: return $arg;
5835: }
5836: }
5837:
1.251 albertel 5838: ###############################################
1.182 matthew 5839:
5840: =pod
5841:
1.549 albertel 5842: =back
5843:
5844: =head1 User Information Routines
5845:
5846: =over 4
5847:
1.405 albertel 5848: =item * &get_users_function()
1.182 matthew 5849:
5850: Used by &bodytag to determine the current users primary role.
5851: Returns either 'student','coordinator','admin', or 'author'.
5852:
5853: =cut
5854:
5855: ###############################################
5856: sub get_users_function {
5857: my $function = 'student';
1.258 albertel 5858: if ($env{'request.role'}=~/^(cc|in|ta|ep)/) {
1.182 matthew 5859: $function='coordinator';
5860: }
1.258 albertel 5861: if ($env{'request.role'}=~/^(su|dc|ad|li)/) {
1.182 matthew 5862: $function='admin';
5863: }
1.258 albertel 5864: if (($env{'request.role'}=~/^(au|ca)/) ||
1.182 matthew 5865: ($ENV{'REQUEST_URI'}=~/^(\/priv|\~)/)) {
5866: $function='author';
5867: }
5868: return $function;
1.54 www 5869: }
1.99 www 5870:
5871: ###############################################
5872:
1.233 raeburn 5873: =pod
5874:
1.542 raeburn 5875: =item * &check_user_status()
1.274 raeburn 5876:
5877: Determines current status of supplied role for a
5878: specific user. Roles can be active, previous or future.
5879:
5880: Inputs:
5881: user's domain, user's username, course's domain,
1.375 raeburn 5882: course's number, optional section ID.
1.274 raeburn 5883:
5884: Outputs:
5885: role status: active, previous or future.
5886:
5887: =cut
5888:
5889: sub check_user_status {
1.412 raeburn 5890: my ($udom,$uname,$cdom,$crs,$role,$sec) = @_;
1.274 raeburn 5891: my %userinfo = &Apache::lonnet::dump('roles',$udom,$uname);
5892: my @uroles = keys %userinfo;
5893: my $srchstr;
5894: my $active_chk = 'none';
1.412 raeburn 5895: my $now = time;
1.274 raeburn 5896: if (@uroles > 0) {
1.412 raeburn 5897: if (($role eq 'cc') || ($sec eq '') || (!defined($sec))) {
1.274 raeburn 5898: $srchstr = '/'.$cdom.'/'.$crs.'_'.$role;
5899: } else {
1.412 raeburn 5900: $srchstr = '/'.$cdom.'/'.$crs.'/'.$sec.'_'.$role;
5901: }
5902: if (grep/^\Q$srchstr\E$/,@uroles) {
1.274 raeburn 5903: my $role_end = 0;
5904: my $role_start = 0;
5905: $active_chk = 'active';
1.412 raeburn 5906: if ($userinfo{$srchstr} =~ m/^\Q$role\E_(\d+)/) {
5907: $role_end = $1;
5908: if ($userinfo{$srchstr} =~ m/^\Q$role\E_\Q$role_end\E_(\d+)$/) {
5909: $role_start = $1;
1.274 raeburn 5910: }
5911: }
5912: if ($role_start > 0) {
1.412 raeburn 5913: if ($now < $role_start) {
1.274 raeburn 5914: $active_chk = 'future';
5915: }
5916: }
5917: if ($role_end > 0) {
1.412 raeburn 5918: if ($now > $role_end) {
1.274 raeburn 5919: $active_chk = 'previous';
5920: }
5921: }
5922: }
5923: }
5924: return $active_chk;
5925: }
5926:
5927: ###############################################
5928:
5929: =pod
5930:
1.405 albertel 5931: =item * &get_sections()
1.233 raeburn 5932:
5933: Determines all the sections for a course including
5934: sections with students and sections containing other roles.
1.419 raeburn 5935: Incoming parameters:
5936:
5937: 1. domain
5938: 2. course number
5939: 3. reference to array containing roles for which sections should
5940: be gathered (optional).
5941: 4. reference to array containing status types for which sections
5942: should be gathered (optional).
5943:
5944: If the third argument is undefined, sections are gathered for any role.
5945: If the fourth argument is undefined, sections are gathered for any status.
5946: Permissible values are 'active' or 'future' or 'previous'.
1.233 raeburn 5947:
1.374 raeburn 5948: Returns section hash (keys are section IDs, values are
5949: number of users in each section), subject to the
1.419 raeburn 5950: optional roles filter, optional status filter
1.233 raeburn 5951:
5952: =cut
5953:
5954: ###############################################
5955: sub get_sections {
1.419 raeburn 5956: my ($cdom,$cnum,$possible_roles,$possible_status) = @_;
1.366 albertel 5957: if (!defined($cdom) || !defined($cnum)) {
5958: my $cid = $env{'request.course.id'};
5959:
5960: return if (!defined($cid));
5961:
5962: $cdom = $env{'course.'.$cid.'.domain'};
5963: $cnum = $env{'course.'.$cid.'.num'};
5964: }
5965:
5966: my %sectioncount;
1.419 raeburn 5967: my $now = time;
1.240 albertel 5968:
1.366 albertel 5969: if (!defined($possible_roles) || (grep(/^st$/,@$possible_roles))) {
1.276 albertel 5970: my ($classlist) = &Apache::loncoursedata::get_classlist($cdom,$cnum);
1.240 albertel 5971: my $sec_index = &Apache::loncoursedata::CL_SECTION();
5972: my $status_index = &Apache::loncoursedata::CL_STATUS();
1.419 raeburn 5973: my $start_index = &Apache::loncoursedata::CL_START();
5974: my $end_index = &Apache::loncoursedata::CL_END();
5975: my $status;
1.366 albertel 5976: while (my ($student,$data) = each(%$classlist)) {
1.419 raeburn 5977: my ($section,$stu_status,$start,$end) = ($data->[$sec_index],
5978: $data->[$status_index],
5979: $data->[$start_index],
5980: $data->[$end_index]);
5981: if ($stu_status eq 'Active') {
5982: $status = 'active';
5983: } elsif ($end < $now) {
5984: $status = 'previous';
5985: } elsif ($start > $now) {
5986: $status = 'future';
5987: }
5988: if ($section ne '-1' && $section !~ /^\s*$/) {
5989: if ((!defined($possible_status)) || (($status ne '') &&
5990: (grep/^\Q$status\E$/,@{$possible_status}))) {
5991: $sectioncount{$section}++;
5992: }
1.240 albertel 5993: }
5994: }
5995: }
5996: my %courseroles = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum);
5997: foreach my $user (sort(keys(%courseroles))) {
5998: if ($user !~ /^(\w{2})/) { next; }
5999: my ($role) = ($user =~ /^(\w{2})/);
6000: if ($possible_roles && !(grep(/^$role$/,@$possible_roles))) { next; }
1.419 raeburn 6001: my ($section,$status);
1.240 albertel 6002: if ($role eq 'cr' &&
6003: $user =~ m-^$role/[^/]*/[^/]*/[^/]*:[^:]*:[^:]*:(\w+)-) {
6004: $section=$1;
6005: }
6006: if ($user =~ /^$role:[^:]*:[^:]*:(\w+)/) { $section=$1; }
6007: if (!defined($section) || $section eq '-1') { next; }
1.419 raeburn 6008: my ($end,$start) = ($courseroles{$user} =~ /^([^:]*):([^:]*)$/);
6009: if ($end == -1 && $start == -1) {
6010: next; #deleted role
6011: }
6012: if (!defined($possible_status)) {
6013: $sectioncount{$section}++;
6014: } else {
6015: if ((!$end || $end >= $now) && (!$start || $start <= $now)) {
6016: $status = 'active';
6017: } elsif ($end < $now) {
6018: $status = 'future';
6019: } elsif ($start > $now) {
6020: $status = 'previous';
6021: }
6022: if (($status ne '') && (grep/^\Q$status\E$/,@{$possible_status})) {
6023: $sectioncount{$section}++;
6024: }
6025: }
1.233 raeburn 6026: }
1.366 albertel 6027: return %sectioncount;
1.233 raeburn 6028: }
6029:
1.274 raeburn 6030: ###############################################
1.294 raeburn 6031:
6032: =pod
1.405 albertel 6033:
6034: =item * &get_course_users()
6035:
1.275 raeburn 6036: Retrieves usernames:domains for users in the specified course
6037: with specific role(s), and access status.
6038:
6039: Incoming parameters:
1.277 albertel 6040: 1. course domain
6041: 2. course number
6042: 3. access status: users must have - either active,
1.275 raeburn 6043: previous, future, or all.
1.277 albertel 6044: 4. reference to array of permissible roles
1.288 raeburn 6045: 5. reference to array of section restrictions (optional)
6046: 6. reference to results object (hash of hashes).
6047: 7. reference to optional userdata hash
1.609 raeburn 6048: 8. reference to optional statushash
1.630 raeburn 6049: 9. flag if privileged users (except those set to unhide in
6050: course settings) should be excluded
1.609 raeburn 6051: Keys of top level results hash are roles.
1.275 raeburn 6052: Keys of inner hashes are username:domain, with
6053: values set to access type.
1.288 raeburn 6054: Optional userdata hash returns an array with arguments in the
6055: same order as loncoursedata::get_classlist() for student data.
6056:
1.609 raeburn 6057: Optional statushash returns
6058:
1.288 raeburn 6059: Entries for end, start, section and status are blank because
6060: of the possibility of multiple values for non-student roles.
6061:
1.275 raeburn 6062: =cut
1.405 albertel 6063:
1.275 raeburn 6064: ###############################################
1.405 albertel 6065:
1.275 raeburn 6066: sub get_course_users {
1.630 raeburn 6067: my ($cdom,$cnum,$types,$roles,$sections,$users,$userdata,$statushash,$hidepriv) = @_;
1.288 raeburn 6068: my %idx = ();
1.419 raeburn 6069: my %seclists;
1.288 raeburn 6070:
6071: $idx{udom} = &Apache::loncoursedata::CL_SDOM();
6072: $idx{uname} = &Apache::loncoursedata::CL_SNAME();
6073: $idx{end} = &Apache::loncoursedata::CL_END();
6074: $idx{start} = &Apache::loncoursedata::CL_START();
6075: $idx{id} = &Apache::loncoursedata::CL_ID();
6076: $idx{section} = &Apache::loncoursedata::CL_SECTION();
6077: $idx{fullname} = &Apache::loncoursedata::CL_FULLNAME();
6078: $idx{status} = &Apache::loncoursedata::CL_STATUS();
6079:
1.290 albertel 6080: if (grep(/^st$/,@{$roles})) {
1.276 albertel 6081: my ($classlist,$keylist)=&Apache::loncoursedata::get_classlist($cdom,$cnum);
1.278 raeburn 6082: my $now = time;
1.277 albertel 6083: foreach my $student (keys(%{$classlist})) {
1.288 raeburn 6084: my $match = 0;
1.412 raeburn 6085: my $secmatch = 0;
1.419 raeburn 6086: my $section = $$classlist{$student}[$idx{section}];
1.609 raeburn 6087: my $status = $$classlist{$student}[$idx{status}];
1.419 raeburn 6088: if ($section eq '') {
6089: $section = 'none';
6090: }
1.291 albertel 6091: if ((ref($sections) eq 'ARRAY') && (@{$sections} > 0)) {
1.420 albertel 6092: if (grep(/^all$/,@{$sections})) {
1.412 raeburn 6093: $secmatch = 1;
6094: } elsif ($$classlist{$student}[$idx{section}] eq '') {
1.420 albertel 6095: if (grep(/^none$/,@{$sections})) {
1.412 raeburn 6096: $secmatch = 1;
6097: }
6098: } else {
1.419 raeburn 6099: if (grep(/^\Q$section\E$/,@{$sections})) {
1.412 raeburn 6100: $secmatch = 1;
6101: }
1.290 albertel 6102: }
1.412 raeburn 6103: if (!$secmatch) {
6104: next;
6105: }
1.419 raeburn 6106: }
1.275 raeburn 6107: if (defined($$types{'active'})) {
1.288 raeburn 6108: if ($$classlist{$student}[$idx{status}] eq 'Active') {
1.275 raeburn 6109: push(@{$$users{st}{$student}},'active');
1.288 raeburn 6110: $match = 1;
1.275 raeburn 6111: }
6112: }
6113: if (defined($$types{'previous'})) {
1.609 raeburn 6114: if ($$classlist{$student}[$idx{status}] eq 'Expired') {
1.275 raeburn 6115: push(@{$$users{st}{$student}},'previous');
1.288 raeburn 6116: $match = 1;
1.275 raeburn 6117: }
6118: }
6119: if (defined($$types{'future'})) {
1.609 raeburn 6120: if ($$classlist{$student}[$idx{status}] eq 'Future') {
1.275 raeburn 6121: push(@{$$users{st}{$student}},'future');
1.288 raeburn 6122: $match = 1;
1.275 raeburn 6123: }
6124: }
1.609 raeburn 6125: if ($match) {
6126: push(@{$seclists{$student}},$section);
6127: if (ref($userdata) eq 'HASH') {
6128: $$userdata{$student} = $$classlist{$student};
6129: }
6130: if (ref($statushash) eq 'HASH') {
6131: $statushash->{$student}{'st'}{$section} = $status;
6132: }
1.288 raeburn 6133: }
1.275 raeburn 6134: }
6135: }
1.412 raeburn 6136: if ((@{$roles} > 1) || ((@{$roles} == 1) && ($$roles[0] ne "st"))) {
1.439 raeburn 6137: my %coursepersonnel = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum);
6138: my $now = time;
1.609 raeburn 6139: my %displaystatus = ( previous => 'Expired',
6140: active => 'Active',
6141: future => 'Future',
6142: );
1.630 raeburn 6143: my %nothide;
6144: if ($hidepriv) {
6145: my %coursehash=&Apache::lonnet::coursedescription($cdom.'_'.$cnum);
6146: foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
6147: if ($user !~ /:/) {
6148: $nothide{join(':',split(/[\@]/,$user))}=1;
6149: } else {
6150: $nothide{$user} = 1;
6151: }
6152: }
6153: }
1.439 raeburn 6154: foreach my $person (sort(keys(%coursepersonnel))) {
1.288 raeburn 6155: my $match = 0;
1.412 raeburn 6156: my $secmatch = 0;
1.439 raeburn 6157: my $status;
1.412 raeburn 6158: my ($role,$user,$usec) = ($person =~ /^([^:]*):([^:]+:[^:]+):([^:]*)/);
1.275 raeburn 6159: $user =~ s/:$//;
1.439 raeburn 6160: my ($end,$start) = split(/:/,$coursepersonnel{$person});
6161: if ($end == -1 || $start == -1) {
6162: next;
6163: }
6164: if (($role) && ((grep(/^\Q$role\E$/,@{$roles})) ||
6165: (grep(/^cr$/,@{$roles}) && $role =~ /^cr\//))) {
1.412 raeburn 6166: my ($uname,$udom) = split(/:/,$user);
6167: if ((ref($sections) eq 'ARRAY') && (@{$sections} > 0)) {
1.420 albertel 6168: if (grep(/^all$/,@{$sections})) {
1.412 raeburn 6169: $secmatch = 1;
6170: } elsif ($usec eq '') {
1.420 albertel 6171: if (grep(/^none$/,@{$sections})) {
1.412 raeburn 6172: $secmatch = 1;
6173: }
6174: } else {
6175: if (grep(/^\Q$usec\E$/,@{$sections})) {
6176: $secmatch = 1;
6177: }
6178: }
6179: if (!$secmatch) {
6180: next;
6181: }
1.288 raeburn 6182: }
1.419 raeburn 6183: if ($usec eq '') {
6184: $usec = 'none';
6185: }
1.275 raeburn 6186: if ($uname ne '' && $udom ne '') {
1.630 raeburn 6187: if ($hidepriv) {
6188: if ((&Apache::lonnet::privileged($uname,$udom)) &&
6189: (!$nothide{$uname.':'.$udom})) {
6190: next;
6191: }
6192: }
1.503 raeburn 6193: if ($end > 0 && $end < $now) {
1.439 raeburn 6194: $status = 'previous';
6195: } elsif ($start > $now) {
6196: $status = 'future';
6197: } else {
6198: $status = 'active';
6199: }
1.277 albertel 6200: foreach my $type (keys(%{$types})) {
1.275 raeburn 6201: if ($status eq $type) {
1.420 albertel 6202: if (!grep(/^\Q$type\E$/,@{$$users{$role}{$user}})) {
1.419 raeburn 6203: push(@{$$users{$role}{$user}},$type);
6204: }
1.288 raeburn 6205: $match = 1;
6206: }
6207: }
1.419 raeburn 6208: if (($match) && (ref($userdata) eq 'HASH')) {
6209: if (!exists($$userdata{$uname.':'.$udom})) {
6210: &get_user_info($udom,$uname,\%idx,$userdata);
6211: }
1.420 albertel 6212: if (!grep(/^\Q$usec\E$/,@{$seclists{$uname.':'.$udom}})) {
1.419 raeburn 6213: push(@{$seclists{$uname.':'.$udom}},$usec);
6214: }
1.609 raeburn 6215: if (ref($statushash) eq 'HASH') {
6216: $statushash->{$uname.':'.$udom}{$role}{$usec} = $displaystatus{$status};
6217: }
1.275 raeburn 6218: }
6219: }
6220: }
6221: }
1.290 albertel 6222: if (grep(/^ow$/,@{$roles})) {
1.279 raeburn 6223: if ((defined($cdom)) && (defined($cnum))) {
6224: my %csettings = &Apache::lonnet::get('environment',['internal.courseowner'],$cdom,$cnum);
6225: if ( defined($csettings{'internal.courseowner'}) ) {
6226: my $owner = $csettings{'internal.courseowner'};
1.609 raeburn 6227: next if ($owner eq '');
6228: my ($ownername,$ownerdom);
6229: if ($owner =~ /^([^:]+):([^:]+)$/) {
6230: $ownername = $1;
6231: $ownerdom = $2;
6232: } else {
6233: $ownername = $owner;
6234: $ownerdom = $cdom;
6235: $owner = $ownername.':'.$ownerdom;
1.439 raeburn 6236: }
6237: @{$$users{'ow'}{$owner}} = 'any';
1.290 albertel 6238: if (defined($userdata) &&
1.609 raeburn 6239: !exists($$userdata{$owner})) {
6240: &get_user_info($ownerdom,$ownername,\%idx,$userdata);
6241: if (!grep(/^none$/,@{$seclists{$owner}})) {
6242: push(@{$seclists{$owner}},'none');
6243: }
6244: if (ref($statushash) eq 'HASH') {
6245: $statushash->{$owner}{'ow'}{'none'} = 'Any';
1.419 raeburn 6246: }
1.290 albertel 6247: }
1.279 raeburn 6248: }
6249: }
6250: }
1.419 raeburn 6251: foreach my $user (keys(%seclists)) {
6252: @{$seclists{$user}} = (sort {$a <=> $b} @{$seclists{$user}});
6253: $$userdata{$user}[$idx{section}] = join(',',@{$seclists{$user}});
6254: }
1.275 raeburn 6255: }
6256: return;
6257: }
6258:
1.288 raeburn 6259: sub get_user_info {
6260: my ($udom,$uname,$idx,$userdata) = @_;
1.289 albertel 6261: $$userdata{$uname.':'.$udom}[$$idx{fullname}] =
6262: &plainname($uname,$udom,'lastname');
1.291 albertel 6263: $$userdata{$uname.':'.$udom}[$$idx{uname}] = $uname;
1.297 raeburn 6264: $$userdata{$uname.':'.$udom}[$$idx{udom}] = $udom;
1.609 raeburn 6265: my %idhash = &Apache::lonnet::idrget($udom,($uname));
6266: $$userdata{$uname.':'.$udom}[$$idx{id}] = $idhash{$uname};
1.288 raeburn 6267: return;
6268: }
1.275 raeburn 6269:
1.472 raeburn 6270: ###############################################
6271:
6272: =pod
6273:
6274: =item * &get_user_quota()
6275:
6276: Retrieves quota assigned for storage of portfolio files for a user
6277:
6278: Incoming parameters:
6279: 1. user's username
6280: 2. user's domain
6281:
6282: Returns:
1.536 raeburn 6283: 1. Disk quota (in Mb) assigned to student.
6284: 2. (Optional) Type of setting: custom or default
6285: (individually assigned or default for user's
6286: institutional status).
6287: 3. (Optional) - User's institutional status (e.g., faculty, staff
6288: or student - types as defined in localenroll::inst_usertypes
6289: for user's domain, which determines default quota for user.
6290: 4. (Optional) - Default quota which would apply to the user.
1.472 raeburn 6291:
6292: If a value has been stored in the user's environment,
1.536 raeburn 6293: it will return that, otherwise it returns the maximal default
6294: defined for the user's instituional status(es) in the domain.
1.472 raeburn 6295:
6296: =cut
6297:
6298: ###############################################
6299:
6300:
6301: sub get_user_quota {
6302: my ($uname,$udom) = @_;
1.536 raeburn 6303: my ($quota,$quotatype,$settingstatus,$defquota);
1.472 raeburn 6304: if (!defined($udom)) {
6305: $udom = $env{'user.domain'};
6306: }
6307: if (!defined($uname)) {
6308: $uname = $env{'user.name'};
6309: }
6310: if (($udom eq '' || $uname eq '') ||
6311: ($udom eq 'public') && ($uname eq 'public')) {
6312: $quota = 0;
1.536 raeburn 6313: $quotatype = 'default';
6314: $defquota = 0;
1.472 raeburn 6315: } else {
1.536 raeburn 6316: my $inststatus;
1.472 raeburn 6317: if ($udom eq $env{'user.domain'} && $uname eq $env{'user.name'}) {
6318: $quota = $env{'environment.portfolioquota'};
1.536 raeburn 6319: $inststatus = $env{'environment.inststatus'};
1.472 raeburn 6320: } else {
1.536 raeburn 6321: my %userenv =
6322: &Apache::lonnet::get('environment',['portfolioquota',
6323: 'inststatus'],$udom,$uname);
1.472 raeburn 6324: my ($tmp) = keys(%userenv);
6325: if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
6326: $quota = $userenv{'portfolioquota'};
1.536 raeburn 6327: $inststatus = $userenv{'inststatus'};
1.472 raeburn 6328: } else {
6329: undef(%userenv);
6330: }
6331: }
1.536 raeburn 6332: ($defquota,$settingstatus) = &default_quota($udom,$inststatus);
1.472 raeburn 6333: if ($quota eq '') {
1.536 raeburn 6334: $quota = $defquota;
6335: $quotatype = 'default';
6336: } else {
6337: $quotatype = 'custom';
1.472 raeburn 6338: }
6339: }
1.536 raeburn 6340: if (wantarray) {
6341: return ($quota,$quotatype,$settingstatus,$defquota);
6342: } else {
6343: return $quota;
6344: }
1.472 raeburn 6345: }
6346:
6347: ###############################################
6348:
6349: =pod
6350:
6351: =item * &default_quota()
6352:
1.536 raeburn 6353: Retrieves default quota assigned for storage of user portfolio files,
6354: given an (optional) user's institutional status.
1.472 raeburn 6355:
6356: Incoming parameters:
6357: 1. domain
1.536 raeburn 6358: 2. (Optional) institutional status(es). This is a : separated list of
6359: status types (e.g., faculty, staff, student etc.)
6360: which apply to the user for whom the default is being retrieved.
6361: If the institutional status string in undefined, the domain
6362: default quota will be returned.
1.472 raeburn 6363:
6364: Returns:
6365: 1. Default disk quota (in Mb) for user portfolios in the domain.
1.536 raeburn 6366: 2. (Optional) institutional type which determined the value of the
6367: default quota.
1.472 raeburn 6368:
6369: If a value has been stored in the domain's configuration db,
6370: it will return that, otherwise it returns 20 (for backwards
6371: compatibility with domains which have not set up a configuration
6372: db file; the original statically defined portfolio quota was 20 Mb).
6373:
1.536 raeburn 6374: If the user's status includes multiple types (e.g., staff and student),
6375: the largest default quota which applies to the user determines the
6376: default quota returned.
6377:
1.472 raeburn 6378: =cut
6379:
6380: ###############################################
6381:
6382:
6383: sub default_quota {
1.536 raeburn 6384: my ($udom,$inststatus) = @_;
6385: my ($defquota,$settingstatus);
6386: my %quotahash = &Apache::lonnet::get_dom('configuration',
1.622 raeburn 6387: ['quotas'],$udom);
6388: if (ref($quotahash{'quotas'}) eq 'HASH') {
1.536 raeburn 6389: if ($inststatus ne '') {
6390: my @statuses = split(/:/,$inststatus);
6391: foreach my $item (@statuses) {
1.622 raeburn 6392: if ($quotahash{'quotas'}{$item} ne '') {
1.536 raeburn 6393: if ($defquota eq '') {
1.622 raeburn 6394: $defquota = $quotahash{'quotas'}{$item};
1.536 raeburn 6395: $settingstatus = $item;
1.622 raeburn 6396: } elsif ($quotahash{'quotas'}{$item} > $defquota) {
6397: $defquota = $quotahash{'quotas'}{$item};
1.536 raeburn 6398: $settingstatus = $item;
6399: }
6400: }
6401: }
6402: }
6403: if ($defquota eq '') {
1.622 raeburn 6404: $defquota = $quotahash{'quotas'}{'default'};
1.536 raeburn 6405: $settingstatus = 'default';
6406: }
6407: } else {
6408: $settingstatus = 'default';
6409: $defquota = 20;
6410: }
6411: if (wantarray) {
6412: return ($defquota,$settingstatus);
1.472 raeburn 6413: } else {
1.536 raeburn 6414: return $defquota;
1.472 raeburn 6415: }
6416: }
6417:
1.384 raeburn 6418: sub get_secgrprole_info {
6419: my ($cdom,$cnum,$needroles,$type) = @_;
6420: my %sections_count = &get_sections($cdom,$cnum);
6421: my @sections = (sort {$a <=> $b} keys(%sections_count));
6422: my %curr_groups = &Apache::longroup::coursegroups($cdom,$cnum);
6423: my @groups = sort(keys(%curr_groups));
6424: my $allroles = [];
6425: my $rolehash;
6426: my $accesshash = {
6427: active => 'Currently has access',
6428: future => 'Will have future access',
6429: previous => 'Previously had access',
6430: };
6431: if ($needroles) {
6432: $rolehash = {'all' => 'all'};
1.385 albertel 6433: my %user_roles = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum);
6434: if (&Apache::lonnet::error(%user_roles)) {
6435: undef(%user_roles);
6436: }
6437: foreach my $item (keys(%user_roles)) {
1.384 raeburn 6438: my ($role)=split(/\:/,$item,2);
6439: if ($role eq 'cr') { next; }
6440: if ($role =~ /^cr/) {
6441: $$rolehash{$role} = (split('/',$role))[3];
6442: } else {
6443: $$rolehash{$role} = &Apache::lonnet::plaintext($role,$type);
6444: }
6445: }
6446: foreach my $key (sort(keys(%{$rolehash}))) {
6447: push(@{$allroles},$key);
6448: }
6449: push (@{$allroles},'st');
6450: $$rolehash{'st'} = &Apache::lonnet::plaintext('st',$type);
6451: }
6452: return (\@sections,\@groups,$allroles,$rolehash,$accesshash);
6453: }
6454:
1.555 raeburn 6455: sub user_picker {
1.627 raeburn 6456: my ($dom,$srch,$forcenewuser,$caller,$cancreate,$usertype) = @_;
1.555 raeburn 6457: my $currdom = $dom;
6458: my %curr_selected = (
6459: srchin => 'dom',
1.580 raeburn 6460: srchby => 'lastname',
1.555 raeburn 6461: );
6462: my $srchterm;
1.625 raeburn 6463: if ((ref($srch) eq 'HASH') && ($env{'form.origform'} ne 'crtusername')) {
1.555 raeburn 6464: if ($srch->{'srchby'} ne '') {
6465: $curr_selected{'srchby'} = $srch->{'srchby'};
6466: }
6467: if ($srch->{'srchin'} ne '') {
6468: $curr_selected{'srchin'} = $srch->{'srchin'};
6469: }
6470: if ($srch->{'srchtype'} ne '') {
6471: $curr_selected{'srchtype'} = $srch->{'srchtype'};
6472: }
6473: if ($srch->{'srchdomain'} ne '') {
6474: $currdom = $srch->{'srchdomain'};
6475: }
6476: $srchterm = $srch->{'srchterm'};
6477: }
6478: my %lt=&Apache::lonlocal::texthash(
1.573 raeburn 6479: 'usr' => 'Search criteria',
1.563 raeburn 6480: 'doma' => 'Domain/institution to search',
1.558 albertel 6481: 'uname' => 'username',
6482: 'lastname' => 'last name',
1.555 raeburn 6483: 'lastfirst' => 'last name, first name',
1.558 albertel 6484: 'crs' => 'in this course',
1.576 raeburn 6485: 'dom' => 'in selected LON-CAPA domain',
1.558 albertel 6486: 'alc' => 'all LON-CAPA',
1.573 raeburn 6487: 'instd' => 'in institutional directory for selected domain',
1.558 albertel 6488: 'exact' => 'is',
6489: 'contains' => 'contains',
1.569 raeburn 6490: 'begins' => 'begins with',
1.571 raeburn 6491: 'youm' => "You must include some text to search for.",
6492: 'thte' => "The text you are searching for must contain at least two characters when using a 'begins' type search.",
6493: 'thet' => "The text you are searching for must contain at least three characters when using a 'contains' type search.",
6494: 'yomc' => "You must choose a domain when using an institutional directory search.",
6495: 'ymcd' => "You must choose a domain when using a domain search.",
6496: 'whus' => "When using searching by last,first you must include a comma as separator between last name and first name.",
6497: 'whse' => "When searching by last,first you must include at least one character in the first name.",
6498: 'thfo' => "The following need to be corrected before the search can be run:",
1.555 raeburn 6499: );
1.563 raeburn 6500: my $domform = &select_dom_form($currdom,'srchdomain',1,1);
6501: my $srchinsel = ' <select name="srchin">';
1.555 raeburn 6502:
6503: my @srchins = ('crs','dom','alc','instd');
6504:
6505: foreach my $option (@srchins) {
6506: # FIXME 'alc' option unavailable until
6507: # loncreateuser::print_user_query_page()
6508: # has been completed.
6509: next if ($option eq 'alc');
6510: next if ($option eq 'crs' && !$env{'request.course.id'});
1.563 raeburn 6511: if ($curr_selected{'srchin'} eq $option) {
6512: $srchinsel .= '
6513: <option value="'.$option.'" selected="selected">'.$lt{$option}.'</option>';
6514: } else {
6515: $srchinsel .= '
6516: <option value="'.$option.'">'.$lt{$option}.'</option>';
6517: }
1.555 raeburn 6518: }
1.563 raeburn 6519: $srchinsel .= "\n </select>\n";
1.555 raeburn 6520:
6521: my $srchbysel = ' <select name="srchby">';
1.580 raeburn 6522: foreach my $option ('lastname','lastfirst','uname') {
1.555 raeburn 6523: if ($curr_selected{'srchby'} eq $option) {
6524: $srchbysel .= '
6525: <option value="'.$option.'" selected="selected">'.$lt{$option}.'</option>';
6526: } else {
6527: $srchbysel .= '
6528: <option value="'.$option.'">'.$lt{$option}.'</option>';
6529: }
6530: }
6531: $srchbysel .= "\n </select>\n";
6532:
6533: my $srchtypesel = ' <select name="srchtype">';
1.580 raeburn 6534: foreach my $option ('begins','contains','exact') {
1.555 raeburn 6535: if ($curr_selected{'srchtype'} eq $option) {
6536: $srchtypesel .= '
6537: <option value="'.$option.'" selected="selected">'.$lt{$option}.'</option>';
6538: } else {
6539: $srchtypesel .= '
6540: <option value="'.$option.'">'.$lt{$option}.'</option>';
6541: }
6542: }
6543: $srchtypesel .= "\n </select>\n";
6544:
1.558 albertel 6545: my ($newuserscript,$new_user_create);
1.556 raeburn 6546:
6547: if ($forcenewuser) {
1.576 raeburn 6548: if (ref($srch) eq 'HASH') {
6549: if ($srch->{'srchby'} eq 'uname' && $srch->{'srchtype'} eq 'exact' && $srch->{'srchin'} eq 'dom' && $srch->{'srchdomain'} eq $env{'request.role.domain'}) {
1.627 raeburn 6550: if ($cancreate) {
6551: $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>';
6552: } else {
6553: my $helplink = ' href="javascript:helpMenu('."'display'".')"';
6554: my %usertypetext = (
6555: official => 'institutional',
6556: unofficial => 'non-institutional',
6557: );
6558: $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 />';
6559: }
1.576 raeburn 6560: }
6561: }
6562:
1.556 raeburn 6563: $newuserscript = <<"ENDSCRIPT";
6564:
1.570 raeburn 6565: function setSearch(createnew,callingForm) {
1.556 raeburn 6566: if (createnew == 1) {
1.570 raeburn 6567: for (var i=0; i<callingForm.srchby.length; i++) {
6568: if (callingForm.srchby.options[i].value == 'uname') {
6569: callingForm.srchby.selectedIndex = i;
1.556 raeburn 6570: }
6571: }
1.570 raeburn 6572: for (var i=0; i<callingForm.srchin.length; i++) {
6573: if ( callingForm.srchin.options[i].value == 'dom') {
6574: callingForm.srchin.selectedIndex = i;
1.556 raeburn 6575: }
6576: }
1.570 raeburn 6577: for (var i=0; i<callingForm.srchtype.length; i++) {
6578: if (callingForm.srchtype.options[i].value == 'exact') {
6579: callingForm.srchtype.selectedIndex = i;
1.556 raeburn 6580: }
6581: }
1.570 raeburn 6582: for (var i=0; i<callingForm.srchdomain.length; i++) {
6583: if (callingForm.srchdomain.options[i].value == '$env{'request.role.domain'}') {
6584: callingForm.srchdomain.selectedIndex = i;
1.556 raeburn 6585: }
6586: }
6587: }
6588: }
6589: ENDSCRIPT
1.558 albertel 6590:
1.556 raeburn 6591: }
6592:
1.555 raeburn 6593: my $output = <<"END_BLOCK";
1.556 raeburn 6594: <script type="text/javascript">
1.570 raeburn 6595: function validateEntry(callingForm) {
1.558 albertel 6596:
1.556 raeburn 6597: var checkok = 1;
1.558 albertel 6598: var srchin;
1.570 raeburn 6599: for (var i=0; i<callingForm.srchin.length; i++) {
6600: if ( callingForm.srchin[i].checked ) {
6601: srchin = callingForm.srchin[i].value;
1.558 albertel 6602: }
6603: }
6604:
1.570 raeburn 6605: var srchtype = callingForm.srchtype.options[callingForm.srchtype.selectedIndex].value;
6606: var srchby = callingForm.srchby.options[callingForm.srchby.selectedIndex].value;
6607: var srchdomain = callingForm.srchdomain.options[callingForm.srchdomain.selectedIndex].value;
6608: var srchterm = callingForm.srchterm.value;
6609: var srchin = callingForm.srchin.options[callingForm.srchin.selectedIndex].value;
1.556 raeburn 6610: var msg = "";
6611:
6612: if (srchterm == "") {
6613: checkok = 0;
1.571 raeburn 6614: msg += "$lt{'youm'}\\n";
1.556 raeburn 6615: }
6616:
1.569 raeburn 6617: if (srchtype== 'begins') {
6618: if (srchterm.length < 2) {
6619: checkok = 0;
1.571 raeburn 6620: msg += "$lt{'thte'}\\n";
1.569 raeburn 6621: }
6622: }
6623:
1.556 raeburn 6624: if (srchtype== 'contains') {
6625: if (srchterm.length < 3) {
6626: checkok = 0;
1.571 raeburn 6627: msg += "$lt{'thet'}\\n";
1.556 raeburn 6628: }
6629: }
6630: if (srchin == 'instd') {
6631: if (srchdomain == '') {
6632: checkok = 0;
1.571 raeburn 6633: msg += "$lt{'yomc'}\\n";
1.556 raeburn 6634: }
6635: }
6636: if (srchin == 'dom') {
6637: if (srchdomain == '') {
6638: checkok = 0;
1.571 raeburn 6639: msg += "$lt{'ymcd'}\\n";
1.556 raeburn 6640: }
6641: }
6642: if (srchby == 'lastfirst') {
6643: if (srchterm.indexOf(",") == -1) {
6644: checkok = 0;
1.571 raeburn 6645: msg += "$lt{'whus'}\\n";
1.556 raeburn 6646: }
6647: if (srchterm.indexOf(",") == srchterm.length -1) {
6648: checkok = 0;
1.571 raeburn 6649: msg += "$lt{'whse'}\\n";
1.556 raeburn 6650: }
6651: }
6652: if (checkok == 0) {
1.571 raeburn 6653: alert("$lt{'thfo'}\\n"+msg);
1.556 raeburn 6654: return;
6655: }
6656: if (checkok == 1) {
1.570 raeburn 6657: callingForm.submit();
1.556 raeburn 6658: }
6659: }
6660:
6661: $newuserscript
6662:
6663: </script>
1.558 albertel 6664:
6665: $new_user_create
6666:
1.555 raeburn 6667: <table>
1.558 albertel 6668: <tr>
1.573 raeburn 6669: <td>$lt{'doma'}:</td>
6670: <td>$domform</td>
6671: </td>
6672: </tr>
6673: <tr>
6674: <td>$lt{'usr'}:</td>
1.563 raeburn 6675: <td>$srchbysel
6676: $srchtypesel
6677: <input type="text" size="15" name="srchterm" value="$srchterm" />
1.564 albertel 6678: $srchinsel
1.563 raeburn 6679: </td>
6680: </tr>
1.555 raeburn 6681: </table>
6682: <br />
6683: END_BLOCK
1.558 albertel 6684:
1.555 raeburn 6685: return $output;
6686: }
6687:
1.612 raeburn 6688: sub user_rule_check {
1.615 raeburn 6689: my ($usershash,$checks,$alerts,$rulematch,$inst_results,$curr_rules,$got_rules) = @_;
1.612 raeburn 6690: my $response;
6691: if (ref($usershash) eq 'HASH') {
6692: foreach my $user (keys(%{$usershash})) {
6693: my ($uname,$udom) = split(/:/,$user);
6694: next if ($udom eq '' || $uname eq '');
1.615 raeburn 6695: my ($id,$newuser);
1.612 raeburn 6696: if (ref($usershash->{$user}) eq 'HASH') {
1.615 raeburn 6697: $newuser = $usershash->{$user}->{'newuser'};
1.612 raeburn 6698: $id = $usershash->{$user}->{'id'};
6699: }
6700: my $inst_response;
6701: if (ref($checks) eq 'HASH') {
6702: if (defined($checks->{'username'})) {
1.615 raeburn 6703: ($inst_response,%{$inst_results->{$user}}) =
1.612 raeburn 6704: &Apache::lonnet::get_instuser($udom,$uname);
6705: } elsif (defined($checks->{'id'})) {
1.615 raeburn 6706: ($inst_response,%{$inst_results->{$user}}) =
1.612 raeburn 6707: &Apache::lonnet::get_instuser($udom,undef,$id);
6708: }
1.615 raeburn 6709: } else {
6710: ($inst_response,%{$inst_results->{$user}}) =
6711: &Apache::lonnet::get_instuser($udom,$uname);
6712: return;
1.612 raeburn 6713: }
1.615 raeburn 6714: if (!$got_rules->{$udom}) {
1.612 raeburn 6715: my %domconfig = &Apache::lonnet::get_dom('configuration',
6716: ['usercreation'],$udom);
6717: if (ref($domconfig{'usercreation'}) eq 'HASH') {
1.615 raeburn 6718: foreach my $item ('username','id') {
1.612 raeburn 6719: if (ref($domconfig{'usercreation'}{$item.'_rule'}) eq 'ARRAY') {
6720: $$curr_rules{$udom}{$item} =
6721: $domconfig{'usercreation'}{$item.'_rule'};
1.585 raeburn 6722: }
6723: }
6724: }
1.615 raeburn 6725: $got_rules->{$udom} = 1;
1.585 raeburn 6726: }
1.612 raeburn 6727: foreach my $item (keys(%{$checks})) {
6728: if (ref($$curr_rules{$udom}) eq 'HASH') {
6729: if (ref($$curr_rules{$udom}{$item}) eq 'ARRAY') {
6730: if (@{$$curr_rules{$udom}{$item}} > 0) {
6731: my %rule_check = &Apache::lonnet::inst_rulecheck($udom,$uname,$id,$item,$$curr_rules{$udom}{$item});
6732: foreach my $rule (@{$$curr_rules{$udom}{$item}}) {
6733: if ($rule_check{$rule}) {
6734: $$rulematch{$user}{$item} = $rule;
6735: if ($inst_response eq 'ok') {
1.615 raeburn 6736: if (ref($inst_results) eq 'HASH') {
6737: if (ref($inst_results->{$user}) eq 'HASH') {
6738: if (keys(%{$inst_results->{$user}}) == 0) {
6739: $$alerts{$item}{$udom}{$uname} = 1;
6740: }
1.612 raeburn 6741: }
6742: }
1.615 raeburn 6743: }
6744: last;
1.585 raeburn 6745: }
6746: }
6747: }
6748: }
6749: }
6750: }
6751: }
6752: }
1.612 raeburn 6753: return;
6754: }
6755:
6756: sub user_rule_formats {
6757: my ($domain,$domdesc,$curr_rules,$check) = @_;
6758: my %text = (
6759: 'username' => 'Usernames',
6760: 'id' => 'IDs',
6761: );
6762: my $output;
6763: my ($rules,$ruleorder) = &Apache::lonnet::inst_userrules($domain,$check);
6764: if ((ref($rules) eq 'HASH') && (ref($ruleorder) eq 'ARRAY')) {
6765: if (@{$ruleorder} > 0) {
6766: $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>';
6767: foreach my $rule (@{$ruleorder}) {
6768: if (ref($curr_rules) eq 'ARRAY') {
6769: if (grep(/^\Q$rule\E$/,@{$curr_rules})) {
6770: if (ref($rules->{$rule}) eq 'HASH') {
6771: $output .= '<li>'.$rules->{$rule}{'name'}.': '.
6772: $rules->{$rule}{'desc'}.'</li>';
6773: }
6774: }
6775: }
6776: }
6777: $output .= '</ul>';
6778: }
6779: }
6780: return $output;
6781: }
6782:
6783: sub instrule_disallow_msg {
1.615 raeburn 6784: my ($checkitem,$domdesc,$count,$mode) = @_;
1.612 raeburn 6785: my $response;
6786: my %text = (
6787: item => 'username',
6788: items => 'usernames',
6789: match => 'matches',
6790: do => 'does',
6791: action => 'a username',
6792: one => 'one',
6793: );
6794: if ($count > 1) {
6795: $text{'item'} = 'usernames';
6796: $text{'match'} ='match';
6797: $text{'do'} = 'do';
6798: $text{'action'} = 'usernames',
6799: $text{'one'} = 'ones';
6800: }
6801: if ($checkitem eq 'id') {
6802: $text{'items'} = 'IDs';
6803: $text{'item'} = 'ID';
6804: $text{'action'} = 'an ID';
1.615 raeburn 6805: if ($count > 1) {
6806: $text{'item'} = 'IDs';
6807: $text{'action'} = 'IDs';
6808: }
1.612 raeburn 6809: }
6810: $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 6811: if ($mode eq 'upload') {
6812: if ($checkitem eq 'username') {
6813: $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'}.");
6814: } elsif ($checkitem eq 'id') {
6815: $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.");
6816: }
6817: } else {
6818: if ($checkitem eq 'username') {
6819: $response .= &mt("You must choose $text{'action'} with a different format -- $text{'one'} that will not conflict with 'official' institutional $text{'items'}.");
6820: } elsif ($checkitem eq 'id') {
6821: $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.");
6822: }
1.612 raeburn 6823: }
6824: return $response;
1.585 raeburn 6825: }
6826:
1.624 raeburn 6827: sub personal_data_fieldtitles {
6828: my %fieldtitles = &Apache::lonlocal::texthash (
6829: id => 'Student/Employee ID',
6830: permanentemail => 'E-mail address',
6831: lastname => 'Last Name',
6832: firstname => 'First Name',
6833: middlename => 'Middle Name',
6834: generation => 'Generation',
6835: gen => 'Generation',
6836: );
6837: return %fieldtitles;
6838: }
6839:
1.642 raeburn 6840: sub sorted_inst_types {
6841: my ($dom) = @_;
6842: my ($usertypes,$order) = &Apache::lonnet::retrieve_inst_usertypes($dom);
6843: my $othertitle = &mt('All users');
6844: if ($env{'request.course.id'}) {
6845: $othertitle = 'any';
6846: }
6847: my @types;
6848: if (ref($order) eq 'ARRAY') {
6849: @types = @{$order};
6850: }
6851: if (@types == 0) {
6852: if (ref($usertypes) eq 'HASH') {
6853: @types = sort(keys(%{$usertypes}));
6854: }
6855: }
6856: if (keys(%{$usertypes}) > 0) {
6857: $othertitle = &mt('Other users');
6858: if ($env{'request.course.id'}) {
6859: $othertitle = 'other';
6860: }
6861: }
6862: return ($othertitle,$usertypes,\@types);
6863: }
6864:
1.645 raeburn 6865: sub get_institutional_codes {
6866: my ($settings,$allcourses,$LC_code) = @_;
6867: # Get complete list of course sections to update
6868: my @currsections = ();
6869: my @currxlists = ();
6870: my $coursecode = $$settings{'internal.coursecode'};
6871:
6872: if ($$settings{'internal.sectionnums'} ne '') {
6873: @currsections = split(/,/,$$settings{'internal.sectionnums'});
6874: }
6875:
6876: if ($$settings{'internal.crosslistings'} ne '') {
6877: @currxlists = split(/,/,$$settings{'internal.crosslistings'});
6878: }
6879:
6880: if (@currxlists > 0) {
6881: foreach (@currxlists) {
6882: if (m/^([^:]+):(\w*)$/) {
6883: unless (grep/^$1$/,@{$allcourses}) {
6884: push @{$allcourses},$1;
6885: $$LC_code{$1} = $2;
6886: }
6887: }
6888: }
6889: }
6890:
6891: if (@currsections > 0) {
6892: foreach (@currsections) {
6893: if (m/^(\w+):(\w*)$/) {
6894: my $sec = $coursecode.$1;
6895: my $lc_sec = $2;
6896: unless (grep/^$sec$/,@{$allcourses}) {
6897: push @{$allcourses},$sec;
6898: $$LC_code{$sec} = $lc_sec;
6899: }
6900: }
6901: }
6902: }
6903: return;
6904: }
6905:
1.112 bowersj2 6906: =pod
6907:
1.549 albertel 6908: =back
6909:
6910: =head1 HTTP Helpers
6911:
6912: =over 4
6913:
1.648 raeburn 6914: =item * &get_unprocessed_cgi($query,$possible_names)
1.112 bowersj2 6915:
1.258 albertel 6916: Modify the %env hash to contain unprocessed CGI form parameters held in
1.112 bowersj2 6917: $query. The parameters listed in $possible_names (an array reference),
1.258 albertel 6918: will be set in $env{'form.name'} if they do not already exist.
1.112 bowersj2 6919:
6920: Typically called with $ENV{'QUERY_STRING'} as the first parameter.
6921: $possible_names is an ref to an array of form element names. As an example:
6922: get_unprocessed_cgi($ENV{'QUERY_STRING'},['uname','udom']);
1.258 albertel 6923: will result in $env{'form.uname'} and $env{'form.udom'} being set.
1.112 bowersj2 6924:
6925: =cut
1.1 albertel 6926:
1.6 albertel 6927: sub get_unprocessed_cgi {
1.25 albertel 6928: my ($query,$possible_names)= @_;
1.26 matthew 6929: # $Apache::lonxml::debug=1;
1.356 albertel 6930: foreach my $pair (split(/&/,$query)) {
6931: my ($name, $value) = split(/=/,$pair);
1.369 www 6932: $name = &unescape($name);
1.25 albertel 6933: if (!defined($possible_names) || (grep {$_ eq $name} @$possible_names)) {
6934: $value =~ tr/+/ /;
6935: $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
1.258 albertel 6936: unless (defined($env{'form.'.$name})) { &add_to_env('form.'.$name,$value) };
1.25 albertel 6937: }
1.16 harris41 6938: }
1.6 albertel 6939: }
6940:
1.112 bowersj2 6941: =pod
6942:
1.648 raeburn 6943: =item * &cacheheader()
1.112 bowersj2 6944:
6945: returns cache-controlling header code
6946:
6947: =cut
6948:
1.7 albertel 6949: sub cacheheader {
1.258 albertel 6950: unless ($env{'request.method'} eq 'GET') { return ''; }
1.216 albertel 6951: my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
6952: my $output .='<meta HTTP-EQUIV="Expires" CONTENT="'.$date.'" />
1.7 albertel 6953: <meta HTTP-EQUIV="Cache-control" CONTENT="no-cache" />
6954: <meta HTTP-EQUIV="Pragma" CONTENT="no-cache" />';
1.216 albertel 6955: return $output;
1.7 albertel 6956: }
6957:
1.112 bowersj2 6958: =pod
6959:
1.648 raeburn 6960: =item * &no_cache($r)
1.112 bowersj2 6961:
6962: specifies header code to not have cache
6963:
6964: =cut
6965:
1.9 albertel 6966: sub no_cache {
1.216 albertel 6967: my ($r) = @_;
6968: if ($ENV{'REQUEST_METHOD'} ne 'GET' &&
1.258 albertel 6969: $env{'request.method'} ne 'GET') { return ''; }
1.216 albertel 6970: my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime(time));
6971: $r->no_cache(1);
6972: $r->header_out("Expires" => $date);
6973: $r->header_out("Pragma" => "no-cache");
1.123 www 6974: }
6975:
6976: sub content_type {
1.181 albertel 6977: my ($r,$type,$charset) = @_;
1.299 foxr 6978: if ($r) {
6979: # Note that printout.pl calls this with undef for $r.
6980: &no_cache($r);
6981: }
1.258 albertel 6982: if ($env{'browser.mathml'} && $type eq 'text/html') { $type='text/xml'; }
1.181 albertel 6983: unless ($charset) {
6984: $charset=&Apache::lonlocal::current_encoding;
6985: }
6986: if ($charset) { $type.='; charset='.$charset; }
6987: if ($r) {
6988: $r->content_type($type);
6989: } else {
6990: print("Content-type: $type\n\n");
6991: }
1.9 albertel 6992: }
1.25 albertel 6993:
1.112 bowersj2 6994: =pod
6995:
1.648 raeburn 6996: =item * &add_to_env($name,$value)
1.112 bowersj2 6997:
1.258 albertel 6998: adds $name to the %env hash with value
1.112 bowersj2 6999: $value, if $name already exists, the entry is converted to an array
7000: reference and $value is added to the array.
7001:
7002: =cut
7003:
1.25 albertel 7004: sub add_to_env {
7005: my ($name,$value)=@_;
1.258 albertel 7006: if (defined($env{$name})) {
7007: if (ref($env{$name})) {
1.25 albertel 7008: #already have multiple values
1.258 albertel 7009: push(@{ $env{$name} },$value);
1.25 albertel 7010: } else {
7011: #first time seeing multiple values, convert hash entry to an arrayref
1.258 albertel 7012: my $first=$env{$name};
7013: undef($env{$name});
7014: push(@{ $env{$name} },$first,$value);
1.25 albertel 7015: }
7016: } else {
1.258 albertel 7017: $env{$name}=$value;
1.25 albertel 7018: }
1.31 albertel 7019: }
1.149 albertel 7020:
7021: =pod
7022:
1.648 raeburn 7023: =item * &get_env_multiple($name)
1.149 albertel 7024:
1.258 albertel 7025: gets $name from the %env hash, it seemlessly handles the cases where multiple
1.149 albertel 7026: values may be defined and end up as an array ref.
7027:
7028: returns an array of values
7029:
7030: =cut
7031:
7032: sub get_env_multiple {
7033: my ($name) = @_;
7034: my @values;
1.258 albertel 7035: if (defined($env{$name})) {
1.149 albertel 7036: # exists is it an array
1.258 albertel 7037: if (ref($env{$name})) {
7038: @values=@{ $env{$name} };
1.149 albertel 7039: } else {
1.258 albertel 7040: $values[0]=$env{$name};
1.149 albertel 7041: }
7042: }
7043: return(@values);
7044: }
7045:
1.31 albertel 7046:
1.41 ng 7047: =pod
1.45 matthew 7048:
1.464 albertel 7049: =back
1.41 ng 7050:
1.112 bowersj2 7051: =head1 CSV Upload/Handling functions
1.38 albertel 7052:
1.41 ng 7053: =over 4
7054:
1.648 raeburn 7055: =item * &upfile_store($r)
1.41 ng 7056:
7057: Store uploaded file, $r should be the HTTP Request object,
1.258 albertel 7058: needs $env{'form.upfile'}
1.41 ng 7059: returns $datatoken to be put into hidden field
7060:
7061: =cut
1.31 albertel 7062:
7063: sub upfile_store {
7064: my $r=shift;
1.258 albertel 7065: $env{'form.upfile'}=~s/\r/\n/gs;
7066: $env{'form.upfile'}=~s/\f/\n/gs;
7067: $env{'form.upfile'}=~s/\n+/\n/gs;
7068: $env{'form.upfile'}=~s/\n+$//gs;
1.31 albertel 7069:
1.258 albertel 7070: my $datatoken=$env{'user.name'}.'_'.$env{'user.domain'}.
7071: '_enroll_'.$env{'request.course.id'}.'_'.time.'_'.$$;
1.31 albertel 7072: {
1.158 raeburn 7073: my $datafile = $r->dir_config('lonDaemons').
7074: '/tmp/'.$datatoken.'.tmp';
7075: if ( open(my $fh,">$datafile") ) {
1.258 albertel 7076: print $fh $env{'form.upfile'};
1.158 raeburn 7077: close($fh);
7078: }
1.31 albertel 7079: }
7080: return $datatoken;
7081: }
7082:
1.56 matthew 7083: =pod
7084:
1.648 raeburn 7085: =item * &load_tmp_file($r)
1.41 ng 7086:
7087: Load uploaded file from tmp, $r should be the HTTP Request object,
1.258 albertel 7088: needs $env{'form.datatoken'},
7089: sets $env{'form.upfile'} to the contents of the file
1.41 ng 7090:
7091: =cut
1.31 albertel 7092:
7093: sub load_tmp_file {
7094: my $r=shift;
7095: my @studentdata=();
7096: {
1.158 raeburn 7097: my $studentfile = $r->dir_config('lonDaemons').
1.258 albertel 7098: '/tmp/'.$env{'form.datatoken'}.'.tmp';
1.158 raeburn 7099: if ( open(my $fh,"<$studentfile") ) {
7100: @studentdata=<$fh>;
7101: close($fh);
7102: }
1.31 albertel 7103: }
1.258 albertel 7104: $env{'form.upfile'}=join('',@studentdata);
1.31 albertel 7105: }
7106:
1.56 matthew 7107: =pod
7108:
1.648 raeburn 7109: =item * &upfile_record_sep()
1.41 ng 7110:
7111: Separate uploaded file into records
7112: returns array of records,
1.258 albertel 7113: needs $env{'form.upfile'} and $env{'form.upfiletype'}
1.41 ng 7114:
7115: =cut
1.31 albertel 7116:
7117: sub upfile_record_sep {
1.258 albertel 7118: if ($env{'form.upfiletype'} eq 'xml') {
1.31 albertel 7119: } else {
1.248 albertel 7120: my @records;
1.258 albertel 7121: foreach my $line (split(/\n/,$env{'form.upfile'})) {
1.248 albertel 7122: if ($line=~/^\s*$/) { next; }
7123: push(@records,$line);
7124: }
7125: return @records;
1.31 albertel 7126: }
7127: }
7128:
1.56 matthew 7129: =pod
7130:
1.648 raeburn 7131: =item * &record_sep($record)
1.41 ng 7132:
1.258 albertel 7133: Separate a record into fields $record should be an item from the upfile_record_sep(), needs $env{'form.upfiletype'}
1.41 ng 7134:
7135: =cut
7136:
1.263 www 7137: sub takeleft {
7138: my $index=shift;
7139: return substr('0000'.$index,-4,4);
7140: }
7141:
1.31 albertel 7142: sub record_sep {
7143: my $record=shift;
7144: my %components=();
1.258 albertel 7145: if ($env{'form.upfiletype'} eq 'xml') {
7146: } elsif ($env{'form.upfiletype'} eq 'space') {
1.31 albertel 7147: my $i=0;
1.356 albertel 7148: foreach my $field (split(/\s+/,$record)) {
1.31 albertel 7149: $field=~s/^(\"|\')//;
7150: $field=~s/(\"|\')$//;
1.263 www 7151: $components{&takeleft($i)}=$field;
1.31 albertel 7152: $i++;
7153: }
1.258 albertel 7154: } elsif ($env{'form.upfiletype'} eq 'tab') {
1.31 albertel 7155: my $i=0;
1.356 albertel 7156: foreach my $field (split(/\t/,$record)) {
1.31 albertel 7157: $field=~s/^(\"|\')//;
7158: $field=~s/(\"|\')$//;
1.263 www 7159: $components{&takeleft($i)}=$field;
1.31 albertel 7160: $i++;
7161: }
7162: } else {
1.561 www 7163: my $separator=',';
1.480 banghart 7164: if ($env{'form.upfiletype'} eq 'semisv') {
1.561 www 7165: $separator=';';
1.480 banghart 7166: }
1.31 albertel 7167: my $i=0;
1.561 www 7168: # the character we are looking for to indicate the end of a quote or a record
7169: my $looking_for=$separator;
7170: # do not add the characters to the fields
7171: my $ignore=0;
7172: # we just encountered a separator (or the beginning of the record)
7173: my $just_found_separator=1;
7174: # store the field we are working on here
7175: my $field='';
7176: # work our way through all characters in record
7177: foreach my $character ($record=~/(.)/g) {
7178: if ($character eq $looking_for) {
7179: if ($character ne $separator) {
7180: # Found the end of a quote, again looking for separator
7181: $looking_for=$separator;
7182: $ignore=1;
7183: } else {
7184: # Found a separator, store away what we got
7185: $components{&takeleft($i)}=$field;
7186: $i++;
7187: $just_found_separator=1;
7188: $ignore=0;
7189: $field='';
7190: }
7191: next;
7192: }
7193: # single or double quotation marks after a separator indicate beginning of a quote
7194: # we are now looking for the end of the quote and need to ignore separators
7195: if ((($character eq '"') || ($character eq "'")) && ($just_found_separator)) {
7196: $looking_for=$character;
7197: next;
7198: }
7199: # ignore would be true after we reached the end of a quote
7200: if ($ignore) { next; }
7201: if (($just_found_separator) && ($character=~/\s/)) { next; }
7202: $field.=$character;
7203: $just_found_separator=0;
1.31 albertel 7204: }
1.561 www 7205: # catch the very last entry, since we never encountered the separator
7206: $components{&takeleft($i)}=$field;
1.31 albertel 7207: }
7208: return %components;
7209: }
7210:
1.144 matthew 7211: ######################################################
7212: ######################################################
7213:
1.56 matthew 7214: =pod
7215:
1.648 raeburn 7216: =item * &upfile_select_html()
1.41 ng 7217:
1.144 matthew 7218: Return HTML code to select a file from the users machine and specify
7219: the file type.
1.41 ng 7220:
7221: =cut
7222:
1.144 matthew 7223: ######################################################
7224: ######################################################
1.31 albertel 7225: sub upfile_select_html {
1.144 matthew 7226: my %Types = (
7227: csv => &mt('CSV (comma separated values, spreadsheet)'),
1.480 banghart 7228: semisv => &mt('Semicolon separated values'),
1.144 matthew 7229: space => &mt('Space separated'),
7230: tab => &mt('Tabulator separated'),
7231: # xml => &mt('HTML/XML'),
7232: );
7233: my $Str = '<input type="file" name="upfile" size="50" />'.
7234: '<br />Type: <select name="upfiletype">';
7235: foreach my $type (sort(keys(%Types))) {
7236: $Str .= '<option value="'.$type.'" >'.$Types{$type}."</option>\n";
7237: }
7238: $Str .= "</select>\n";
7239: return $Str;
1.31 albertel 7240: }
7241:
1.301 albertel 7242: sub get_samples {
7243: my ($records,$toget) = @_;
7244: my @samples=({});
7245: my $got=0;
7246: foreach my $rec (@$records) {
7247: my %temp = &record_sep($rec);
7248: if (! grep(/\S/, values(%temp))) { next; }
7249: if (%temp) {
7250: $samples[$got]=\%temp;
7251: $got++;
7252: if ($got == $toget) { last; }
7253: }
7254: }
7255: return \@samples;
7256: }
7257:
1.144 matthew 7258: ######################################################
7259: ######################################################
7260:
1.56 matthew 7261: =pod
7262:
1.648 raeburn 7263: =item * &csv_print_samples($r,$records)
1.41 ng 7264:
7265: Prints a table of sample values from each column uploaded $r is an
7266: Apache Request ref, $records is an arrayref from
7267: &Apache::loncommon::upfile_record_sep
7268:
7269: =cut
7270:
1.144 matthew 7271: ######################################################
7272: ######################################################
1.31 albertel 7273: sub csv_print_samples {
7274: my ($r,$records) = @_;
1.301 albertel 7275: my $samples = &get_samples($records,3);
7276:
1.594 raeburn 7277: $r->print(&mt('Samples').'<br />'.&start_data_table().
7278: &start_data_table_header_row());
1.356 albertel 7279: foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
7280: $r->print('<th>'.&mt('Column [_1]',($sample+1)).'</th>'); }
1.594 raeburn 7281: $r->print(&end_data_table_header_row());
1.301 albertel 7282: foreach my $hash (@$samples) {
1.594 raeburn 7283: $r->print(&start_data_table_row());
1.356 albertel 7284: foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
1.31 albertel 7285: $r->print('<td>');
1.356 albertel 7286: if (defined($$hash{$sample})) { $r->print($$hash{$sample}); }
1.31 albertel 7287: $r->print('</td>');
7288: }
1.594 raeburn 7289: $r->print(&end_data_table_row());
1.31 albertel 7290: }
1.594 raeburn 7291: $r->print(&end_data_table().'<br />'."\n");
1.31 albertel 7292: }
7293:
1.144 matthew 7294: ######################################################
7295: ######################################################
7296:
1.56 matthew 7297: =pod
7298:
1.648 raeburn 7299: =item * &csv_print_select_table($r,$records,$d)
1.41 ng 7300:
7301: Prints a table to create associations between values and table columns.
1.144 matthew 7302:
1.41 ng 7303: $r is an Apache Request ref,
7304: $records is an arrayref from &Apache::loncommon::upfile_record_sep,
1.174 matthew 7305: $d is an array of 2 element arrays (internal name, displayed name,defaultcol)
1.41 ng 7306:
7307: =cut
7308:
1.144 matthew 7309: ######################################################
7310: ######################################################
1.31 albertel 7311: sub csv_print_select_table {
7312: my ($r,$records,$d) = @_;
1.301 albertel 7313: my $i=0;
7314: my $samples = &get_samples($records,1);
1.144 matthew 7315: $r->print(&mt('Associate columns with student attributes.')."\n".
1.594 raeburn 7316: &start_data_table().&start_data_table_header_row().
1.144 matthew 7317: '<th>'.&mt('Attribute').'</th>'.
1.594 raeburn 7318: '<th>'.&mt('Column').'</th>'.
7319: &end_data_table_header_row()."\n");
1.356 albertel 7320: foreach my $array_ref (@$d) {
7321: my ($value,$display,$defaultcol)=@{ $array_ref };
1.594 raeburn 7322: $r->print(&start_data_table_row().'<tr><td>'.$display.'</td>');
1.31 albertel 7323:
7324: $r->print('<td><select name=f'.$i.
1.32 matthew 7325: ' onchange="javascript:flip(this.form,'.$i.');">');
1.31 albertel 7326: $r->print('<option value="none"></option>');
1.356 albertel 7327: foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
7328: $r->print('<option value="'.$sample.'"'.
7329: ($sample eq $defaultcol ? ' selected="selected" ' : '').
7330: '>Column '.($sample+1).'</option>');
1.31 albertel 7331: }
1.594 raeburn 7332: $r->print('</select></td>'.&end_data_table_row()."\n");
1.31 albertel 7333: $i++;
7334: }
1.594 raeburn 7335: $r->print(&end_data_table());
1.31 albertel 7336: $i--;
7337: return $i;
7338: }
1.56 matthew 7339:
1.144 matthew 7340: ######################################################
7341: ######################################################
7342:
1.56 matthew 7343: =pod
1.31 albertel 7344:
1.648 raeburn 7345: =item * &csv_samples_select_table($r,$records,$d)
1.41 ng 7346:
7347: Prints a table of sample values from the upload and can make associate samples to internal names.
7348:
7349: $r is an Apache Request ref,
7350: $records is an arrayref from &Apache::loncommon::upfile_record_sep,
7351: $d is an array of 2 element arrays (internal name, displayed name)
7352:
7353: =cut
7354:
1.144 matthew 7355: ######################################################
7356: ######################################################
1.31 albertel 7357: sub csv_samples_select_table {
7358: my ($r,$records,$d) = @_;
7359: my $i=0;
1.144 matthew 7360: #
1.301 albertel 7361: my $samples = &get_samples($records,3);
1.594 raeburn 7362: $r->print(&start_data_table().
7363: &start_data_table_header_row().'<th>'.
7364: &mt('Field').'</th><th>'.&mt('Samples').'</th>'.
7365: &end_data_table_header_row());
1.301 albertel 7366:
7367: foreach my $key (sort(keys(%{ $samples->[0] }))) {
1.594 raeburn 7368: $r->print(&start_data_table_row().'<td><select name="f'.$i.'"'.
1.32 matthew 7369: ' onchange="javascript:flip(this.form,'.$i.');">');
1.301 albertel 7370: foreach my $option (@$d) {
7371: my ($value,$display,$defaultcol)=@{ $option };
1.174 matthew 7372: $r->print('<option value="'.$value.'"'.
1.253 albertel 7373: ($i eq $defaultcol ? ' selected="selected" ':'').'>'.
1.174 matthew 7374: $display.'</option>');
1.31 albertel 7375: }
7376: $r->print('</select></td><td>');
1.301 albertel 7377: foreach my $line (0..2) {
7378: if (defined($samples->[$line]{$key})) {
7379: $r->print($samples->[$line]{$key}."<br />\n");
7380: }
7381: }
1.594 raeburn 7382: $r->print('</td>'.&end_data_table_row());
1.31 albertel 7383: $i++;
7384: }
1.594 raeburn 7385: $r->print(&end_data_table());
1.31 albertel 7386: $i--;
7387: return($i);
1.115 matthew 7388: }
7389:
1.144 matthew 7390: ######################################################
7391: ######################################################
7392:
1.115 matthew 7393: =pod
7394:
1.648 raeburn 7395: =item * &clean_excel_name($name)
1.115 matthew 7396:
7397: Returns a replacement for $name which does not contain any illegal characters.
7398:
7399: =cut
7400:
1.144 matthew 7401: ######################################################
7402: ######################################################
1.115 matthew 7403: sub clean_excel_name {
7404: my ($name) = @_;
7405: $name =~ s/[:\*\?\/\\]//g;
7406: if (length($name) > 31) {
7407: $name = substr($name,0,31);
7408: }
7409: return $name;
1.25 albertel 7410: }
1.84 albertel 7411:
1.85 albertel 7412: =pod
7413:
1.648 raeburn 7414: =item * &check_if_partid_hidden($id,$symb,$udom,$uname)
1.85 albertel 7415:
7416: Returns either 1 or undef
7417:
7418: 1 if the part is to be hidden, undef if it is to be shown
7419:
7420: Arguments are:
7421:
7422: $id the id of the part to be checked
7423: $symb, optional the symb of the resource to check
7424: $udom, optional the domain of the user to check for
7425: $uname, optional the username of the user to check for
7426:
7427: =cut
1.84 albertel 7428:
7429: sub check_if_partid_hidden {
7430: my ($id,$symb,$udom,$uname) = @_;
1.133 albertel 7431: my $hiddenparts=&Apache::lonnet::EXT('resource.0.hiddenparts',
1.84 albertel 7432: $symb,$udom,$uname);
1.141 albertel 7433: my $truth=1;
7434: #if the string starts with !, then the list is the list to show not hide
7435: if ($hiddenparts=~s/^\s*!//) { $truth=undef; }
1.84 albertel 7436: my @hiddenlist=split(/,/,$hiddenparts);
7437: foreach my $checkid (@hiddenlist) {
1.141 albertel 7438: if ($checkid =~ /^\s*\Q$id\E\s*$/) { return $truth; }
1.84 albertel 7439: }
1.141 albertel 7440: return !$truth;
1.84 albertel 7441: }
1.127 matthew 7442:
1.138 matthew 7443:
7444: ############################################################
7445: ############################################################
7446:
7447: =pod
7448:
1.157 matthew 7449: =back
7450:
1.138 matthew 7451: =head1 cgi-bin script and graphing routines
7452:
1.157 matthew 7453: =over 4
7454:
1.648 raeburn 7455: =item * &get_cgi_id()
1.138 matthew 7456:
7457: Inputs: none
7458:
7459: Returns an id which can be used to pass environment variables
7460: to various cgi-bin scripts. These environment variables will
7461: be removed from the users environment after a given time by
7462: the routine &Apache::lonnet::transfer_profile_to_env.
7463:
7464: =cut
7465:
7466: ############################################################
7467: ############################################################
1.152 albertel 7468: my $uniq=0;
1.136 matthew 7469: sub get_cgi_id {
1.154 albertel 7470: $uniq=($uniq+1)%100000;
1.280 albertel 7471: return (time.'_'.$$.'_'.$uniq);
1.136 matthew 7472: }
7473:
1.127 matthew 7474: ############################################################
7475: ############################################################
7476:
7477: =pod
7478:
1.648 raeburn 7479: =item * &DrawBarGraph()
1.127 matthew 7480:
1.138 matthew 7481: Facilitates the plotting of data in a (stacked) bar graph.
7482: Puts plot definition data into the users environment in order for
7483: graph.png to plot it. Returns an <img> tag for the plot.
7484: The bars on the plot are labeled '1','2',...,'n'.
7485:
7486: Inputs:
7487:
7488: =over 4
7489:
7490: =item $Title: string, the title of the plot
7491:
7492: =item $xlabel: string, text describing the X-axis of the plot
7493:
7494: =item $ylabel: string, text describing the Y-axis of the plot
7495:
7496: =item $Max: scalar, the maximum Y value to use in the plot
7497: If $Max is < any data point, the graph will not be rendered.
7498:
1.140 matthew 7499: =item $colors: array ref holding the colors to be used for the data sets when
1.138 matthew 7500: they are plotted. If undefined, default values will be used.
7501:
1.178 matthew 7502: =item $labels: array ref holding the labels to use on the x-axis for the bars.
7503:
1.138 matthew 7504: =item @Values: An array of array references. Each array reference holds data
7505: to be plotted in a stacked bar chart.
7506:
1.239 matthew 7507: =item If the final element of @Values is a hash reference the key/value
7508: pairs will be added to the graph definition.
7509:
1.138 matthew 7510: =back
7511:
7512: Returns:
7513:
7514: An <img> tag which references graph.png and the appropriate identifying
7515: information for the plot.
7516:
1.127 matthew 7517: =cut
7518:
7519: ############################################################
7520: ############################################################
1.134 matthew 7521: sub DrawBarGraph {
1.178 matthew 7522: my ($Title,$xlabel,$ylabel,$Max,$colors,$labels,@Values)=@_;
1.134 matthew 7523: #
7524: if (! defined($colors)) {
7525: $colors = ['#33ff00',
7526: '#0033cc', '#990000', '#aaaa66', '#663399', '#ff9933',
7527: '#66ccff', '#ff9999', '#cccc33', '#660000', '#33cc66',
7528: ];
7529: }
1.228 matthew 7530: my $extra_settings = {};
7531: if (ref($Values[-1]) eq 'HASH') {
7532: $extra_settings = pop(@Values);
7533: }
1.127 matthew 7534: #
1.136 matthew 7535: my $identifier = &get_cgi_id();
7536: my $id = 'cgi.'.$identifier;
1.129 matthew 7537: if (! @Values || ref($Values[0]) ne 'ARRAY') {
1.127 matthew 7538: return '';
7539: }
1.225 matthew 7540: #
7541: my @Labels;
7542: if (defined($labels)) {
7543: @Labels = @$labels;
7544: } else {
7545: for (my $i=0;$i<@{$Values[0]};$i++) {
7546: push (@Labels,$i+1);
7547: }
7548: }
7549: #
1.129 matthew 7550: my $NumBars = scalar(@{$Values[0]});
1.225 matthew 7551: if ($NumBars < scalar(@Labels)) { $NumBars = scalar(@Labels); }
1.129 matthew 7552: my %ValuesHash;
7553: my $NumSets=1;
7554: foreach my $array (@Values) {
7555: next if (! ref($array));
1.136 matthew 7556: $ValuesHash{$id.'.data.'.$NumSets++} =
1.132 matthew 7557: join(',',@$array);
1.129 matthew 7558: }
1.127 matthew 7559: #
1.136 matthew 7560: my ($height,$width,$xskip,$bar_width) = (200,120,1,15);
1.225 matthew 7561: if ($NumBars < 3) {
7562: $width = 120+$NumBars*32;
1.220 matthew 7563: $xskip = 1;
1.225 matthew 7564: $bar_width = 30;
7565: } elsif ($NumBars < 5) {
7566: $width = 120+$NumBars*20;
7567: $xskip = 1;
7568: $bar_width = 20;
1.220 matthew 7569: } elsif ($NumBars < 10) {
1.136 matthew 7570: $width = 120+$NumBars*15;
7571: $xskip = 1;
7572: $bar_width = 15;
7573: } elsif ($NumBars <= 25) {
7574: $width = 120+$NumBars*11;
7575: $xskip = 5;
7576: $bar_width = 8;
7577: } elsif ($NumBars <= 50) {
7578: $width = 120+$NumBars*8;
7579: $xskip = 5;
7580: $bar_width = 4;
7581: } else {
7582: $width = 120+$NumBars*8;
7583: $xskip = 5;
7584: $bar_width = 4;
7585: }
7586: #
1.137 matthew 7587: $Max = 1 if ($Max < 1);
7588: if ( int($Max) < $Max ) {
7589: $Max++;
7590: $Max = int($Max);
7591: }
1.127 matthew 7592: $Title = '' if (! defined($Title));
7593: $xlabel = '' if (! defined($xlabel));
7594: $ylabel = '' if (! defined($ylabel));
1.369 www 7595: $ValuesHash{$id.'.title'} = &escape($Title);
7596: $ValuesHash{$id.'.xlabel'} = &escape($xlabel);
7597: $ValuesHash{$id.'.ylabel'} = &escape($ylabel);
1.137 matthew 7598: $ValuesHash{$id.'.y_max_value'} = $Max;
1.136 matthew 7599: $ValuesHash{$id.'.NumBars'} = $NumBars;
7600: $ValuesHash{$id.'.NumSets'} = $NumSets;
7601: $ValuesHash{$id.'.PlotType'} = 'bar';
7602: $ValuesHash{$id.'.Colors'} = join(',',@{$colors});
7603: $ValuesHash{$id.'.height'} = $height;
7604: $ValuesHash{$id.'.width'} = $width;
7605: $ValuesHash{$id.'.xskip'} = $xskip;
7606: $ValuesHash{$id.'.bar_width'} = $bar_width;
7607: $ValuesHash{$id.'.labels'} = join(',',@Labels);
1.127 matthew 7608: #
1.228 matthew 7609: # Deal with other parameters
7610: while (my ($key,$value) = each(%$extra_settings)) {
7611: $ValuesHash{$id.'.'.$key} = $value;
7612: }
7613: #
1.646 raeburn 7614: &Apache::lonnet::appenv(\%ValuesHash);
1.137 matthew 7615: return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';
7616: }
7617:
7618: ############################################################
7619: ############################################################
7620:
7621: =pod
7622:
1.648 raeburn 7623: =item * &DrawXYGraph()
1.137 matthew 7624:
1.138 matthew 7625: Facilitates the plotting of data in an XY graph.
7626: Puts plot definition data into the users environment in order for
7627: graph.png to plot it. Returns an <img> tag for the plot.
7628:
7629: Inputs:
7630:
7631: =over 4
7632:
7633: =item $Title: string, the title of the plot
7634:
7635: =item $xlabel: string, text describing the X-axis of the plot
7636:
7637: =item $ylabel: string, text describing the Y-axis of the plot
7638:
7639: =item $Max: scalar, the maximum Y value to use in the plot
7640: If $Max is < any data point, the graph will not be rendered.
7641:
7642: =item $colors: Array ref containing the hex color codes for the data to be
7643: plotted in. If undefined, default values will be used.
7644:
7645: =item $Xlabels: Array ref containing the labels to be used for the X-axis.
7646:
7647: =item $Ydata: Array ref containing Array refs.
1.185 www 7648: Each of the contained arrays will be plotted as a separate curve.
1.138 matthew 7649:
7650: =item %Values: hash indicating or overriding any default values which are
7651: passed to graph.png.
7652: Possible values are: width, xskip, x_ticks, x_tick_offset, among others.
7653:
7654: =back
7655:
7656: Returns:
7657:
7658: An <img> tag which references graph.png and the appropriate identifying
7659: information for the plot.
7660:
1.137 matthew 7661: =cut
7662:
7663: ############################################################
7664: ############################################################
7665: sub DrawXYGraph {
7666: my ($Title,$xlabel,$ylabel,$Max,$colors,$Xlabels,$Ydata,%Values)=@_;
7667: #
7668: # Create the identifier for the graph
7669: my $identifier = &get_cgi_id();
7670: my $id = 'cgi.'.$identifier;
7671: #
7672: $Title = '' if (! defined($Title));
7673: $xlabel = '' if (! defined($xlabel));
7674: $ylabel = '' if (! defined($ylabel));
7675: my %ValuesHash =
7676: (
1.369 www 7677: $id.'.title' => &escape($Title),
7678: $id.'.xlabel' => &escape($xlabel),
7679: $id.'.ylabel' => &escape($ylabel),
1.137 matthew 7680: $id.'.y_max_value'=> $Max,
7681: $id.'.labels' => join(',',@$Xlabels),
7682: $id.'.PlotType' => 'XY',
7683: );
7684: #
7685: if (defined($colors) && ref($colors) eq 'ARRAY') {
7686: $ValuesHash{$id.'.Colors'} = join(',',@{$colors});
7687: }
7688: #
7689: if (! ref($Ydata) || ref($Ydata) ne 'ARRAY') {
7690: return '';
7691: }
7692: my $NumSets=1;
1.138 matthew 7693: foreach my $array (@{$Ydata}){
1.137 matthew 7694: next if (! ref($array));
7695: $ValuesHash{$id.'.data.'.$NumSets++} = join(',',@$array);
7696: }
1.138 matthew 7697: $ValuesHash{$id.'.NumSets'} = $NumSets-1;
1.137 matthew 7698: #
7699: # Deal with other parameters
7700: while (my ($key,$value) = each(%Values)) {
7701: $ValuesHash{$id.'.'.$key} = $value;
1.127 matthew 7702: }
7703: #
1.646 raeburn 7704: &Apache::lonnet::appenv(\%ValuesHash);
1.136 matthew 7705: return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';
7706: }
7707:
7708: ############################################################
7709: ############################################################
7710:
7711: =pod
7712:
1.648 raeburn 7713: =item * &DrawXYYGraph()
1.138 matthew 7714:
7715: Facilitates the plotting of data in an XY graph with two Y axes.
7716: Puts plot definition data into the users environment in order for
7717: graph.png to plot it. Returns an <img> tag for the plot.
7718:
7719: Inputs:
7720:
7721: =over 4
7722:
7723: =item $Title: string, the title of the plot
7724:
7725: =item $xlabel: string, text describing the X-axis of the plot
7726:
7727: =item $ylabel: string, text describing the Y-axis of the plot
7728:
7729: =item $colors: Array ref containing the hex color codes for the data to be
7730: plotted in. If undefined, default values will be used.
7731:
7732: =item $Xlabels: Array ref containing the labels to be used for the X-axis.
7733:
7734: =item $Ydata1: The first data set
7735:
7736: =item $Min1: The minimum value of the left Y-axis
7737:
7738: =item $Max1: The maximum value of the left Y-axis
7739:
7740: =item $Ydata2: The second data set
7741:
7742: =item $Min2: The minimum value of the right Y-axis
7743:
7744: =item $Max2: The maximum value of the left Y-axis
7745:
7746: =item %Values: hash indicating or overriding any default values which are
7747: passed to graph.png.
7748: Possible values are: width, xskip, x_ticks, x_tick_offset, among others.
7749:
7750: =back
7751:
7752: Returns:
7753:
7754: An <img> tag which references graph.png and the appropriate identifying
7755: information for the plot.
1.136 matthew 7756:
7757: =cut
7758:
7759: ############################################################
7760: ############################################################
1.137 matthew 7761: sub DrawXYYGraph {
7762: my ($Title,$xlabel,$ylabel,$colors,$Xlabels,$Ydata1,$Min1,$Max1,
7763: $Ydata2,$Min2,$Max2,%Values)=@_;
1.136 matthew 7764: #
7765: # Create the identifier for the graph
7766: my $identifier = &get_cgi_id();
7767: my $id = 'cgi.'.$identifier;
7768: #
7769: $Title = '' if (! defined($Title));
7770: $xlabel = '' if (! defined($xlabel));
7771: $ylabel = '' if (! defined($ylabel));
7772: my %ValuesHash =
7773: (
1.369 www 7774: $id.'.title' => &escape($Title),
7775: $id.'.xlabel' => &escape($xlabel),
7776: $id.'.ylabel' => &escape($ylabel),
1.136 matthew 7777: $id.'.labels' => join(',',@$Xlabels),
7778: $id.'.PlotType' => 'XY',
7779: $id.'.NumSets' => 2,
1.137 matthew 7780: $id.'.two_axes' => 1,
7781: $id.'.y1_max_value' => $Max1,
7782: $id.'.y1_min_value' => $Min1,
7783: $id.'.y2_max_value' => $Max2,
7784: $id.'.y2_min_value' => $Min2,
1.136 matthew 7785: );
7786: #
1.137 matthew 7787: if (defined($colors) && ref($colors) eq 'ARRAY') {
7788: $ValuesHash{$id.'.Colors'} = join(',',@{$colors});
7789: }
7790: #
7791: if (! ref($Ydata1) || ref($Ydata1) ne 'ARRAY' ||
7792: ! ref($Ydata2) || ref($Ydata2) ne 'ARRAY'){
1.136 matthew 7793: return '';
7794: }
7795: my $NumSets=1;
1.137 matthew 7796: foreach my $array ($Ydata1,$Ydata2){
1.136 matthew 7797: next if (! ref($array));
7798: $ValuesHash{$id.'.data.'.$NumSets++} = join(',',@$array);
1.137 matthew 7799: }
7800: #
7801: # Deal with other parameters
7802: while (my ($key,$value) = each(%Values)) {
7803: $ValuesHash{$id.'.'.$key} = $value;
1.136 matthew 7804: }
7805: #
1.646 raeburn 7806: &Apache::lonnet::appenv(\%ValuesHash);
1.130 albertel 7807: return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';
1.139 matthew 7808: }
7809:
7810: ############################################################
7811: ############################################################
7812:
7813: =pod
7814:
1.157 matthew 7815: =back
7816:
1.139 matthew 7817: =head1 Statistics helper routines?
7818:
7819: Bad place for them but what the hell.
7820:
1.157 matthew 7821: =over 4
7822:
1.648 raeburn 7823: =item * &chartlink()
1.139 matthew 7824:
7825: Returns a link to the chart for a specific student.
7826:
7827: Inputs:
7828:
7829: =over 4
7830:
7831: =item $linktext: The text of the link
7832:
7833: =item $sname: The students username
7834:
7835: =item $sdomain: The students domain
7836:
7837: =back
7838:
1.157 matthew 7839: =back
7840:
1.139 matthew 7841: =cut
7842:
7843: ############################################################
7844: ############################################################
7845: sub chartlink {
7846: my ($linktext, $sname, $sdomain) = @_;
7847: my $link = '<a href="/adm/statistics?reportSelected=student_assessment'.
1.369 www 7848: '&SelectedStudent='.&escape($sname.':'.$sdomain).
1.219 albertel 7849: '&chartoutputmode='.HTML::Entities::encode('html, with all links').
1.139 matthew 7850: '">'.$linktext.'</a>';
1.153 matthew 7851: }
7852:
7853: #######################################################
7854: #######################################################
7855:
7856: =pod
7857:
7858: =head1 Course Environment Routines
1.157 matthew 7859:
7860: =over 4
1.153 matthew 7861:
1.648 raeburn 7862: =item * &restore_course_settings()
1.153 matthew 7863:
1.648 raeburn 7864: =item * &store_course_settings()
1.153 matthew 7865:
7866: Restores/Store indicated form parameters from the course environment.
7867: Will not overwrite existing values of the form parameters.
7868:
7869: Inputs:
7870: a scalar describing the data (e.g. 'chart', 'problem_analysis')
7871:
7872: a hash ref describing the data to be stored. For example:
7873:
7874: %Save_Parameters = ('Status' => 'scalar',
7875: 'chartoutputmode' => 'scalar',
7876: 'chartoutputdata' => 'scalar',
7877: 'Section' => 'array',
1.373 raeburn 7878: 'Group' => 'array',
1.153 matthew 7879: 'StudentData' => 'array',
7880: 'Maps' => 'array');
7881:
7882: Returns: both routines return nothing
7883:
1.631 raeburn 7884: =back
7885:
1.153 matthew 7886: =cut
7887:
7888: #######################################################
7889: #######################################################
7890: sub store_course_settings {
1.496 albertel 7891: return &store_settings($env{'request.course.id'},@_);
7892: }
7893:
7894: sub store_settings {
1.153 matthew 7895: # save to the environment
7896: # appenv the same items, just to be safe
1.300 albertel 7897: my $udom = $env{'user.domain'};
7898: my $uname = $env{'user.name'};
1.496 albertel 7899: my ($context,$prefix,$Settings) = @_;
1.153 matthew 7900: my %SaveHash;
7901: my %AppHash;
7902: while (my ($setting,$type) = each(%$Settings)) {
1.496 albertel 7903: my $basename = join('.','internal',$context,$prefix,$setting);
1.300 albertel 7904: my $envname = 'environment.'.$basename;
1.258 albertel 7905: if (exists($env{'form.'.$setting})) {
1.153 matthew 7906: # Save this value away
7907: if ($type eq 'scalar' &&
1.258 albertel 7908: (! exists($env{$envname}) ||
7909: $env{$envname} ne $env{'form.'.$setting})) {
7910: $SaveHash{$basename} = $env{'form.'.$setting};
7911: $AppHash{$envname} = $env{'form.'.$setting};
1.153 matthew 7912: } elsif ($type eq 'array') {
7913: my $stored_form;
1.258 albertel 7914: if (ref($env{'form.'.$setting})) {
1.153 matthew 7915: $stored_form = join(',',
7916: map {
1.369 www 7917: &escape($_);
1.258 albertel 7918: } sort(@{$env{'form.'.$setting}}));
1.153 matthew 7919: } else {
7920: $stored_form =
1.369 www 7921: &escape($env{'form.'.$setting});
1.153 matthew 7922: }
7923: # Determine if the array contents are the same.
1.258 albertel 7924: if ($stored_form ne $env{$envname}) {
1.153 matthew 7925: $SaveHash{$basename} = $stored_form;
7926: $AppHash{$envname} = $stored_form;
7927: }
7928: }
7929: }
7930: }
7931: my $put_result = &Apache::lonnet::put('environment',\%SaveHash,
1.300 albertel 7932: $udom,$uname);
1.153 matthew 7933: if ($put_result !~ /^(ok|delayed)/) {
7934: &Apache::lonnet::logthis('unable to save form parameters, '.
7935: 'got error:'.$put_result);
7936: }
7937: # Make sure these settings stick around in this session, too
1.646 raeburn 7938: &Apache::lonnet::appenv(\%AppHash);
1.153 matthew 7939: return;
7940: }
7941:
7942: sub restore_course_settings {
1.499 albertel 7943: return &restore_settings($env{'request.course.id'},@_);
1.496 albertel 7944: }
7945:
7946: sub restore_settings {
7947: my ($context,$prefix,$Settings) = @_;
1.153 matthew 7948: while (my ($setting,$type) = each(%$Settings)) {
1.258 albertel 7949: next if (exists($env{'form.'.$setting}));
1.496 albertel 7950: my $envname = 'environment.internal.'.$context.'.'.$prefix.
1.153 matthew 7951: '.'.$setting;
1.258 albertel 7952: if (exists($env{$envname})) {
1.153 matthew 7953: if ($type eq 'scalar') {
1.258 albertel 7954: $env{'form.'.$setting} = $env{$envname};
1.153 matthew 7955: } elsif ($type eq 'array') {
1.258 albertel 7956: $env{'form.'.$setting} = [
1.153 matthew 7957: map {
1.369 www 7958: &unescape($_);
1.258 albertel 7959: } split(',',$env{$envname})
1.153 matthew 7960: ];
7961: }
7962: }
7963: }
1.127 matthew 7964: }
7965:
1.618 raeburn 7966: #######################################################
7967: #######################################################
7968:
7969: =pod
7970:
7971: =head1 Domain E-mail Routines
7972:
7973: =over 4
7974:
1.648 raeburn 7975: =item * &build_recipient_list()
1.618 raeburn 7976:
7977: Build recipient lists for three types of e-mail:
7978: (a) Error Reports, (b) Package Updates, (c) Help requests, generated by
1.619 raeburn 7979: lonerrorhandler.pm, CHECKRPMS and lonsupportreq.pm respectively.
1.618 raeburn 7980:
7981: Inputs:
1.619 raeburn 7982: defmail (scalar - email address of default recipient),
1.618 raeburn 7983: mailing type (scalar - errormail, packagesmail, or helpdeskmail),
1.619 raeburn 7984: defdom (domain for which to retrieve configuration settings),
7985: origmail (scalar - email address of recipient from loncapa.conf,
7986: i.e., predates configuration by DC via domainprefs.pm
1.618 raeburn 7987:
1.655 raeburn 7988: Returns: comma separated list of addresses to which to send e-mail.
7989:
7990: =back
1.618 raeburn 7991:
7992: =cut
7993:
7994: ############################################################
7995: ############################################################
7996: sub build_recipient_list {
1.619 raeburn 7997: my ($defmail,$mailing,$defdom,$origmail) = @_;
1.618 raeburn 7998: my @recipients;
7999: my $otheremails;
8000: my %domconfig =
8001: &Apache::lonnet::get_dom('configuration',['contacts'],$defdom);
8002: if (ref($domconfig{'contacts'}) eq 'HASH') {
8003: if (ref($domconfig{'contacts'}{$mailing}) eq 'HASH') {
8004: my @contacts = ('adminemail','supportemail');
8005: foreach my $item (@contacts) {
8006: if ($domconfig{'contacts'}{$mailing}{$item}) {
1.619 raeburn 8007: my $addr = $domconfig{'contacts'}{$item};
8008: if (!grep(/^\Q$addr\E$/,@recipients)) {
8009: push(@recipients,$addr);
8010: }
1.618 raeburn 8011: }
8012: $otheremails = $domconfig{'contacts'}{$mailing}{'others'};
8013: }
8014: }
1.619 raeburn 8015: } elsif ($origmail ne '') {
8016: push(@recipients,$origmail);
1.618 raeburn 8017: }
8018: if ($defmail ne '') {
8019: push(@recipients,$defmail);
8020: }
8021: if ($otheremails) {
1.619 raeburn 8022: my @others;
8023: if ($otheremails =~ /,/) {
8024: @others = split(/,/,$otheremails);
1.618 raeburn 8025: } else {
1.619 raeburn 8026: push(@others,$otheremails);
8027: }
8028: foreach my $addr (@others) {
8029: if (!grep(/^\Q$addr\E$/,@recipients)) {
8030: push(@recipients,$addr);
8031: }
1.618 raeburn 8032: }
8033: }
1.619 raeburn 8034: my $recipientlist = join(',',@recipients);
1.618 raeburn 8035: return $recipientlist;
8036: }
8037:
1.127 matthew 8038: ############################################################
8039: ############################################################
1.154 albertel 8040:
1.655 raeburn 8041: =pod
8042:
8043: =head1 Course Catalog Routines
8044:
8045: =over 4
8046:
8047: =item * &gather_categories()
8048:
8049: Converts category definitions - keys of categories hash stored in
8050: coursecategories in configuration.db on the primary library server in a
8051: domain - to an array. Also generates javascript and idx hash used to
8052: generate Domain Coordinator interface for editing Course Categories.
8053:
8054: Inputs:
8055: categories (reference to hash of category definitions).
8056: cats (reference to array of arrays/hashes which encapsulates hierarchy of
8057: categories and subcategories).
8058: idx (reference to hash of counters used in Domain Coordinator interface for
8059: editing Course Categories).
8060: jsarray (reference to array of categories used to create Javascript arrays for
8061: Domain Coordinator interface for editing Course Categories).
8062:
8063: Returns: nothing
8064:
8065: Side effects: populates cats, idx and jsarray.
8066:
8067: =cut
8068:
8069: sub gather_categories {
8070: my ($categories,$cats,$idx,$jsarray) = @_;
8071: my %counters;
8072: my $num = 0;
8073: foreach my $item (keys(%{$categories})) {
8074: my ($cat,$container,$depth) = map { &unescape($_); } split(/:/,$item);
8075: if ($container eq '' && $depth == 0) {
8076: $cats->[$depth][$categories->{$item}] = $cat;
8077: } else {
8078: $cats->[$depth]{$container}[$categories->{$item}] = $cat;
8079: }
8080: my ($escitem,$tail) = split(/:/,$item,2);
8081: if ($counters{$tail} eq '') {
8082: $counters{$tail} = $num;
8083: $num ++;
8084: }
8085: if (ref($idx) eq 'HASH') {
8086: $idx->{$item} = $counters{$tail};
8087: }
8088: if (ref($jsarray) eq 'ARRAY') {
8089: push(@{$jsarray->[$counters{$tail}]},$item);
8090: }
8091: }
8092: return;
8093: }
8094:
8095: =pod
8096:
8097: =item * &extract_categories()
8098:
8099: Used to generate breadcrumb trails for course categories.
8100:
8101: Inputs:
8102: categories (reference to hash of category definitions).
8103: cats (reference to array of arrays/hashes which encapsulates hierarchy of
8104: categories and subcategories).
8105: trails (reference to array of breacrumb trails for each category).
8106: allitems (reference to hash - key is category key
8107: (format: escaped(name):escaped(parent category):depth in hierarchy).
8108: idx (reference to hash of counters used in Domain Coordinator interface for
8109: editing Course Categories).
8110: jsarray (reference to array of categories used to create Javascript arrays for
8111: Domain Coordinator interface for editing Course Categories).
8112:
8113: Returns: nothing
8114:
8115: Side effects: populates trails and allitems hash references.
8116:
8117: =cut
8118:
8119: sub extract_categories {
8120: my ($categories,$cats,$trails,$allitems,$idx,$jsarray) = @_;
8121: if (ref($categories) eq 'HASH') {
8122: &gather_categories($categories,$cats,$idx,$jsarray);
8123: if (ref($cats->[0]) eq 'ARRAY') {
8124: for (my $i=0; $i<@{$cats->[0]}; $i++) {
8125: my $name = $cats->[0][$i];
8126: my $item = &escape($name).'::0';
8127: my $trailstr;
8128: if ($name eq 'instcode') {
8129: $trailstr = &mt('Official courses (with institutional codes)');
8130: } else {
8131: $trailstr = $name;
8132: }
8133: if ($allitems->{$item} eq '') {
8134: push(@{$trails},$trailstr);
8135: $allitems->{$item} = scalar(@{$trails})-1;
8136: }
8137: my @parents = ($name);
8138: if (ref($cats->[1]{$name}) eq 'ARRAY') {
8139: for (my $j=0; $j<@{$cats->[1]{$name}}; $j++) {
8140: my $category = $cats->[1]{$name}[$j];
8141: &recurse_categories($cats,2,$category,$trails,$allitems,\@parents);
8142: }
8143: }
8144: }
8145: }
8146: }
8147: return;
8148: }
8149:
8150: =pod
8151:
8152: =item *&recurse_categories()
8153:
8154: Recursively used to generate breadcrumb trails for course categories.
8155:
8156: Inputs:
8157: cats (reference to array of arrays/hashes which encapsulates hierarchy of
8158: categories and subcategories).
8159: depth (current depth in hierarchy of categories and sub-categories - 0 indexed).
8160: category (current course category, for which breadcrumb trail is being generated).
8161: trails (reference to array of breacrumb trails for each category).
8162: allitems (reference to hash - key is category key
8163: (format: escaped(name):escaped(parent category):depth in hierarchy).
8164: parents (array containing containers directories for current category,
8165: back to top level).
8166:
8167: Returns: nothing
8168:
8169: Side effects: populates trails and allitems hash references
8170:
8171: =back
8172:
8173: =cut
8174:
8175: sub recurse_categories {
8176: my ($cats,$depth,$category,$trails,$allitems,$parents) = @_;
8177: my $shallower = $depth - 1;
8178: if (ref($cats->[$depth]{$category}) eq 'ARRAY') {
8179: for (my $k=0; $k<@{$cats->[$depth]{$category}}; $k++) {
8180: my $name = $cats->[$depth]{$category}[$k];
8181: my $item = &escape($category).':'.&escape($parents->[-1]).':'.$shallower;
8182: my $trailstr = join(' -> ',(@{$parents},$category));
8183: if ($allitems->{$item} eq '') {
8184: push(@{$trails},$trailstr);
8185: $allitems->{$item} = scalar(@{$trails})-1;
8186: }
8187: my $deeper = $depth+1;
8188: push(@{$parents},$category);
8189: &recurse_categories($cats,$deeper,$name,$trails,$allitems,$parents);
8190: pop(@{$parents});
8191: }
8192: } else {
8193: my $item = &escape($category).':'.&escape($parents->[-1]).':'.$shallower;
8194: my $trailstr = join(' -> ',(@{$parents},$category));
8195: if ($allitems->{$item} eq '') {
8196: push(@{$trails},$trailstr);
8197: $allitems->{$item} = scalar(@{$trails})-1;
8198: }
8199: }
8200: return;
8201: }
8202:
8203: ############################################################
8204: ############################################################
8205:
8206:
1.443 albertel 8207: sub commit_customrole {
8208: my ($udom,$uname,$url,$three,$four,$five,$start,$end) = @_;
1.630 raeburn 8209: my $output = &mt('Assigning custom role').' "'.$five.'" by '.$four.':'.$three.' in '.$url.
1.443 albertel 8210: ($start?', '.&mt('starting').' '.localtime($start):'').
8211: ($end?', ending '.localtime($end):'').': <b>'.
8212: &Apache::lonnet::assigncustomrole(
8213: $udom,$uname,$url,$three,$four,$five,$end,$start).
8214: '</b><br />';
8215: return $output;
8216: }
8217:
8218: sub commit_standardrole {
1.541 raeburn 8219: my ($udom,$uname,$url,$three,$start,$end,$one,$two,$sec,$context) = @_;
8220: my ($output,$logmsg,$linefeed);
8221: if ($context eq 'auto') {
8222: $linefeed = "\n";
8223: } else {
8224: $linefeed = "<br />\n";
8225: }
1.443 albertel 8226: if ($three eq 'st') {
1.541 raeburn 8227: my $result = &commit_studentrole(\$logmsg,$udom,$uname,$url,$three,$start,$end,
8228: $one,$two,$sec,$context);
8229: if (($result =~ /^error/) || ($result eq 'not_in_class') ||
1.626 raeburn 8230: ($result eq 'unknown_course') || ($result eq 'refused')) {
8231: $output = $logmsg.' '.&mt('Error: ').$result."\n";
1.443 albertel 8232: } else {
1.541 raeburn 8233: $output = $logmsg.$linefeed.&mt('Assigning').' '.$three.' in '.$url.
1.443 albertel 8234: ($start?', '.&mt('starting').' '.localtime($start):'').
1.541 raeburn 8235: ($end?', '.&mt('ending').' '.localtime($end):'').': ';
8236: if ($context eq 'auto') {
8237: $output .= $result.$linefeed.&mt('Add to classlist').': ok';
8238: } else {
8239: $output .= '<b>'.$result.'</b>'.$linefeed.
8240: &mt('Add to classlist').': <b>ok</b>';
8241: }
8242: $output .= $linefeed;
1.443 albertel 8243: }
8244: } else {
8245: $output = &mt('Assigning').' '.$three.' in '.$url.
8246: ($start?', '.&mt('starting').' '.localtime($start):'').
1.541 raeburn 8247: ($end?', '.&mt('ending').' '.localtime($end):'').': ';
1.652 raeburn 8248: my $result = &Apache::lonnet::assignrole($udom,$uname,$url,$three,$end,$start,'','',$context);
1.541 raeburn 8249: if ($context eq 'auto') {
8250: $output .= $result.$linefeed;
8251: } else {
8252: $output .= '<b>'.$result.'</b>'.$linefeed;
8253: }
1.443 albertel 8254: }
8255: return $output;
8256: }
8257:
8258: sub commit_studentrole {
1.541 raeburn 8259: my ($logmsg,$udom,$uname,$url,$three,$start,$end,$one,$two,$sec,$context) = @_;
1.626 raeburn 8260: my ($result,$linefeed,$oldsecurl,$newsecurl);
1.541 raeburn 8261: if ($context eq 'auto') {
8262: $linefeed = "\n";
8263: } else {
8264: $linefeed = '<br />'."\n";
8265: }
1.443 albertel 8266: if (defined($one) && defined($two)) {
8267: my $cid=$one.'_'.$two;
8268: my $oldsec=&Apache::lonnet::getsection($udom,$uname,$cid);
8269: my $secchange = 0;
8270: my $expire_role_result;
8271: my $modify_section_result;
1.628 raeburn 8272: if ($oldsec ne '-1') {
8273: if ($oldsec ne $sec) {
1.443 albertel 8274: $secchange = 1;
1.628 raeburn 8275: my $now = time;
1.443 albertel 8276: my $uurl='/'.$cid;
8277: $uurl=~s/\_/\//g;
8278: if ($oldsec) {
8279: $uurl.='/'.$oldsec;
8280: }
1.626 raeburn 8281: $oldsecurl = $uurl;
1.628 raeburn 8282: $expire_role_result =
1.652 raeburn 8283: &Apache::lonnet::assignrole($udom,$uname,$uurl,'st',$now,'','',$context);
1.628 raeburn 8284: if ($env{'request.course.sec'} ne '') {
8285: if ($expire_role_result eq 'refused') {
8286: my @roles = ('st');
8287: my @statuses = ('previous');
8288: my @roledoms = ($one);
8289: my $withsec = 1;
8290: my %roleshash =
8291: &Apache::lonnet::get_my_roles($uname,$udom,'userroles',
8292: \@statuses,\@roles,\@roledoms,$withsec);
8293: if (defined ($roleshash{$two.':'.$one.':st:'.$oldsec})) {
8294: my ($oldstart,$oldend) =
8295: split(':',$roleshash{$two.':'.$one.':st:'.$oldsec});
8296: if ($oldend > 0 && $oldend <= $now) {
8297: $expire_role_result = 'ok';
8298: }
8299: }
8300: }
8301: }
1.443 albertel 8302: $result = $expire_role_result;
8303: }
8304: }
8305: if (($expire_role_result eq 'ok') || ($secchange == 0)) {
1.652 raeburn 8306: $modify_section_result = &Apache::lonnet::modify_student_enrollment($udom,$uname,undef,undef,undef,undef,undef,$sec,$end,$start,'','',$cid,'',$context);
1.443 albertel 8307: if ($modify_section_result =~ /^ok/) {
8308: if ($secchange == 1) {
1.628 raeburn 8309: if ($sec eq '') {
8310: $$logmsg .= &mt('Section for [_1] switched from (possibly expired) old section: [_2] to student role without a section.',$uname,$oldsec).$linefeed;
8311: } else {
8312: $$logmsg .= &mt('Section for [_1] switched from (possibly expired) old section: [_2] to new section: [_3].',$uname,$oldsec,$sec).$linefeed;
8313: }
1.443 albertel 8314: } elsif ($oldsec eq '-1') {
1.628 raeburn 8315: if ($sec eq '') {
8316: $$logmsg .= &mt('New student role without a section for [_1] in course [_2].',$uname,$cid).$linefeed;
8317: } else {
8318: $$logmsg .= &mt('New student role for [_1] in section [_2] in course [_3].',$uname,$sec,$cid).$linefeed;
8319: }
1.443 albertel 8320: } else {
1.628 raeburn 8321: if ($sec eq '') {
8322: $$logmsg .= &mt('Student [_1] assigned to course [_2] without a section.',$uname,$cid).$linefeed;
8323: } else {
8324: $$logmsg .= &mt('Student [_1] assigned to section [_2] in course [_3].',$uname,$sec,$cid).$linefeed;
8325: }
1.443 albertel 8326: }
8327: } else {
1.628 raeburn 8328: if ($secchange) {
8329: $$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;
8330: } else {
8331: $$logmsg .= &mt('Error when attempting to modify role for [_1] for section: "[_2]" in course [_3] -error:',$uname,$sec,$cid).' '.$modify_section_result.$linefeed;
8332: }
1.443 albertel 8333: }
8334: $result = $modify_section_result;
8335: } elsif ($secchange == 1) {
1.628 raeburn 8336: if ($oldsec eq '') {
8337: $$logmsg .= &mt('Error when attempting to expire existing role without a section for [_1] in course [_3] -error: ',$uname,$cid).' '.$expire_role_result.$linefeed;
8338: } else {
8339: $$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;
8340: }
1.626 raeburn 8341: if ($expire_role_result eq 'refused') {
8342: my $newsecurl = '/'.$cid;
8343: $newsecurl =~ s/\_/\//g;
8344: if ($sec ne '') {
8345: $newsecurl.='/'.$sec;
8346: }
8347: if (&Apache::lonnet::allowed('cst',$newsecurl) && !(&Apache::lonnet::allowed('cst',$oldsecurl))) {
8348: if ($sec eq '') {
8349: $$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;
8350: } else {
8351: $$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;
8352: }
8353: }
8354: }
1.443 albertel 8355: }
8356: } else {
1.626 raeburn 8357: $$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 8358: $result = "error: incomplete course id\n";
8359: }
8360: return $result;
8361: }
8362:
8363: ############################################################
8364: ############################################################
8365:
1.566 albertel 8366: sub check_clone {
1.578 raeburn 8367: my ($args,$linefeed) = @_;
1.566 albertel 8368: my $cloneid='/'.$args->{'clonedomain'}.'/'.$args->{'clonecourse'};
8369: my ($clonecrsudom,$clonecrsunum)= &LONCAPA::split_courseid($cloneid);
8370: my $clonehome=&Apache::lonnet::homeserver($clonecrsunum,$clonecrsudom);
8371: my $clonemsg;
8372: my $can_clone = 0;
8373:
8374: if ($clonehome eq 'no_host') {
1.578 raeburn 8375: $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 8376: } else {
8377: my %clonedesc = &Apache::lonnet::coursedescription($cloneid,{'one_time' => 1});
1.568 albertel 8378: if ($env{'request.role.domain'} eq $args->{'clonedomain'}) {
1.566 albertel 8379: $can_clone = 1;
8380: } else {
8381: my %clonehash = &Apache::lonnet::get('environment',['cloners'],
8382: $args->{'clonedomain'},$args->{'clonecourse'});
8383: my @cloners = split(/,/,$clonehash{'cloners'});
1.578 raeburn 8384: if (grep(/^\*$/,@cloners)) {
8385: $can_clone = 1;
8386: } elsif (grep(/^\*\:\Q$args->{'ccdomain'}\E$/,@cloners)) {
8387: $can_clone = 1;
8388: } else {
8389: my %roleshash =
8390: &Apache::lonnet::get_my_roles($args->{'ccuname'},
8391: $args->{'ccdomain'},
8392: 'userroles',['active'],['cc'],
8393: [$args->{'clonedomain'}]);
8394: if (($roleshash{$args->{'clonecourse'}.':'.$args->{'clonedomain'}.':cc'}) || (grep(/^\Q$args->{'ccuname'}\E:\Q$args->{'ccdomain'}\E$/,@cloners))) {
8395: $can_clone = 1;
8396: } else {
8397: $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'});
8398: }
1.566 albertel 8399: }
1.578 raeburn 8400: }
1.566 albertel 8401: }
8402: return ($can_clone, $clonemsg, $cloneid, $clonehome);
8403: }
8404:
1.444 albertel 8405: sub construct_course {
1.541 raeburn 8406: my ($args,$logmsg,$courseid,$crsudom,$crsunum,$udom,$uname,$context) = @_;
1.444 albertel 8407: my $outcome;
1.541 raeburn 8408: my $linefeed = '<br />'."\n";
8409: if ($context eq 'auto') {
8410: $linefeed = "\n";
8411: }
1.566 albertel 8412:
8413: #
8414: # Are we cloning?
8415: #
8416: my ($can_clone, $clonemsg, $cloneid, $clonehome);
8417: if (($args->{'clonecourse'}) && ($args->{'clonedomain'})) {
1.578 raeburn 8418: ($can_clone, $clonemsg, $cloneid, $clonehome) = &check_clone($args,$linefeed);
1.566 albertel 8419: if ($context ne 'auto') {
1.578 raeburn 8420: if ($clonemsg ne '') {
8421: $clonemsg = '<span class="LC_error">'.$clonemsg.'</span>';
8422: }
1.566 albertel 8423: }
8424: $outcome .= $clonemsg.$linefeed;
8425:
8426: if (!$can_clone) {
8427: return (0,$outcome);
8428: }
8429: }
8430:
1.444 albertel 8431: #
8432: # Open course
8433: #
8434: my $crstype = lc($args->{'crstype'});
8435: my %cenv=();
8436: $$courseid=&Apache::lonnet::createcourse($args->{'course_domain'},
8437: $args->{'cdescr'},
8438: $args->{'curl'},
8439: $args->{'course_home'},
8440: $args->{'nonstandard'},
8441: $args->{'crscode'},
8442: $args->{'ccuname'}.':'.
8443: $args->{'ccdomain'},
8444: $args->{'crstype'});
8445:
8446: # Note: The testing routines depend on this being output; see
8447: # Utils::Course. This needs to at least be output as a comment
8448: # if anyone ever decides to not show this, and Utils::Course::new
8449: # will need to be suitably modified.
1.541 raeburn 8450: $outcome .= &mt('New LON-CAPA [_1] ID: [_2]',$crstype,$$courseid).$linefeed;
1.444 albertel 8451: #
8452: # Check if created correctly
8453: #
1.479 albertel 8454: ($$crsudom,$$crsunum)= &LONCAPA::split_courseid($$courseid);
1.444 albertel 8455: my $crsuhome=&Apache::lonnet::homeserver($$crsunum,$$crsudom);
1.541 raeburn 8456: $outcome .= &mt('Created on').': '.$crsuhome.$linefeed;
1.566 albertel 8457:
1.444 albertel 8458: #
1.566 albertel 8459: # Do the cloning
8460: #
8461: if ($can_clone && $cloneid) {
8462: $clonemsg = &mt('Cloning [_1] from [_2]',$crstype,$clonehome);
8463: if ($context ne 'auto') {
8464: $clonemsg = '<span class="LC_success">'.$clonemsg.'</span>';
8465: }
8466: $outcome .= $clonemsg.$linefeed;
8467: my %oldcenv=&Apache::lonnet::dump('environment',$$crsudom,$$crsunum);
1.444 albertel 8468: # Copy all files
1.637 www 8469: &Apache::lonclonecourse::copycoursefiles($cloneid,$$courseid,$args->{'datemode'},$args->{'dateshift'});
1.444 albertel 8470: # Restore URL
1.566 albertel 8471: $cenv{'url'}=$oldcenv{'url'};
1.444 albertel 8472: # Restore title
1.566 albertel 8473: $cenv{'description'}=$oldcenv{'description'};
1.444 albertel 8474: # Mark as cloned
1.566 albertel 8475: $cenv{'clonedfrom'}=$cloneid;
1.638 www 8476: # Need to clone grading mode
8477: my %newenv=&Apache::lonnet::get('environment',['grading'],$$crsudom,$$crsunum);
8478: $cenv{'grading'}=$newenv{'grading'};
8479: # Do not clone these environment entries
8480: &Apache::lonnet::del('environment',
8481: ['default_enrollment_start_date',
8482: 'default_enrollment_end_date',
8483: 'question.email',
8484: 'policy.email',
8485: 'comment.email',
8486: 'pch.users.denied',
8487: 'plc.users.denied'],
8488: $$crsudom,$$crsunum);
1.444 albertel 8489: }
1.566 albertel 8490:
1.444 albertel 8491: #
8492: # Set environment (will override cloned, if existing)
8493: #
8494: my @sections = ();
8495: my @xlists = ();
8496: if ($args->{'crstype'}) {
8497: $cenv{'type'}=$args->{'crstype'};
8498: }
8499: if ($args->{'crsid'}) {
8500: $cenv{'courseid'}=$args->{'crsid'};
8501: }
8502: if ($args->{'crscode'}) {
8503: $cenv{'internal.coursecode'}=$args->{'crscode'};
8504: }
8505: if ($args->{'crsquota'} ne '') {
8506: $cenv{'internal.coursequota'}=$args->{'crsquota'};
8507: } else {
8508: $cenv{'internal.coursequota'}=$args->{'crsquota'} = 20;
8509: }
8510: if ($args->{'ccuname'}) {
8511: $cenv{'internal.courseowner'} = $args->{'ccuname'}.
8512: ':'.$args->{'ccdomain'};
8513: } else {
8514: $cenv{'internal.courseowner'} = $args->{'curruser'};
8515: }
8516: my @badclasses = (); # Used to accumulate sections/crosslistings that did not pass classlist access check for course owner.
8517: if ($args->{'crssections'}) {
8518: $cenv{'internal.sectionnums'} = '';
8519: if ($args->{'crssections'} =~ m/,/) {
8520: @sections = split/,/,$args->{'crssections'};
8521: } else {
8522: $sections[0] = $args->{'crssections'};
8523: }
8524: if (@sections > 0) {
8525: foreach my $item (@sections) {
8526: my ($sec,$gp) = split/:/,$item;
8527: my $class = $args->{'crscode'}.$sec;
8528: my $addcheck = &Apache::lonnet::auto_new_course($$crsunum,$$crsudom,$class,$cenv{'internal.courseowner'});
8529: $cenv{'internal.sectionnums'} .= $item.',';
8530: unless ($addcheck eq 'ok') {
8531: push @badclasses, $class;
8532: }
8533: }
8534: $cenv{'internal.sectionnums'} =~ s/,$//;
8535: }
8536: }
8537: # do not hide course coordinator from staff listing,
8538: # even if privileged
8539: $cenv{'nothideprivileged'}=$args->{'ccuname'}.':'.$args->{'ccdomain'};
8540: # add crosslistings
8541: if ($args->{'crsxlist'}) {
8542: $cenv{'internal.crosslistings'}='';
8543: if ($args->{'crsxlist'} =~ m/,/) {
8544: @xlists = split/,/,$args->{'crsxlist'};
8545: } else {
8546: $xlists[0] = $args->{'crsxlist'};
8547: }
8548: if (@xlists > 0) {
8549: foreach my $item (@xlists) {
8550: my ($xl,$gp) = split/:/,$item;
8551: my $addcheck = &Apache::lonnet::auto_new_course($$crsunum,$$crsudom,$xl,$cenv{'internal.courseowner'});
8552: $cenv{'internal.crosslistings'} .= $item.',';
8553: unless ($addcheck eq 'ok') {
8554: push @badclasses, $xl;
8555: }
8556: }
8557: $cenv{'internal.crosslistings'} =~ s/,$//;
8558: }
8559: }
8560: if ($args->{'autoadds'}) {
8561: $cenv{'internal.autoadds'}=$args->{'autoadds'};
8562: }
8563: if ($args->{'autodrops'}) {
8564: $cenv{'internal.autodrops'}=$args->{'autodrops'};
8565: }
8566: # check for notification of enrollment changes
8567: my @notified = ();
8568: if ($args->{'notify_owner'}) {
8569: if ($args->{'ccuname'} ne '') {
8570: push(@notified,$args->{'ccuname'}.':'.$args->{'ccdomain'});
8571: }
8572: }
8573: if ($args->{'notify_dc'}) {
8574: if ($uname ne '') {
1.630 raeburn 8575: push(@notified,$uname.':'.$udom);
1.444 albertel 8576: }
8577: }
8578: if (@notified > 0) {
8579: my $notifylist;
8580: if (@notified > 1) {
8581: $notifylist = join(',',@notified);
8582: } else {
8583: $notifylist = $notified[0];
8584: }
8585: $cenv{'internal.notifylist'} = $notifylist;
8586: }
8587: if (@badclasses > 0) {
8588: my %lt=&Apache::lonlocal::texthash(
8589: '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',
8590: 'dnhr' => 'does not have rights to access enrollment in these classes',
8591: 'adby' => 'as determined by the policies of your institution on access to official classlists'
8592: );
1.541 raeburn 8593: my $badclass_msg = $cenv{'internal.courseowner'}.') - '.$lt{'dnhr'}.
8594: ' ('.$lt{'adby'}.')';
8595: if ($context eq 'auto') {
8596: $outcome .= $badclass_msg.$linefeed;
1.566 albertel 8597: $outcome .= '<div class="LC_warning">'.$badclass_msg.$linefeed.'<ul>'."\n";
1.541 raeburn 8598: foreach my $item (@badclasses) {
8599: if ($context eq 'auto') {
8600: $outcome .= " - $item\n";
8601: } else {
8602: $outcome .= "<li>$item</li>\n";
8603: }
8604: }
8605: if ($context eq 'auto') {
8606: $outcome .= $linefeed;
8607: } else {
1.566 albertel 8608: $outcome .= "</ul><br /><br /></div>\n";
1.541 raeburn 8609: }
8610: }
1.444 albertel 8611: }
8612: if ($args->{'no_end_date'}) {
8613: $args->{'endaccess'} = 0;
8614: }
8615: $cenv{'internal.autostart'}=$args->{'enrollstart'};
8616: $cenv{'internal.autoend'}=$args->{'enrollend'};
8617: $cenv{'default_enrollment_start_date'}=$args->{'startaccess'};
8618: $cenv{'default_enrollment_end_date'}=$args->{'endaccess'};
8619: if ($args->{'showphotos'}) {
8620: $cenv{'internal.showphotos'}=$args->{'showphotos'};
8621: }
8622: $cenv{'internal.authtype'} = $args->{'authtype'};
8623: $cenv{'internal.autharg'} = $args->{'autharg'};
8624: if ( ($cenv{'internal.authtype'} =~ /^krb/) && ($cenv{'internal.autoadds'} == 1)) {
8625: if (! defined($cenv{'internal.autharg'}) || $cenv{'internal.autharg'} eq '') {
1.541 raeburn 8626: 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');
8627: if ($context eq 'auto') {
8628: $outcome .= $krb_msg;
8629: } else {
1.566 albertel 8630: $outcome .= '<span class="LC_error">'.$krb_msg.'</span>';
1.541 raeburn 8631: }
8632: $outcome .= $linefeed;
1.444 albertel 8633: }
8634: }
8635: if (($args->{'ccdomain'}) && ($args->{'ccuname'})) {
8636: if ($args->{'setpolicy'}) {
8637: $cenv{'policy.email'}=$args->{'ccuname'}.':'.$args->{'ccdomain'};
8638: }
8639: if ($args->{'setcontent'}) {
8640: $cenv{'question.email'}=$args->{'ccuname'}.':'.$args->{'ccdomain'};
8641: }
8642: }
8643: if ($args->{'reshome'}) {
8644: $cenv{'reshome'}=$args->{'reshome'}.'/';
8645: $cenv{'reshome'}=~s/\/+$/\//;
8646: }
8647: #
8648: # course has keyed access
8649: #
8650: if ($args->{'setkeys'}) {
8651: $cenv{'keyaccess'}='yes';
8652: }
8653: # if specified, key authority is not course, but user
8654: # only active if keyaccess is yes
8655: if ($args->{'keyauth'}) {
1.487 albertel 8656: my ($user,$domain) = split(':',$args->{'keyauth'});
8657: $user = &LONCAPA::clean_username($user);
8658: $domain = &LONCAPA::clean_username($domain);
1.488 foxr 8659: if ($user ne '' && $domain ne '') {
1.487 albertel 8660: $cenv{'keyauth'}=$user.':'.$domain;
1.444 albertel 8661: }
8662: }
8663:
8664: if ($args->{'disresdis'}) {
8665: $cenv{'pch.roles.denied'}='st';
8666: }
8667: if ($args->{'disablechat'}) {
8668: $cenv{'plc.roles.denied'}='st';
8669: }
8670:
8671: # Record we've not yet viewed the Course Initialization Helper for this
8672: # course
8673: $cenv{'course.helper.not.run'} = 1;
8674: #
8675: # Use new Randomseed
8676: #
8677: $cenv{'rndseed'}=&Apache::lonnet::latest_rnd_algorithm_id();;
8678: $cenv{'receiptalg'}=&Apache::lonnet::latest_receipt_algorithm_id();;
8679: #
8680: # The encryption code and receipt prefix for this course
8681: #
8682: $cenv{'internal.encseed'}=$Apache::lonnet::perlvar{'lonReceipt'}.$$.time.int(rand(9999));
8683: $cenv{'internal.encpref'}=100+int(9*rand(99));
8684: #
8685: # By default, use standard grading
8686: if (!defined($cenv{'grading'})) { $cenv{'grading'} = 'standard'; }
8687:
1.541 raeburn 8688: $outcome .= $linefeed.&mt('Setting environment').': '.
8689: &Apache::lonnet::put('environment',\%cenv,$$crsudom,$$crsunum).$linefeed;
1.444 albertel 8690: #
8691: # Open all assignments
8692: #
8693: if ($args->{'openall'}) {
8694: my $storeunder=$$crsudom.'_'.$$crsunum.'.0.opendate';
8695: my %storecontent = ($storeunder => time,
8696: $storeunder.'.type' => 'date_start');
8697:
8698: $outcome .= &mt('Opening all assignments').': '.&Apache::lonnet::cput
1.541 raeburn 8699: ('resourcedata',\%storecontent,$$crsudom,$$crsunum).$linefeed;
1.444 albertel 8700: }
8701: #
8702: # Set first page
8703: #
8704: unless (($args->{'nonstandard'}) || ($args->{'firstres'} eq 'blank')
8705: || ($cloneid)) {
1.445 albertel 8706: use LONCAPA::map;
1.444 albertel 8707: $outcome .= &mt('Setting first resource').': ';
1.445 albertel 8708:
8709: my $map = '/uploaded/'.$$crsudom.'/'.$$crsunum.'/default.sequence';
8710: my ($errtext,$fatal)=&LONCAPA::map::mapread($map);
8711:
1.444 albertel 8712: $outcome .= ($fatal?$errtext:'read ok').' - ';
8713: my $title; my $url;
8714: if ($args->{'firstres'} eq 'syl') {
8715: $title='Syllabus';
8716: $url='/public/'.$$crsudom.'/'.$$crsunum.'/syllabus';
8717: } else {
8718: $title='Navigate Contents';
8719: $url='/adm/navmaps';
8720: }
1.445 albertel 8721:
8722: $LONCAPA::map::resources[1]=$title.':'.$url.':false:start:res';
8723: (my $outtext,$errtext) = &LONCAPA::map::storemap($map,1);
8724:
8725: if ($errtext) { $fatal=2; }
1.541 raeburn 8726: $outcome .= ($fatal?$errtext:'write ok').$linefeed;
1.444 albertel 8727: }
1.566 albertel 8728:
8729: return (1,$outcome);
1.444 albertel 8730: }
8731:
8732: ############################################################
8733: ############################################################
8734:
1.378 raeburn 8735: sub course_type {
8736: my ($cid) = @_;
8737: if (!defined($cid)) {
8738: $cid = $env{'request.course.id'};
8739: }
1.404 albertel 8740: if (defined($env{'course.'.$cid.'.type'})) {
8741: return $env{'course.'.$cid.'.type'};
1.378 raeburn 8742: } else {
8743: return 'Course';
1.377 raeburn 8744: }
8745: }
1.156 albertel 8746:
1.406 raeburn 8747: sub group_term {
8748: my $crstype = &course_type();
8749: my %names = (
8750: 'Course' => 'group',
8751: 'Group' => 'team',
8752: );
8753: return $names{$crstype};
8754: }
8755:
1.156 albertel 8756: sub icon {
8757: my ($file)=@_;
1.505 albertel 8758: my $curfext = lc((split(/\./,$file))[-1]);
1.168 albertel 8759: my $iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/unknown.gif';
1.156 albertel 8760: my $embstyle = &Apache::loncommon::fileembstyle($curfext);
1.168 albertel 8761: if (!(!defined($embstyle) || $embstyle eq 'unk' || $embstyle eq 'hdn')) {
8762: if (-e $Apache::lonnet::perlvar{'lonDocRoot'}.'/'.
8763: $Apache::lonnet::perlvar{'lonIconsURL'}.'/'.
8764: $curfext.".gif") {
8765: $iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/'.
8766: $curfext.".gif";
8767: }
8768: }
1.249 albertel 8769: return &lonhttpdurl($iconname);
1.154 albertel 8770: }
1.84 albertel 8771:
1.575 albertel 8772: sub lonhttpd_port {
1.215 albertel 8773: my $lonhttpd_port=$Apache::lonnet::perlvar{'lonhttpdPort'};
8774: if (!defined($lonhttpd_port)) { $lonhttpd_port='8080'; }
1.574 albertel 8775: # IE doesn't like a secure page getting images from a non-secure
8776: # port (when logging we haven't parsed the browser type so default
8777: # back to secure
8778: if ((!exists($env{'browser.type'}) || $env{'browser.type'} eq 'explorer')
8779: && $ENV{'SERVER_PORT'} == 443) {
1.575 albertel 8780: return 443;
8781: }
8782: return $lonhttpd_port;
8783:
8784: }
8785:
8786: sub lonhttpdurl {
8787: my ($url)=@_;
8788:
8789: my $lonhttpd_port = &lonhttpd_port();
8790: if ($lonhttpd_port == 443) {
1.574 albertel 8791: return 'https://'.$ENV{'SERVER_NAME'}.$url;
8792: }
1.215 albertel 8793: return 'http://'.$ENV{'SERVER_NAME'}.':'.$lonhttpd_port.$url;
8794: }
8795:
1.213 albertel 8796: sub connection_aborted {
8797: my ($r)=@_;
8798: $r->print(" ");$r->rflush();
8799: my $c = $r->connection;
8800: return $c->aborted();
8801: }
8802:
1.221 foxr 8803: # Escapes strings that may have embedded 's that will be put into
1.222 foxr 8804: # strings as 'strings'.
8805: sub escape_single {
1.221 foxr 8806: my ($input) = @_;
1.223 albertel 8807: $input =~ s/\\/\\\\/g; # Escape the \'s..(must be first)>
1.221 foxr 8808: $input =~ s/\'/\\\'/g; # Esacpe the 's....
8809: return $input;
8810: }
1.223 albertel 8811:
1.222 foxr 8812: # Same as escape_single, but escape's "'s This
8813: # can be used for "strings"
8814: sub escape_double {
8815: my ($input) = @_;
8816: $input =~ s/\\/\\\\/g; # Escape the /'s..(must be first)>
8817: $input =~ s/\"/\\\"/g; # Esacpe the "s....
8818: return $input;
8819: }
1.223 albertel 8820:
1.222 foxr 8821: # Escapes the last element of a full URL.
8822: sub escape_url {
8823: my ($url) = @_;
1.238 raeburn 8824: my @urlslices = split(/\//, $url,-1);
1.369 www 8825: my $lastitem = &escape(pop(@urlslices));
1.223 albertel 8826: return join('/',@urlslices).'/'.$lastitem;
1.222 foxr 8827: }
1.462 albertel 8828:
8829: # -------------------------------------------------------- Initliaze user login
8830: sub init_user_environment {
1.463 albertel 8831: my ($r, $username, $domain, $authhost, $form, $args) = @_;
1.462 albertel 8832: my $lonids=$Apache::lonnet::perlvar{'lonIDsDir'};
8833:
8834: my $public=($username eq 'public' && $domain eq 'public');
8835:
8836: # See if old ID present, if so, remove
8837:
8838: my ($filename,$cookie,$userroles);
8839: my $now=time;
8840:
8841: if ($public) {
8842: my $max_public=100;
8843: my $oldest;
8844: my $oldest_time=0;
8845: for(my $next=1;$next<=$max_public;$next++) {
8846: if (-e $lonids."/publicuser_$next.id") {
8847: my $mtime=(stat($lonids."/publicuser_$next.id"))[9];
8848: if ($mtime<$oldest_time || !$oldest_time) {
8849: $oldest_time=$mtime;
8850: $oldest=$next;
8851: }
8852: } else {
8853: $cookie="publicuser_$next";
8854: last;
8855: }
8856: }
8857: if (!$cookie) { $cookie="publicuser_$oldest"; }
8858: } else {
1.463 albertel 8859: # if this isn't a robot, kill any existing non-robot sessions
8860: if (!$args->{'robot'}) {
8861: opendir(DIR,$lonids);
8862: while ($filename=readdir(DIR)) {
8863: if ($filename=~/^$username\_\d+\_$domain\_$authhost\.id$/) {
8864: unlink($lonids.'/'.$filename);
8865: }
1.462 albertel 8866: }
1.463 albertel 8867: closedir(DIR);
1.462 albertel 8868: }
8869: # Give them a new cookie
1.463 albertel 8870: my $id = ($args->{'robot'} ? 'robot'.$args->{'robot'}
8871: : $now);
8872: $cookie="$username\_$id\_$domain\_$authhost";
1.462 albertel 8873:
8874: # Initialize roles
8875:
8876: $userroles=&Apache::lonnet::rolesinit($domain,$username,$authhost);
8877: }
8878: # ------------------------------------ Check browser type and MathML capability
8879:
8880: my ($httpbrowser,$clientbrowser,$clientversion,$clientmathml,
8881: $clientunicode,$clientos) = &decode_user_agent($r);
8882:
8883: # -------------------------------------- Any accessibility options to remember?
8884: if (($form->{'interface'}) && ($form->{'remember'} eq 'true')) {
8885: foreach my $option ('imagesuppress','appletsuppress',
8886: 'embedsuppress','fontenhance','blackwhite') {
8887: if ($form->{$option} eq 'true') {
8888: &Apache::lonnet::put('environment',{$option => 'on'},
8889: $domain,$username);
8890: } else {
8891: &Apache::lonnet::del('environment',[$option],
8892: $domain,$username);
8893: }
8894: }
8895: }
8896: # ------------------------------------------------------------- Get environment
8897:
8898: my %userenv = &Apache::lonnet::dump('environment',$domain,$username);
8899: my ($tmp) = keys(%userenv);
8900: if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
8901: # default remote control to off
8902: if ($userenv{'remote'} ne 'on') { $userenv{'remote'} = 'off'; }
8903: } else {
8904: undef(%userenv);
8905: }
8906: if (($userenv{'interface'}) && (!$form->{'interface'})) {
8907: $form->{'interface'}=$userenv{'interface'};
8908: }
8909: $env{'environment.remote'}=$userenv{'remote'};
8910: if ($userenv{'texengine'} eq 'ttm') { $clientmathml=1; }
8911:
8912: # --------------- Do not trust query string to be put directly into environment
8913: foreach my $option ('imagesuppress','appletsuppress',
8914: 'embedsuppress','fontenhance','blackwhite',
8915: 'interface','localpath','localres') {
8916: $form->{$option}=~s/[\n\r\=]//gs;
8917: }
8918: # --------------------------------------------------------- Write first profile
8919:
8920: {
8921: my %initial_env =
8922: ("user.name" => $username,
8923: "user.domain" => $domain,
8924: "user.home" => $authhost,
8925: "browser.type" => $clientbrowser,
8926: "browser.version" => $clientversion,
8927: "browser.mathml" => $clientmathml,
8928: "browser.unicode" => $clientunicode,
8929: "browser.os" => $clientos,
8930: "server.domain" => $Apache::lonnet::perlvar{'lonDefDomain'},
8931: "request.course.fn" => '',
8932: "request.course.uri" => '',
8933: "request.course.sec" => '',
8934: "request.role" => 'cm',
8935: "request.role.adv" => $env{'user.adv'},
8936: "request.host" => $ENV{'REMOTE_ADDR'},);
8937:
8938: if ($form->{'localpath'}) {
8939: $initial_env{"browser.localpath"} = $form->{'localpath'};
8940: $initial_env{"browser.localres"} = $form->{'localres'};
8941: }
8942:
8943: if ($public) {
8944: $initial_env{"environment.remote"} = "off";
8945: }
8946: if ($form->{'interface'}) {
8947: $form->{'interface'}=~s/\W//gs;
8948: $initial_env{"browser.interface"} = $form->{'interface'};
8949: $env{'browser.interface'}=$form->{'interface'};
8950: foreach my $option ('imagesuppress','appletsuppress',
8951: 'embedsuppress','fontenhance','blackwhite') {
8952: if (($form->{$option} eq 'true') ||
8953: ($userenv{$option} eq 'on')) {
8954: $initial_env{"browser.$option"} = "on";
8955: }
8956: }
8957: }
8958:
8959: $env{'user.environment'} = "$lonids/$cookie.id";
8960:
8961: if (tie(my %disk_env,'GDBM_File',"$lonids/$cookie.id",
8962: &GDBM_WRCREAT(),0640)) {
8963: &_add_to_env(\%disk_env,\%initial_env);
8964: &_add_to_env(\%disk_env,\%userenv,'environment.');
8965: &_add_to_env(\%disk_env,$userroles);
1.463 albertel 8966: if (ref($args->{'extra_env'})) {
8967: &_add_to_env(\%disk_env,$args->{'extra_env'});
8968: }
1.462 albertel 8969: untie(%disk_env);
8970: } else {
8971: &Apache::lonnet::logthis("<font color=\"blue\">WARNING: ".
8972: 'Could not create environment storage in lonauth: '.$!.'</font>');
8973: return 'error: '.$!;
8974: }
8975: }
8976: $env{'request.role'}='cm';
8977: $env{'request.role.adv'}=$env{'user.adv'};
8978: $env{'browser.type'}=$clientbrowser;
8979:
8980: return $cookie;
8981:
8982: }
8983:
8984: sub _add_to_env {
8985: my ($idf,$env_data,$prefix) = @_;
8986: while (my ($key,$value) = each(%$env_data)) {
8987: $idf->{$prefix.$key} = $value;
8988: $env{$prefix.$key} = $value;
8989: }
8990: }
8991:
8992:
1.41 ng 8993: =pod
8994:
8995: =back
8996:
1.112 bowersj2 8997: =cut
1.41 ng 8998:
1.112 bowersj2 8999: 1;
9000: __END__;
1.41 ng 9001:
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