Annotation of loncom/interface/loncommon.pm, revision 1.685
1.10 albertel 1: # The LearningOnline Network with CAPA
1.1 albertel 2: # a pile of common routines
1.10 albertel 3: #
1.685 ! tempelho 4: # $Id: loncommon.pm,v 1.684 2008/09/11 15:15:29 www Exp $
1.10 albertel 5: #
6: # Copyright Michigan State University Board of Trustees
7: #
8: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
9: #
10: # LON-CAPA is free software; you can redistribute it and/or modify
11: # it under the terms of the GNU General Public License as published by
12: # the Free Software Foundation; either version 2 of the License, or
13: # (at your option) any later version.
14: #
15: # LON-CAPA is distributed in the hope that it will be useful,
16: # but WITHOUT ANY WARRANTY; without even the implied warranty of
17: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18: # GNU General Public License for more details.
19: #
20: # You should have received a copy of the GNU General Public License
21: # along with LON-CAPA; if not, write to the Free Software
22: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
23: #
24: # /home/httpd/html/adm/gpl.txt
25: #
26: # http://www.lon-capa.org/
27: #
1.1 albertel 28:
29: # Makes a table out of the previous attempts
1.2 albertel 30: # Inputs result_from_symbread, user, domain, course_id
1.16 harris41 31: # Reads in non-network-related .tab files
1.1 albertel 32:
1.35 matthew 33: # POD header:
34:
1.45 matthew 35: =pod
36:
1.35 matthew 37: =head1 NAME
38:
39: Apache::loncommon - pile of common routines
40:
41: =head1 SYNOPSIS
42:
1.112 bowersj2 43: Common routines for manipulating connections, student answers,
44: domains, common Javascript fragments, etc.
1.35 matthew 45:
1.112 bowersj2 46: =head1 OVERVIEW
1.35 matthew 47:
1.112 bowersj2 48: A collection of commonly used subroutines that don't have a natural
49: home anywhere else. This collection helps remove
1.35 matthew 50: redundancy from other modules and increase efficiency of memory usage.
51:
52: =cut
53:
54: # End of POD header
1.1 albertel 55: package Apache::loncommon;
56:
57: use strict;
1.258 albertel 58: use Apache::lonnet;
1.46 matthew 59: use GDBM_File;
1.51 www 60: use POSIX qw(strftime mktime);
1.82 www 61: use Apache::lonmenu();
1.498 albertel 62: use Apache::lonenc();
1.117 www 63: use Apache::lonlocal;
1.685 ! tempelho 64: use Apache::lonnet();
1.139 matthew 65: use HTML::Entities;
1.334 albertel 66: use Apache::lonhtmlcommon();
67: use Apache::loncoursedata();
1.344 albertel 68: use Apache::lontexconvert();
1.444 albertel 69: use Apache::lonclonecourse();
1.479 albertel 70: use LONCAPA qw(:DEFAULT :match);
1.657 raeburn 71: use DateTime::TimeZone;
1.117 www 72:
1.517 raeburn 73: # ---------------------------------------------- Designs
74: use vars qw(%defaultdesign);
75:
1.22 www 76: my $readit;
77:
1.517 raeburn 78:
1.157 matthew 79: ##
80: ## Global Variables
81: ##
1.46 matthew 82:
1.643 foxr 83:
84: # ----------------------------------------------- SSI with retries:
85: #
86:
87: =pod
88:
1.648 raeburn 89: =head1 Server Side include with retries:
1.643 foxr 90:
91: =over 4
92:
1.648 raeburn 93: =item * &ssi_with_retries(resource,retries form)
1.643 foxr 94:
95: Performs an ssi with some number of retries. Retries continue either
96: until the result is ok or until the retry count supplied by the
97: caller is exhausted.
98:
99: Inputs:
1.648 raeburn 100:
101: =over 4
102:
1.643 foxr 103: resource - Identifies the resource to insert.
1.648 raeburn 104:
1.643 foxr 105: retries - Count of the number of retries allowed.
1.648 raeburn 106:
1.643 foxr 107: form - Hash that identifies the rendering options.
108:
1.648 raeburn 109: =back
110:
111: Returns:
112:
113: =over 4
114:
1.643 foxr 115: content - The content of the response. If retries were exhausted this is empty.
1.648 raeburn 116:
1.643 foxr 117: response - The response from the last attempt (which may or may not have been successful.
118:
1.648 raeburn 119: =back
120:
121: =back
122:
1.643 foxr 123: =cut
124:
125: sub ssi_with_retries {
126: my ($resource, $retries, %form) = @_;
127:
128:
129: my $ok = 0; # True if we got a good response.
130: my $content;
131: my $response;
132:
133: # Try to get the ssi done. within the retries count:
134:
135: do {
136: ($content, $response) = &Apache::lonnet::ssi($resource, %form);
137: $ok = $response->is_success;
1.650 www 138: if (!$ok) {
139: &Apache::lonnet::logthis("Failed ssi_with_retries on $resource: ".$response->is_success.', '.$response->code.', '.$response->message);
140: }
1.643 foxr 141: $retries--;
142: } while (!$ok && ($retries > 0));
143:
144: if (!$ok) {
145: $content = ''; # On error return an empty content.
146: }
147: return ($content, $response);
148:
149: }
150:
151:
152:
1.20 www 153: # ----------------------------------------------- Filetypes/Languages/Copyright
1.12 harris41 154: my %language;
1.124 www 155: my %supported_language;
1.12 harris41 156: my %cprtag;
1.192 taceyjo1 157: my %scprtag;
1.351 www 158: my %fe; my %fd; my %fm;
1.41 ng 159: my %category_extensions;
1.12 harris41 160:
1.46 matthew 161: # ---------------------------------------------- Thesaurus variables
1.144 matthew 162: #
163: # %Keywords:
164: # A hash used by &keyword to determine if a word is considered a keyword.
165: # $thesaurus_db_file
166: # Scalar containing the full path to the thesaurus database.
1.46 matthew 167:
168: my %Keywords;
169: my $thesaurus_db_file;
170:
1.144 matthew 171: #
172: # Initialize values from language.tab, copyright.tab, filetypes.tab,
173: # thesaurus.tab, and filecategories.tab.
174: #
1.18 www 175: BEGIN {
1.46 matthew 176: # Variable initialization
177: $thesaurus_db_file = $Apache::lonnet::perlvar{'lonTabDir'}."/thesaurus.db";
178: #
1.22 www 179: unless ($readit) {
1.12 harris41 180: # ------------------------------------------------------------------- languages
181: {
1.158 raeburn 182: my $langtabfile = $Apache::lonnet::perlvar{'lonTabDir'}.
183: '/language.tab';
184: if ( open(my $fh,"<$langtabfile") ) {
1.356 albertel 185: while (my $line = <$fh>) {
186: next if ($line=~/^\#/);
187: chomp($line);
188: my ($key,$two,$country,$three,$enc,$val,$sup)=(split(/\t/,$line));
1.158 raeburn 189: $language{$key}=$val.' - '.$enc;
190: if ($sup) {
191: $supported_language{$key}=$sup;
192: }
193: }
194: close($fh);
195: }
1.12 harris41 196: }
197: # ------------------------------------------------------------------ copyrights
198: {
1.158 raeburn 199: my $copyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.
200: '/copyright.tab';
201: if ( open (my $fh,"<$copyrightfile") ) {
1.356 albertel 202: while (my $line = <$fh>) {
203: next if ($line=~/^\#/);
204: chomp($line);
205: my ($key,$val)=(split(/\s+/,$line,2));
1.158 raeburn 206: $cprtag{$key}=$val;
207: }
208: close($fh);
209: }
1.12 harris41 210: }
1.351 www 211: # ----------------------------------------------------------- source copyrights
1.192 taceyjo1 212: {
213: my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.
214: '/source_copyright.tab';
215: if ( open (my $fh,"<$sourcecopyrightfile") ) {
1.356 albertel 216: while (my $line = <$fh>) {
217: next if ($line =~ /^\#/);
218: chomp($line);
219: my ($key,$val)=(split(/\s+/,$line,2));
1.192 taceyjo1 220: $scprtag{$key}=$val;
221: }
222: close($fh);
223: }
224: }
1.63 www 225:
1.517 raeburn 226: # -------------------------------------------------------------- default domain designs
1.63 www 227: my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors';
1.517 raeburn 228: my $designfile = $designdir.'/default.tab';
229: if ( open (my $fh,"<$designfile") ) {
230: while (my $line = <$fh>) {
231: next if ($line =~ /^\#/);
232: chomp($line);
233: my ($key,$val)=(split(/\=/,$line));
234: if ($val) { $defaultdesign{$key}=$val; }
235: }
236: close($fh);
1.63 www 237: }
238:
1.15 harris41 239: # ------------------------------------------------------------- file categories
240: {
1.158 raeburn 241: my $categoryfile = $Apache::lonnet::perlvar{'lonTabDir'}.
242: '/filecategories.tab';
243: if ( open (my $fh,"<$categoryfile") ) {
1.356 albertel 244: while (my $line = <$fh>) {
245: next if ($line =~ /^\#/);
246: chomp($line);
247: my ($extension,$category)=(split(/\s+/,$line,2));
1.158 raeburn 248: push @{$category_extensions{lc($category)}},$extension;
249: }
250: close($fh);
251: }
252:
1.15 harris41 253: }
1.12 harris41 254: # ------------------------------------------------------------------ file types
255: {
1.158 raeburn 256: my $typesfile = $Apache::lonnet::perlvar{'lonTabDir'}.
257: '/filetypes.tab';
258: if ( open (my $fh,"<$typesfile") ) {
1.356 albertel 259: while (my $line = <$fh>) {
260: next if ($line =~ /^\#/);
261: chomp($line);
262: my ($ending,$emb,$mime,$descr)=split(/\s+/,$line,4);
1.158 raeburn 263: if ($descr ne '') {
264: $fe{$ending}=lc($emb);
265: $fd{$ending}=$descr;
1.351 www 266: if ($mime ne 'unk') { $fm{$ending}=$mime; }
1.158 raeburn 267: }
268: }
269: close($fh);
270: }
1.12 harris41 271: }
1.22 www 272: &Apache::lonnet::logthis(
1.46 matthew 273: "<font color=yellow>INFO: Read file types</font>");
1.22 www 274: $readit=1;
1.46 matthew 275: } # end of unless($readit)
1.32 matthew 276:
277: }
1.112 bowersj2 278:
1.42 matthew 279: ###############################################################
280: ## HTML and Javascript Helper Functions ##
281: ###############################################################
282:
283: =pod
284:
1.112 bowersj2 285: =head1 HTML and Javascript Functions
1.42 matthew 286:
1.112 bowersj2 287: =over 4
288:
1.648 raeburn 289: =item * &browser_and_searcher_javascript()
1.112 bowersj2 290:
291: X<browsing, javascript>X<searching, javascript>Returns a string
292: containing javascript with two functions, C<openbrowser> and
293: C<opensearcher>. Returned string does not contain E<lt>scriptE<gt>
294: tags.
1.42 matthew 295:
1.648 raeburn 296: =item * &openbrowser(formname,elementname,only,omit) [javascript]
1.42 matthew 297:
298: inputs: formname, elementname, only, omit
299:
300: formname and elementname indicate the name of the html form and name of
301: the element that the results of the browsing selection are to be placed in.
302:
303: Specifying 'only' will restrict the browser to displaying only files
1.185 www 304: with the given extension. Can be a comma separated list.
1.42 matthew 305:
306: Specifying 'omit' will restrict the browser to NOT displaying files
1.185 www 307: with the given extension. Can be a comma separated list.
1.42 matthew 308:
1.648 raeburn 309: =item * &opensearcher(formname,elementname) [javascript]
1.42 matthew 310:
311: Inputs: formname, elementname
312:
313: formname and elementname specify the name of the html form and the name
314: of the element the selection from the search results will be placed in.
1.542 raeburn 315:
1.42 matthew 316: =cut
317:
318: sub browser_and_searcher_javascript {
1.199 albertel 319: my ($mode)=@_;
320: if (!defined($mode)) { $mode='edit'; }
1.453 albertel 321: my $resurl=&escape_single(&lastresurl());
1.42 matthew 322: return <<END;
1.219 albertel 323: // <!-- BEGIN LON-CAPA Internal
1.50 matthew 324: var editbrowser = null;
1.135 albertel 325: function openbrowser(formname,elementname,only,omit,titleelement) {
1.170 www 326: var url = '$resurl/?';
1.42 matthew 327: if (editbrowser == null) {
328: url += 'launch=1&';
329: }
330: url += 'catalogmode=interactive&';
1.199 albertel 331: url += 'mode=$mode&';
1.611 albertel 332: url += 'inhibitmenu=yes&';
1.42 matthew 333: url += 'form=' + formname + '&';
334: if (only != null) {
335: url += 'only=' + only + '&';
1.217 albertel 336: } else {
337: url += 'only=&';
338: }
1.42 matthew 339: if (omit != null) {
340: url += 'omit=' + omit + '&';
1.217 albertel 341: } else {
342: url += 'omit=&';
343: }
1.135 albertel 344: if (titleelement != null) {
345: url += 'titleelement=' + titleelement + '&';
1.217 albertel 346: } else {
347: url += 'titleelement=&';
348: }
1.42 matthew 349: url += 'element=' + elementname + '';
350: var title = 'Browser';
1.435 albertel 351: var options = 'scrollbars=1,resizable=1,menubar=0,toolbar=1,location=1';
1.42 matthew 352: options += ',width=700,height=600';
353: editbrowser = open(url,title,options,'1');
354: editbrowser.focus();
355: }
356: var editsearcher;
1.135 albertel 357: function opensearcher(formname,elementname,titleelement) {
1.42 matthew 358: var url = '/adm/searchcat?';
359: if (editsearcher == null) {
360: url += 'launch=1&';
361: }
362: url += 'catalogmode=interactive&';
1.199 albertel 363: url += 'mode=$mode&';
1.42 matthew 364: url += 'form=' + formname + '&';
1.135 albertel 365: if (titleelement != null) {
366: url += 'titleelement=' + titleelement + '&';
1.217 albertel 367: } else {
368: url += 'titleelement=&';
369: }
1.42 matthew 370: url += 'element=' + elementname + '';
371: var title = 'Search';
1.435 albertel 372: var options = 'scrollbars=1,resizable=1,menubar=0,toolbar=1,location=1';
1.42 matthew 373: options += ',width=700,height=600';
374: editsearcher = open(url,title,options,'1');
375: editsearcher.focus();
376: }
1.219 albertel 377: // END LON-CAPA Internal -->
1.42 matthew 378: END
1.170 www 379: }
380:
381: sub lastresurl {
1.258 albertel 382: if ($env{'environment.lastresurl'}) {
383: return $env{'environment.lastresurl'}
1.170 www 384: } else {
385: return '/res';
386: }
387: }
388:
389: sub storeresurl {
390: my $resurl=&Apache::lonnet::clutter(shift);
391: unless ($resurl=~/^\/res/) { return 0; }
392: $resurl=~s/\/$//;
393: &Apache::lonnet::put('environment',{'lastresurl' => $resurl});
1.646 raeburn 394: &Apache::lonnet::appenv({'environment.lastresurl' => $resurl});
1.170 www 395: return 1;
1.42 matthew 396: }
397:
1.74 www 398: sub studentbrowser_javascript {
1.111 www 399: unless (
1.258 albertel 400: (($env{'request.course.id'}) &&
1.302 albertel 401: (&Apache::lonnet::allowed('srm',$env{'request.course.id'})
402: || &Apache::lonnet::allowed('srm',$env{'request.course.id'}.
403: '/'.$env{'request.course.sec'})
404: ))
1.258 albertel 405: || ($env{'request.role'}=~/^(au|dc|su)/)
1.111 www 406: ) { return ''; }
1.74 www 407: return (<<'ENDSTDBRW');
408: <script type="text/javascript" language="Javascript" >
409: var stdeditbrowser;
1.558 albertel 410: function openstdbrowser(formname,uname,udom,roleflag,ignorefilter) {
1.74 www 411: var url = '/adm/pickstudent?';
412: var filter;
1.558 albertel 413: if (!ignorefilter) {
414: eval('filter=document.'+formname+'.'+uname+'.value;');
415: }
1.74 www 416: if (filter != null) {
417: if (filter != '') {
418: url += 'filter='+filter+'&';
419: }
420: }
421: url += 'form=' + formname + '&unameelement='+uname+
422: '&udomelement='+udom;
1.111 www 423: if (roleflag) { url+="&roles=1"; }
1.102 www 424: var title = 'Student_Browser';
1.74 www 425: var options = 'scrollbars=1,resizable=1,menubar=0';
426: options += ',width=700,height=600';
427: stdeditbrowser = open(url,title,options,'1');
428: stdeditbrowser.focus();
429: }
430: </script>
431: ENDSTDBRW
432: }
1.42 matthew 433:
1.74 www 434: sub selectstudent_link {
1.111 www 435: my ($form,$unameele,$udomele)=@_;
1.258 albertel 436: if ($env{'request.course.id'}) {
1.302 albertel 437: if (!&Apache::lonnet::allowed('srm',$env{'request.course.id'})
438: && !&Apache::lonnet::allowed('srm',$env{'request.course.id'}.
439: '/'.$env{'request.course.sec'})) {
1.111 www 440: return '';
441: }
442: return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele.
1.607 albertel 443: '","'.$udomele.'");'."'>".&mt('Select User')."</a>";
1.74 www 444: }
1.258 albertel 445: if ($env{'request.role'}=~/^(au|dc|su)/) {
1.111 www 446: return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele.
1.119 www 447: '","'.$udomele.'",1);'."'>".&mt('Select User')."</a>";
1.111 www 448: }
449: return '';
1.91 www 450: }
451:
1.653 raeburn 452: sub authorbrowser_javascript {
453: return <<"ENDAUTHORBRW";
454: <script type="text/javascript">
455: var stdeditbrowser;
456:
457: function openauthorbrowser(formname,udom) {
458: var url = '/adm/pickauthor?';
459: url += 'form='+formname+'&roledom='+udom;
460: var title = 'Author_Browser';
461: var options = 'scrollbars=1,resizable=1,menubar=0';
462: options += ',width=700,height=600';
463: stdeditbrowser = open(url,title,options,'1');
464: stdeditbrowser.focus();
465: }
466:
467: </script>
468: ENDAUTHORBRW
469: }
470:
1.91 www 471: sub coursebrowser_javascript {
1.468 raeburn 472: my ($domainfilter,$sec_element,$formname)=@_;
1.377 raeburn 473: 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 474: my $output = '
1.538 albertel 475: <script type="text/javascript">
1.468 raeburn 476: var stdeditbrowser;'."\n";
477: $output .= <<"ENDSTDBRW";
1.377 raeburn 478: function opencrsbrowser(formname,uname,udom,desc,extra_element,multflag,crstype) {
1.91 www 479: var url = '/adm/pickcourse?';
1.468 raeburn 480: var domainfilter = '';
481: var formid = getFormIdByName(formname);
482: if (formid > -1) {
483: var domid = getIndexByName(formid,udom);
484: if (domid > -1) {
485: if (document.forms[formid].elements[domid].type == 'select-one') {
486: domainfilter=document.forms[formid].elements[domid].options[document.forms[formid].elements[domid].selectedIndex].value;
487: }
488: if (document.forms[formid].elements[domid].type == 'hidden') {
489: domainfilter=document.forms[formid].elements[domid].value;
490: }
491: }
1.91 www 492: }
1.128 albertel 493: if (domainfilter != null) {
494: if (domainfilter != '') {
495: url += 'domainfilter='+domainfilter+'&';
496: }
497: }
1.91 www 498: url += 'form=' + formname + '&cnumelement='+uname+
1.187 albertel 499: '&cdomelement='+udom+
500: '&cnameelement='+desc;
1.468 raeburn 501: if (extra_element !=null && extra_element != '') {
1.594 raeburn 502: if (formname == 'rolechoice' || formname == 'studentform') {
1.468 raeburn 503: url += '&roleelement='+extra_element;
504: if (domainfilter == null || domainfilter == '') {
505: url += '&domainfilter='+extra_element;
506: }
1.234 raeburn 507: }
1.468 raeburn 508: else {
509: if (formname == 'portform') {
510: url += '&setroles='+extra_element;
511: }
512: }
1.230 raeburn 513: }
1.293 raeburn 514: if (multflag !=null && multflag != '') {
515: url += '&multiple='+multflag;
516: }
1.377 raeburn 517: if (crstype == 'Course/Group') {
518: if (formname == 'cu') {
519: crstype = document.cu.crstype.options[document.cu.crstype.selectedIndex].value;
520: if (crstype == "") {
521: alert("$crs_or_grp_alert");
522: return;
523: }
524: }
525: }
526: if (crstype !=null && crstype != '') {
527: url += '&type='+crstype;
528: }
1.102 www 529: var title = 'Course_Browser';
1.91 www 530: var options = 'scrollbars=1,resizable=1,menubar=0';
531: options += ',width=700,height=600';
532: stdeditbrowser = open(url,title,options,'1');
533: stdeditbrowser.focus();
534: }
1.468 raeburn 535:
536: function getFormIdByName(formname) {
537: for (var i=0;i<document.forms.length;i++) {
538: if (document.forms[i].name == formname) {
539: return i;
540: }
541: }
542: return -1;
543: }
544:
545: function getIndexByName(formid,item) {
546: for (var i=0;i<document.forms[formid].elements.length;i++) {
547: if (document.forms[formid].elements[i].name == item) {
548: return i;
549: }
550: }
551: return -1;
552: }
1.91 www 553: ENDSTDBRW
1.468 raeburn 554: if ($sec_element ne '') {
555: $output .= &setsec_javascript($sec_element,$formname);
556: }
557: $output .= '
558: </script>';
559: return $output;
560: }
561:
562: sub setsec_javascript {
563: my ($sec_element,$formname) = @_;
564: my $setsections = qq|
565: function setSect(sectionlist) {
1.629 raeburn 566: var sectionsArray = new Array();
567: if ((sectionlist != '') && (typeof sectionlist != "undefined")) {
568: sectionsArray = sectionlist.split(",");
569: }
1.468 raeburn 570: var numSections = sectionsArray.length;
571: document.$formname.$sec_element.length = 0;
572: if (numSections == 0) {
573: document.$formname.$sec_element.multiple=false;
574: document.$formname.$sec_element.size=1;
575: document.$formname.$sec_element.options[0] = new Option('No existing sections','',false,false)
576: } else {
577: if (numSections == 1) {
578: document.$formname.$sec_element.multiple=false;
579: document.$formname.$sec_element.size=1;
580: document.$formname.$sec_element.options[0] = new Option('Select','',true,true);
581: document.$formname.$sec_element.options[1] = new Option('No section','',false,false)
582: document.$formname.$sec_element.options[2] = new Option(sectionsArray[0],sectionsArray[0],false,false);
583: } else {
584: for (var i=0; i<numSections; i++) {
585: document.$formname.$sec_element.options[i] = new Option(sectionsArray[i],sectionsArray[i],false,false)
586: }
587: document.$formname.$sec_element.multiple=true
588: if (numSections < 3) {
589: document.$formname.$sec_element.size=numSections;
590: } else {
591: document.$formname.$sec_element.size=3;
592: }
593: document.$formname.$sec_element.options[0].selected = false
594: }
595: }
1.91 www 596: }
1.468 raeburn 597: |;
598: return $setsections;
599: }
600:
1.91 www 601:
602: sub selectcourse_link {
1.377 raeburn 603: my ($form,$unameele,$udomele,$desc,$extra_element,$multflag,$selecttype)=@_;
1.492 albertel 604: return "<a href='".'javascript:opencrsbrowser("'.$form.'","'.$unameele.
605: '","'.$udomele.'","'.$desc.'","'.$extra_element.'","'.$multflag.'","'.$selecttype.'");'."'>".&mt('Select Course')."</a>";
1.74 www 606: }
1.42 matthew 607:
1.653 raeburn 608: sub selectauthor_link {
609: my ($form,$udom)=@_;
610: return '<a href="javascript:openauthorbrowser('."'$form','$udom'".');">'.
611: &mt('Select Author').'</a>';
612: }
613:
1.273 raeburn 614: sub check_uncheck_jscript {
615: my $jscript = <<"ENDSCRT";
616: function checkAll(field) {
617: if (field.length > 0) {
618: for (i = 0; i < field.length; i++) {
619: field[i].checked = true ;
620: }
621: } else {
622: field.checked = true
623: }
624: }
625:
626: function uncheckAll(field) {
627: if (field.length > 0) {
628: for (i = 0; i < field.length; i++) {
629: field[i].checked = false ;
1.543 albertel 630: }
631: } else {
1.273 raeburn 632: field.checked = false ;
633: }
634: }
635: ENDSCRT
636: return $jscript;
637: }
638:
1.656 www 639: sub select_timezone {
1.659 raeburn 640: my ($name,$selected,$onchange,$includeempty)=@_;
641: my $output='<select name="'.$name.'" '.$onchange.'>'."\n";
642: if ($includeempty) {
643: $output .= '<option value=""';
644: if (($selected eq '') || ($selected eq 'local')) {
645: $output .= ' selected="selected" ';
646: }
647: $output .= '> </option>';
648: }
1.657 raeburn 649: my @timezones = DateTime::TimeZone->all_names;
650: foreach my $tzone (@timezones) {
651: $output.= '<option value="'.$tzone.'"';
652: if ($tzone eq $selected) {
653: $output.=' selected="selected"';
654: }
655: $output.=">$tzone</option>\n";
1.656 www 656: }
657: $output.="</select>";
658: return $output;
659: }
1.273 raeburn 660:
1.42 matthew 661: =pod
1.36 matthew 662:
1.648 raeburn 663: =item * &linked_select_forms(...)
1.36 matthew 664:
665: linked_select_forms returns a string containing a <script></script> block
666: and html for two <select> menus. The select menus will be linked in that
667: changing the value of the first menu will result in new values being placed
668: in the second menu. The values in the select menu will appear in alphabetical
1.609 raeburn 669: order unless a defined order is provided.
1.36 matthew 670:
671: linked_select_forms takes the following ordered inputs:
672:
673: =over 4
674:
1.112 bowersj2 675: =item * $formname, the name of the <form> tag
1.36 matthew 676:
1.112 bowersj2 677: =item * $middletext, the text which appears between the <select> tags
1.36 matthew 678:
1.112 bowersj2 679: =item * $firstdefault, the default value for the first menu
1.36 matthew 680:
1.112 bowersj2 681: =item * $firstselectname, the name of the first <select> tag
1.36 matthew 682:
1.112 bowersj2 683: =item * $secondselectname, the name of the second <select> tag
1.36 matthew 684:
1.112 bowersj2 685: =item * $hashref, a reference to a hash containing the data for the menus.
1.36 matthew 686:
1.609 raeburn 687: =item * $menuorder, the order of values in the first menu
688:
1.41 ng 689: =back
690:
1.36 matthew 691: Below is an example of such a hash. Only the 'text', 'default', and
692: 'select2' keys must appear as stated. keys(%menu) are the possible
693: values for the first select menu. The text that coincides with the
1.41 ng 694: first menu value is given in $menu{$choice1}->{'text'}. The values
1.36 matthew 695: and text for the second menu are given in the hash pointed to by
696: $menu{$choice1}->{'select2'}.
697:
1.112 bowersj2 698: my %menu = ( A1 => { text =>"Choice A1" ,
699: default => "B3",
700: select2 => {
701: B1 => "Choice B1",
702: B2 => "Choice B2",
703: B3 => "Choice B3",
704: B4 => "Choice B4"
1.609 raeburn 705: },
706: order => ['B4','B3','B1','B2'],
1.112 bowersj2 707: },
708: A2 => { text =>"Choice A2" ,
709: default => "C2",
710: select2 => {
711: C1 => "Choice C1",
712: C2 => "Choice C2",
713: C3 => "Choice C3"
1.609 raeburn 714: },
715: order => ['C2','C1','C3'],
1.112 bowersj2 716: },
717: A3 => { text =>"Choice A3" ,
718: default => "D6",
719: select2 => {
720: D1 => "Choice D1",
721: D2 => "Choice D2",
722: D3 => "Choice D3",
723: D4 => "Choice D4",
724: D5 => "Choice D5",
725: D6 => "Choice D6",
726: D7 => "Choice D7"
1.609 raeburn 727: },
728: order => ['D4','D3','D2','D1','D7','D6','D5'],
1.112 bowersj2 729: }
730: );
1.36 matthew 731:
732: =cut
733:
734: sub linked_select_forms {
735: my ($formname,
736: $middletext,
737: $firstdefault,
738: $firstselectname,
739: $secondselectname,
1.609 raeburn 740: $hashref,
741: $menuorder,
1.36 matthew 742: ) = @_;
743: my $second = "document.$formname.$secondselectname";
744: my $first = "document.$formname.$firstselectname";
745: # output the javascript to do the changing
746: my $result = '';
1.219 albertel 747: $result.="<script type=\"text/javascript\">\n";
1.36 matthew 748: $result.="var select2data = new Object();\n";
749: $" = '","';
750: my $debug = '';
751: foreach my $s1 (sort(keys(%$hashref))) {
752: $result.="select2data.d_$s1 = new Object();\n";
753: $result.="select2data.d_$s1.def = new String('".
754: $hashref->{$s1}->{'default'}."');\n";
1.609 raeburn 755: $result.="select2data.d_$s1.values = new Array(";
1.36 matthew 756: my @s2values = sort(keys( %{ $hashref->{$s1}->{'select2'} } ));
1.609 raeburn 757: if (ref($hashref->{$s1}->{'order'}) eq 'ARRAY') {
758: @s2values = @{$hashref->{$s1}->{'order'}};
759: }
1.36 matthew 760: $result.="\"@s2values\");\n";
761: $result.="select2data.d_$s1.texts = new Array(";
762: my @s2texts;
763: foreach my $value (@s2values) {
764: push @s2texts, $hashref->{$s1}->{'select2'}->{$value};
765: }
766: $result.="\"@s2texts\");\n";
767: }
768: $"=' ';
769: $result.= <<"END";
770:
771: function select1_changed() {
772: // Determine new choice
773: var newvalue = "d_" + $first.value;
774: // update select2
775: var values = select2data[newvalue].values;
776: var texts = select2data[newvalue].texts;
777: var select2def = select2data[newvalue].def;
778: var i;
779: // out with the old
780: for (i = 0; i < $second.options.length; i++) {
781: $second.options[i] = null;
782: }
783: // in with the nuclear
784: for (i=0;i<values.length; i++) {
785: $second.options[i] = new Option(values[i]);
1.143 matthew 786: $second.options[i].value = values[i];
1.36 matthew 787: $second.options[i].text = texts[i];
788: if (values[i] == select2def) {
789: $second.options[i].selected = true;
790: }
791: }
792: }
793: </script>
794: END
795: # output the initial values for the selection lists
796: $result .= "<select size=\"1\" name=\"$firstselectname\" onchange=\"select1_changed()\">\n";
1.609 raeburn 797: my @order = sort(keys(%{$hashref}));
798: if (ref($menuorder) eq 'ARRAY') {
799: @order = @{$menuorder};
800: }
801: foreach my $value (@order) {
1.36 matthew 802: $result.=" <option value=\"$value\" ";
1.253 albertel 803: $result.=" selected=\"selected\" " if ($value eq $firstdefault);
1.119 www 804: $result.=">".&mt($hashref->{$value}->{'text'})."</option>\n";
1.36 matthew 805: }
806: $result .= "</select>\n";
807: my %select2 = %{$hashref->{$firstdefault}->{'select2'}};
808: $result .= $middletext;
809: $result .= "<select size=\"1\" name=\"$secondselectname\">\n";
810: my $seconddefault = $hashref->{$firstdefault}->{'default'};
1.609 raeburn 811:
812: my @secondorder = sort(keys(%select2));
813: if (ref($hashref->{$firstdefault}->{'order'}) eq 'ARRAY') {
814: @secondorder = @{$hashref->{$firstdefault}->{'order'}};
815: }
816: foreach my $value (@secondorder) {
1.36 matthew 817: $result.=" <option value=\"$value\" ";
1.253 albertel 818: $result.=" selected=\"selected\" " if ($value eq $seconddefault);
1.119 www 819: $result.=">".&mt($select2{$value})."</option>\n";
1.36 matthew 820: }
821: $result .= "</select>\n";
822: # return $debug;
823: return $result;
824: } # end of sub linked_select_forms {
825:
1.45 matthew 826: =pod
1.44 bowersj2 827:
1.648 raeburn 828: =item * &help_open_topic($topic,$text,$stayOnPage,$width,$height)
1.44 bowersj2 829:
1.112 bowersj2 830: Returns a string corresponding to an HTML link to the given help
831: $topic, where $topic corresponds to the name of a .tex file in
832: /home/httpd/html/adm/help/tex, with underscores replaced by
833: spaces.
834:
835: $text will optionally be linked to the same topic, allowing you to
836: link text in addition to the graphic. If you do not want to link
837: text, but wish to specify one of the later parameters, pass an
838: empty string.
839:
840: $stayOnPage is a value that will be interpreted as a boolean. If true,
841: the link will not open a new window. If false, the link will open
842: a new window using Javascript. (Default is false.)
843:
844: $width and $height are optional numerical parameters that will
845: override the width and height of the popped up window, which may
846: be useful for certain help topics with big pictures included.
1.44 bowersj2 847:
848: =cut
849:
850: sub help_open_topic {
1.48 bowersj2 851: my ($topic, $text, $stayOnPage, $width, $height) = @_;
852: $text = "" if (not defined $text);
1.44 bowersj2 853: $stayOnPage = 0 if (not defined $stayOnPage);
1.552 banghart 854: if ($env{'browser.interface'} eq 'textual') {
1.79 www 855: $stayOnPage=1;
856: }
1.44 bowersj2 857: $width = 350 if (not defined $width);
858: $height = 400 if (not defined $height);
859: my $filename = $topic;
860: $filename =~ s/ /_/g;
861:
1.48 bowersj2 862: my $template = "";
863: my $link;
1.572 banghart 864:
1.159 www 865: $topic=~s/\W/\_/g;
1.44 bowersj2 866:
1.572 banghart 867: if (!$stayOnPage) {
1.72 bowersj2 868: $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 869: } else {
1.48 bowersj2 870: $link = "/adm/help/${filename}.hlp";
871: }
872:
873: # Add the text
1.572 banghart 874: if ($text ne "") {
1.77 www 875: $template .=
1.572 banghart 876: "<table bgcolor='#3333AA' cellspacing='1' cellpadding='1' border='0'><tr>".
877: "<td bgcolor='#5555FF'><a target=\"_top\" href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";
1.48 bowersj2 878: }
879:
880: # Add the graphic
1.179 matthew 881: my $title = &mt('Online Help');
1.667 raeburn 882: my $helpicon=&lonhttpdurl("/adm/help/help.png");
1.48 bowersj2 883: $template .= <<"ENDTEMPLATE";
1.436 albertel 884: <a target="_top" href="$link" title="$title"><img src="$helpicon" border="0" alt="(Help: $topic)" /></a>
1.44 bowersj2 885: ENDTEMPLATE
1.78 www 886: if ($text ne '') { $template.='</td></tr></table>' };
1.44 bowersj2 887: return $template;
888:
1.106 bowersj2 889: }
890:
891: # This is a quicky function for Latex cheatsheet editing, since it
892: # appears in at least four places
893: sub helpLatexCheatsheet {
894: my $other = shift;
895: my $addOther = '';
896: if ($other) {
897: $addOther = Apache::loncommon::help_open_topic($other, shift,
898: undef, undef, 600) .
899: '</td><td>';
900: }
901: return '<table><tr><td>'.
902: $addOther .
1.636 raeburn 903: &Apache::loncommon::help_open_topic("Greek_Symbols",&mt('Greek Symbols'),
1.106 bowersj2 904: undef,undef,600)
905: .'</td><td>'.
1.636 raeburn 906: &Apache::loncommon::help_open_topic("Other_Symbols",&mt('Other Symbols'),
1.106 bowersj2 907: undef,undef,600)
1.673 felicia 908: .'</td><td>'.
909: &Apache::loncommon::help_open_topic("Authoring_Output_Tags",&mt('Output Tags'),
910: undef,undef,600)
1.106 bowersj2 911: .'</td></tr></table>';
1.172 www 912: }
913:
1.430 albertel 914: sub general_help {
915: my $helptopic='Student_Intro';
916: if ($env{'request.role'}=~/^(ca|au)/) {
917: $helptopic='Authoring_Intro';
918: } elsif ($env{'request.role'}=~/^cc/) {
919: $helptopic='Course_Coordination_Intro';
1.672 raeburn 920: } elsif ($env{'request.role'}=~/^dc/) {
921: $helptopic='Domain_Coordination_Intro';
1.430 albertel 922: }
923: return $helptopic;
924: }
925:
926: sub update_help_link {
927: my ($topic,$component_help,$faq,$bug,$stayOnPage) = @_;
928: my $origurl = $ENV{'REQUEST_URI'};
929: $origurl=~s|^/~|/priv/|;
930: my $timestamp = time;
931: foreach my $datum (\$topic,\$component_help,\$faq,\$bug,\$origurl) {
932: $$datum = &escape($$datum);
933: }
934:
935: my $banner_link = "/adm/helpmenu?page=banner&topic=$topic&component_help=$component_help&faq=$faq&bug=$bug&origurl=$origurl&stamp=$timestamp&stayonpage=$stayOnPage";
936: my $output .= <<"ENDOUTPUT";
937: <script type="text/javascript">
938: banner_link = '$banner_link';
939: </script>
940: ENDOUTPUT
941: return $output;
942: }
943:
944: # now just updates the help link and generates a blue icon
1.193 raeburn 945: sub help_open_menu {
1.430 albertel 946: my ($topic,$component_help,$faq,$bug,$stayOnPage,$width,$height,$text)
1.552 banghart 947: = @_;
1.430 albertel 948: $stayOnPage = 0 if (not defined $stayOnPage);
1.572 banghart 949: # only use pop-up help (stayOnPage == 0)
1.552 banghart 950: # if environment.remote is on (using remote control UI)
1.572 banghart 951: if ($env{'browser.interface'} eq 'textual' ||
952: $env{'environment.remote'} eq 'off' ) {
1.552 banghart 953: $stayOnPage=1;
1.430 albertel 954: }
955: my $output;
956: if ($component_help) {
957: if (!$text) {
958: $output=&help_open_topic($component_help,undef,$stayOnPage,
959: $width,$height);
960: } else {
961: my $help_text;
962: $help_text=&unescape($topic);
963: $output='<table><tr><td>'.
964: &help_open_topic($component_help,$help_text,$stayOnPage,
965: $width,$height).'</td></tr></table>';
966: }
967: }
968: my $banner_link = &update_help_link($topic,$component_help,$faq,$bug,$stayOnPage);
969: return $output.$banner_link;
970: }
971:
972: sub top_nav_help {
973: my ($text) = @_;
1.436 albertel 974: $text = &mt($text);
1.572 banghart 975: my $stay_on_page =
1.436 albertel 976: ($env{'browser.interface'} eq 'textual' ||
977: $env{'environment.remote'} eq 'off' );
1.572 banghart 978: my $link = ($stay_on_page) ? "javascript:helpMenu('display')"
1.436 albertel 979: : "javascript:helpMenu('open')";
1.572 banghart 980: my $banner_link = &update_help_link(undef,undef,undef,undef,$stay_on_page);
1.436 albertel 981:
1.201 raeburn 982: my $title = &mt('Get help');
1.436 albertel 983:
984: return <<"END";
985: $banner_link
986: <a href="$link" title="$title">$text</a>
987: END
988: }
989:
990: sub help_menu_js {
991: my ($text) = @_;
992:
993: my $stayOnPage =
994: ($env{'browser.interface'} eq 'textual' ||
995: $env{'environment.remote'} eq 'off' );
996:
997: my $width = 620;
998: my $height = 600;
1.430 albertel 999: my $helptopic=&general_help();
1000: my $details_link = '/adm/help/'.$helptopic.'.hlp';
1.261 albertel 1001: my $nothing=&Apache::lonhtmlcommon::javascript_nothing();
1.331 albertel 1002: my $start_page =
1003: &Apache::loncommon::start_page('Help Menu', undef,
1004: {'frameset' => 1,
1005: 'js_ready' => 1,
1006: 'add_entries' => {
1007: 'border' => '0',
1.579 raeburn 1008: 'rows' => "110,*",},});
1.331 albertel 1009: my $end_page =
1010: &Apache::loncommon::end_page({'frameset' => 1,
1011: 'js_ready' => 1,});
1012:
1.436 albertel 1013: my $template .= <<"ENDTEMPLATE";
1014: <script type="text/javascript">
1.253 albertel 1015: // <!-- BEGIN LON-CAPA Internal
1016: // <![CDATA[
1.430 albertel 1017: var banner_link = '';
1.243 raeburn 1018: function helpMenu(target) {
1019: var caller = this;
1020: if (target == 'open') {
1021: var newWindow = null;
1022: try {
1.262 albertel 1023: newWindow = window.open($nothing,"helpmenu","HEIGHT=$height,WIDTH=$width,resizable=yes,scrollbars=yes" )
1.243 raeburn 1024: }
1025: catch(error) {
1026: writeHelp(caller);
1027: return;
1028: }
1029: if (newWindow) {
1030: caller = newWindow;
1031: }
1.193 raeburn 1032: }
1.243 raeburn 1033: writeHelp(caller);
1034: return;
1035: }
1036: function writeHelp(caller) {
1.430 albertel 1037: caller.document.writeln('$start_page<frame name="bannerframe" src="'+banner_link+'" /><frame name="bodyframe" src="$details_link" /> $end_page')
1.243 raeburn 1038: caller.document.close()
1039: caller.focus()
1.193 raeburn 1040: }
1.253 albertel 1041: // ]]>
1.219 albertel 1042: // END LON-CAPA Internal -->
1.436 albertel 1043: </script>
1.193 raeburn 1044: ENDTEMPLATE
1045: return $template;
1046: }
1047:
1.172 www 1048: sub help_open_bug {
1049: my ($topic, $text, $stayOnPage, $width, $height) = @_;
1.258 albertel 1050: unless ($env{'user.adv'}) { return ''; }
1.172 www 1051: unless ($Apache::lonnet::perlvar{'BugzillaHost'}) { return ''; }
1052: $text = "" if (not defined $text);
1053: $stayOnPage = 0 if (not defined $stayOnPage);
1.258 albertel 1054: if ($env{'browser.interface'} eq 'textual' ||
1055: $env{'environment.remote'} eq 'off' ) {
1.172 www 1056: $stayOnPage=1;
1057: }
1.184 albertel 1058: $width = 600 if (not defined $width);
1059: $height = 600 if (not defined $height);
1.172 www 1060:
1061: $topic=~s/\W+/\+/g;
1062: my $link='';
1063: my $template='';
1.379 albertel 1064: my $url=$Apache::lonnet::perlvar{'BugzillaHost'}.'enter_bug.cgi?product=LON-CAPA&bug_file_loc='.
1065: &escape($ENV{'REQUEST_URI'}).'&component='.$topic;
1.172 www 1066: if (!$stayOnPage)
1067: {
1068: $link = "javascript:void(open('$url', 'Bugzilla', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))";
1069: }
1070: else
1071: {
1072: $link = $url;
1073: }
1074: # Add the text
1075: if ($text ne "")
1076: {
1077: $template .=
1078: "<table bgcolor='#AA3333' cellspacing='1' cellpadding='1' border='0'><tr>".
1.436 albertel 1079: "<td bgcolor='#FF5555'><a target=\"_top\" href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";
1.172 www 1080: }
1081:
1082: # Add the graphic
1.179 matthew 1083: my $title = &mt('Report a Bug');
1.215 albertel 1084: my $bugicon=&lonhttpdurl("/adm/lonMisc/smallBug.gif");
1.172 www 1085: $template .= <<"ENDTEMPLATE";
1.436 albertel 1086: <a target="_top" href="$link" title="$title"><img src="$bugicon" border="0" alt="(Bug: $topic)" /></a>
1.172 www 1087: ENDTEMPLATE
1088: if ($text ne '') { $template.='</td></tr></table>' };
1089: return $template;
1090:
1091: }
1092:
1093: sub help_open_faq {
1094: my ($topic, $text, $stayOnPage, $width, $height) = @_;
1.258 albertel 1095: unless ($env{'user.adv'}) { return ''; }
1.172 www 1096: unless ($Apache::lonnet::perlvar{'FAQHost'}) { return ''; }
1097: $text = "" if (not defined $text);
1098: $stayOnPage = 0 if (not defined $stayOnPage);
1.258 albertel 1099: if ($env{'browser.interface'} eq 'textual' ||
1100: $env{'environment.remote'} eq 'off' ) {
1.172 www 1101: $stayOnPage=1;
1102: }
1103: $width = 350 if (not defined $width);
1104: $height = 400 if (not defined $height);
1105:
1106: $topic=~s/\W+/\+/g;
1107: my $link='';
1108: my $template='';
1109: my $url=$Apache::lonnet::perlvar{'FAQHost'}.'/fom/cache/'.$topic.'.html';
1110: if (!$stayOnPage)
1111: {
1112: $link = "javascript:void(open('$url', 'FAQ-O-Matic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))";
1113: }
1114: else
1115: {
1116: $link = $url;
1117: }
1118:
1119: # Add the text
1120: if ($text ne "")
1121: {
1122: $template .=
1.173 www 1123: "<table bgcolor='#337733' cellspacing='1' cellpadding='1' border='0'><tr>".
1.436 albertel 1124: "<td bgcolor='#448844'><a target=\"_top\" href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";
1.172 www 1125: }
1126:
1127: # Add the graphic
1.179 matthew 1128: my $title = &mt('View the FAQ');
1.215 albertel 1129: my $faqicon=&lonhttpdurl("/adm/lonMisc/smallFAQ.gif");
1.172 www 1130: $template .= <<"ENDTEMPLATE";
1.436 albertel 1131: <a target="_top" href="$link" title="$title"><img src="$faqicon" border="0" alt="(FAQ: $topic)" /></a>
1.172 www 1132: ENDTEMPLATE
1133: if ($text ne '') { $template.='</td></tr></table>' };
1134: return $template;
1135:
1.44 bowersj2 1136: }
1.37 matthew 1137:
1.180 matthew 1138: ###############################################################
1139: ###############################################################
1140:
1.45 matthew 1141: =pod
1142:
1.648 raeburn 1143: =item * &change_content_javascript():
1.256 matthew 1144:
1145: This and the next function allow you to create small sections of an
1146: otherwise static HTML page that you can update on the fly with
1147: Javascript, even in Netscape 4.
1148:
1149: The Javascript fragment returned by this function (no E<lt>scriptE<gt> tag)
1150: must be written to the HTML page once. It will prove the Javascript
1151: function "change(name, content)". Calling the change function with the
1152: name of the section
1153: you want to update, matching the name passed to C<changable_area>, and
1154: the new content you want to put in there, will put the content into
1155: that area.
1156:
1157: B<Note>: Netscape 4 only reserves enough space for the changable area
1158: to contain room for the original contents. You need to "make space"
1159: for whatever changes you wish to make, and be B<sure> to check your
1160: code in Netscape 4. This feature in Netscape 4 is B<not> powerful;
1161: it's adequate for updating a one-line status display, but little more.
1162: This script will set the space to 100% width, so you only need to
1163: worry about height in Netscape 4.
1164:
1165: Modern browsers are much less limiting, and if you can commit to the
1166: user not using Netscape 4, this feature may be used freely with
1167: pretty much any HTML.
1168:
1169: =cut
1170:
1171: sub change_content_javascript {
1172: # If we're on Netscape 4, we need to use Layer-based code
1.258 albertel 1173: if ($env{'browser.type'} eq 'netscape' &&
1174: $env{'browser.version'} =~ /^4\./) {
1.256 matthew 1175: return (<<NETSCAPE4);
1176: function change(name, content) {
1177: doc = document.layers[name+"___escape"].layers[0].document;
1178: doc.open();
1179: doc.write(content);
1180: doc.close();
1181: }
1182: NETSCAPE4
1183: } else {
1184: # Otherwise, we need to use semi-standards-compliant code
1185: # (technically, "innerHTML" isn't standard but the equivalent
1186: # is really scary, and every useful browser supports it
1187: return (<<DOMBASED);
1188: function change(name, content) {
1189: element = document.getElementById(name);
1190: element.innerHTML = content;
1191: }
1192: DOMBASED
1193: }
1194: }
1195:
1196: =pod
1197:
1.648 raeburn 1198: =item * &changable_area($name,$origContent):
1.256 matthew 1199:
1200: This provides a "changable area" that can be modified on the fly via
1201: the Javascript code provided in C<change_content_javascript>. $name is
1202: the name you will use to reference the area later; do not repeat the
1203: same name on a given HTML page more then once. $origContent is what
1204: the area will originally contain, which can be left blank.
1205:
1206: =cut
1207:
1208: sub changable_area {
1209: my ($name, $origContent) = @_;
1210:
1.258 albertel 1211: if ($env{'browser.type'} eq 'netscape' &&
1212: $env{'browser.version'} =~ /^4\./) {
1.256 matthew 1213: # If this is netscape 4, we need to use the Layer tag
1214: return "<ilayer width='100%' id='${name}___escape' overflow='none'><layer width='100%' id='$name' overflow='none'>$origContent</layer></ilayer>";
1215: } else {
1216: return "<span id='$name'>$origContent</span>";
1217: }
1218: }
1219:
1220: =pod
1221:
1.648 raeburn 1222: =item * &viewport_geometry_js
1.590 raeburn 1223:
1224: Provides javascript object (Geometry) which can provide information about the viewport geometry for the client browser.
1225:
1226: =cut
1227:
1228:
1229: sub viewport_geometry_js {
1230: return <<"GEOMETRY";
1231: var Geometry = {};
1232: function init_geometry() {
1233: if (Geometry.init) { return };
1234: Geometry.init=1;
1235: if (window.innerHeight) {
1236: Geometry.getViewportHeight = function() { return window.innerHeight; };
1237: Geometry.getViewportWidth = function() { return window.innerWidth; };
1238: Geometry.getHorizontalScroll = function() { return window.pageXOffset; };
1239: Geometry.getVerticalScroll = function() { return window.pageYOffset; };
1240: }
1241: else if (document.documentElement && document.documentElement.clientHeight) {
1242: Geometry.getViewportHeight =
1243: function() { return document.documentElement.clientHeight; };
1244: Geometry.getViewportWidth =
1245: function() { return document.documentElement.clientWidth; };
1246:
1247: Geometry.getHorizontalScroll =
1248: function() { return document.documentElement.scrollLeft; };
1249: Geometry.getVerticalScroll =
1250: function() { return document.documentElement.scrollTop; };
1251: }
1252: else if (document.body.clientHeight) {
1253: Geometry.getViewportHeight =
1254: function() { return document.body.clientHeight; };
1255: Geometry.getViewportWidth =
1256: function() { return document.body.clientWidth; };
1257: Geometry.getHorizontalScroll =
1258: function() { return document.body.scrollLeft; };
1259: Geometry.getVerticalScroll =
1260: function() { return document.body.scrollTop; };
1261: }
1262: }
1263:
1264: GEOMETRY
1265: }
1266:
1267: =pod
1268:
1.648 raeburn 1269: =item * &viewport_size_js()
1.590 raeburn 1270:
1271: 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.
1272:
1273: =cut
1274:
1275: sub viewport_size_js {
1276: my $geometry = &viewport_geometry_js();
1277: return <<"DIMS";
1278:
1279: $geometry
1280:
1281: function getViewportDims(width,height) {
1282: init_geometry();
1283: width.value = Geometry.getViewportWidth();
1284: height.value = Geometry.getViewportHeight();
1285: return;
1286: }
1287:
1288: DIMS
1289: }
1290:
1291: =pod
1292:
1.648 raeburn 1293: =item * &resize_textarea_js()
1.565 albertel 1294:
1295: emits the needed javascript to resize a textarea to be as big as possible
1296:
1297: creates a function resize_textrea that takes two IDs first should be
1298: the id of the element to resize, second should be the id of a div that
1299: surrounds everything that comes after the textarea, this routine needs
1300: to be attached to the <body> for the onload and onresize events.
1301:
1.648 raeburn 1302: =back
1.565 albertel 1303:
1304: =cut
1305:
1306: sub resize_textarea_js {
1.590 raeburn 1307: my $geometry = &viewport_geometry_js();
1.565 albertel 1308: return <<"RESIZE";
1309: <script type="text/javascript">
1.590 raeburn 1310: $geometry
1.565 albertel 1311:
1.588 albertel 1312: function getX(element) {
1313: var x = 0;
1314: while (element) {
1315: x += element.offsetLeft;
1316: element = element.offsetParent;
1317: }
1318: return x;
1319: }
1320: function getY(element) {
1321: var y = 0;
1322: while (element) {
1323: y += element.offsetTop;
1324: element = element.offsetParent;
1325: }
1326: return y;
1327: }
1328:
1329:
1.565 albertel 1330: function resize_textarea(textarea_id,bottom_id) {
1331: init_geometry();
1332: var textarea = document.getElementById(textarea_id);
1333: //alert(textarea);
1334:
1.588 albertel 1335: var textarea_top = getY(textarea);
1.565 albertel 1336: var textarea_height = textarea.offsetHeight;
1337: var bottom = document.getElementById(bottom_id);
1.588 albertel 1338: var bottom_top = getY(bottom);
1.565 albertel 1339: var bottom_height = bottom.offsetHeight;
1340: var window_height = Geometry.getViewportHeight();
1.588 albertel 1341: var fudge = 23;
1.565 albertel 1342: var new_height = window_height-fudge-textarea_top-bottom_height;
1343: if (new_height < 300) {
1344: new_height = 300;
1345: }
1346: textarea.style.height=new_height+'px';
1347: }
1348: </script>
1349: RESIZE
1350:
1351: }
1352:
1353: =pod
1354:
1.256 matthew 1355: =head1 Excel and CSV file utility routines
1356:
1357: =over 4
1358:
1359: =cut
1360:
1361: ###############################################################
1362: ###############################################################
1363:
1364: =pod
1365:
1.648 raeburn 1366: =item * &csv_translate($text)
1.37 matthew 1367:
1.185 www 1368: Translate $text to allow it to be output as a 'comma separated values'
1.37 matthew 1369: format.
1370:
1371: =cut
1372:
1.180 matthew 1373: ###############################################################
1374: ###############################################################
1.37 matthew 1375: sub csv_translate {
1376: my $text = shift;
1377: $text =~ s/\"/\"\"/g;
1.209 albertel 1378: $text =~ s/\n/ /g;
1.37 matthew 1379: return $text;
1380: }
1.180 matthew 1381:
1382: ###############################################################
1383: ###############################################################
1384:
1385: =pod
1386:
1.648 raeburn 1387: =item * &define_excel_formats()
1.180 matthew 1388:
1389: Define some commonly used Excel cell formats.
1390:
1391: Currently supported formats:
1392:
1393: =over 4
1394:
1395: =item header
1396:
1397: =item bold
1398:
1399: =item h1
1400:
1401: =item h2
1402:
1403: =item h3
1404:
1.256 matthew 1405: =item h4
1406:
1407: =item i
1408:
1.180 matthew 1409: =item date
1410:
1411: =back
1412:
1413: Inputs: $workbook
1414:
1415: Returns: $format, a hash reference.
1416:
1417: =cut
1418:
1419: ###############################################################
1420: ###############################################################
1421: sub define_excel_formats {
1422: my ($workbook) = @_;
1423: my $format;
1424: $format->{'header'} = $workbook->add_format(bold => 1,
1425: bottom => 1,
1426: align => 'center');
1427: $format->{'bold'} = $workbook->add_format(bold=>1);
1428: $format->{'h1'} = $workbook->add_format(bold=>1, size=>18);
1429: $format->{'h2'} = $workbook->add_format(bold=>1, size=>16);
1430: $format->{'h3'} = $workbook->add_format(bold=>1, size=>14);
1.255 matthew 1431: $format->{'h4'} = $workbook->add_format(bold=>1, size=>12);
1.246 matthew 1432: $format->{'i'} = $workbook->add_format(italic=>1);
1.180 matthew 1433: $format->{'date'} = $workbook->add_format(num_format=>
1.207 matthew 1434: 'mm/dd/yyyy hh:mm:ss');
1.180 matthew 1435: return $format;
1436: }
1437:
1438: ###############################################################
1439: ###############################################################
1.113 bowersj2 1440:
1441: =pod
1442:
1.648 raeburn 1443: =item * &create_workbook()
1.255 matthew 1444:
1445: Create an Excel worksheet. If it fails, output message on the
1446: request object and return undefs.
1447:
1448: Inputs: Apache request object
1449:
1450: Returns (undef) on failure,
1451: Excel worksheet object, scalar with filename, and formats
1452: from &Apache::loncommon::define_excel_formats on success
1453:
1454: =cut
1455:
1456: ###############################################################
1457: ###############################################################
1458: sub create_workbook {
1459: my ($r) = @_;
1460: #
1461: # Create the excel spreadsheet
1462: my $filename = '/prtspool/'.
1.258 albertel 1463: $env{'user.name'}.'_'.$env{'user.domain'}.'_'.
1.255 matthew 1464: time.'_'.rand(1000000000).'.xls';
1465: my $workbook = Spreadsheet::WriteExcel->new('/home/httpd'.$filename);
1466: if (! defined($workbook)) {
1467: $r->log_error("Error creating excel spreadsheet $filename: $!");
1468: $r->print('<p>'.&mt("Unable to create new Excel file. ".
1469: "This error has been logged. ".
1470: "Please alert your LON-CAPA administrator").
1471: '</p>');
1472: return (undef);
1473: }
1474: #
1475: $workbook->set_tempdir('/home/httpd/perl/tmp');
1476: #
1477: my $format = &Apache::loncommon::define_excel_formats($workbook);
1478: return ($workbook,$filename,$format);
1479: }
1480:
1481: ###############################################################
1482: ###############################################################
1483:
1484: =pod
1485:
1.648 raeburn 1486: =item * &create_text_file()
1.113 bowersj2 1487:
1.542 raeburn 1488: Create a file to write to and eventually make available to the user.
1.256 matthew 1489: If file creation fails, outputs an error message on the request object and
1490: return undefs.
1.113 bowersj2 1491:
1.256 matthew 1492: Inputs: Apache request object, and file suffix
1.113 bowersj2 1493:
1.256 matthew 1494: Returns (undef) on failure,
1495: Filehandle and filename on success.
1.113 bowersj2 1496:
1497: =cut
1498:
1.256 matthew 1499: ###############################################################
1500: ###############################################################
1501: sub create_text_file {
1502: my ($r,$suffix) = @_;
1503: if (! defined($suffix)) { $suffix = 'txt'; };
1504: my $fh;
1505: my $filename = '/prtspool/'.
1.258 albertel 1506: $env{'user.name'}.'_'.$env{'user.domain'}.'_'.
1.256 matthew 1507: time.'_'.rand(1000000000).'.'.$suffix;
1508: $fh = Apache::File->new('>/home/httpd'.$filename);
1509: if (! defined($fh)) {
1510: $r->log_error("Couldn't open $filename for output $!");
1.683 bisitz 1511: $r->print(&mt('Problems occurred in creating the output file. '
1512: .'This error has been logged. '
1513: .'Please alert your LON-CAPA administrator.'));
1.113 bowersj2 1514: }
1.256 matthew 1515: return ($fh,$filename)
1.113 bowersj2 1516: }
1517:
1518:
1.256 matthew 1519: =pod
1.113 bowersj2 1520:
1521: =back
1522:
1523: =cut
1.37 matthew 1524:
1525: ###############################################################
1.33 matthew 1526: ## Home server <option> list generating code ##
1527: ###############################################################
1.35 matthew 1528:
1.169 www 1529: # ------------------------------------------
1530:
1531: sub domain_select {
1532: my ($name,$value,$multiple)=@_;
1533: my %domains=map {
1.514 albertel 1534: $_ => $_.' '. &Apache::lonnet::domain($_,'description')
1.512 albertel 1535: } &Apache::lonnet::all_domains();
1.169 www 1536: if ($multiple) {
1537: $domains{''}=&mt('Any domain');
1.550 albertel 1538: $domains{'select_form_order'} = [sort {lc($a) cmp lc($b) } (keys(%domains))];
1.287 albertel 1539: return &multiple_select_form($name,$value,4,\%domains);
1.169 www 1540: } else {
1.550 albertel 1541: $domains{'select_form_order'} = [sort {lc($a) cmp lc($b) } (keys(%domains))];
1.169 www 1542: return &select_form($name,$value,%domains);
1543: }
1544: }
1545:
1.282 albertel 1546: #-------------------------------------------
1547:
1548: =pod
1549:
1.519 raeburn 1550: =head1 Routines for form select boxes
1551:
1552: =over 4
1553:
1.648 raeburn 1554: =item * &multiple_select_form($name,$value,$size,$hash,$order)
1.282 albertel 1555:
1556: Returns a string containing a <select> element int multiple mode
1557:
1558:
1559: Args:
1560: $name - name of the <select> element
1.506 raeburn 1561: $value - scalar or array ref of values that should already be selected
1.282 albertel 1562: $size - number of rows long the select element is
1.283 albertel 1563: $hash - the elements should be 'option' => 'shown text'
1.282 albertel 1564: (shown text should already have been &mt())
1.506 raeburn 1565: $order - (optional) array ref of the order to show the elements in
1.283 albertel 1566:
1.282 albertel 1567: =cut
1568:
1569: #-------------------------------------------
1.169 www 1570: sub multiple_select_form {
1.284 albertel 1571: my ($name,$value,$size,$hash,$order)=@_;
1.169 www 1572: my %selected = map { $_ => 1 } ref($value)?@{$value}:($value);
1573: my $output='';
1.191 matthew 1574: if (! defined($size)) {
1575: $size = 4;
1.283 albertel 1576: if (scalar(keys(%$hash))<4) {
1577: $size = scalar(keys(%$hash));
1.191 matthew 1578: }
1579: }
1.169 www 1580: $output.="\n<select name='$name' size='$size' multiple='1'>";
1.501 banghart 1581: my @order;
1.506 raeburn 1582: if (ref($order) eq 'ARRAY') {
1583: @order = @{$order};
1584: } else {
1585: @order = sort(keys(%$hash));
1.501 banghart 1586: }
1587: if (exists($$hash{'select_form_order'})) {
1588: @order = @{$$hash{'select_form_order'}};
1589: }
1590:
1.284 albertel 1591: foreach my $key (@order) {
1.356 albertel 1592: $output.='<option value="'.&HTML::Entities::encode($key,'"<>&').'" ';
1.284 albertel 1593: $output.='selected="selected" ' if ($selected{$key});
1594: $output.='>'.$hash->{$key}."</option>\n";
1.169 www 1595: }
1596: $output.="</select>\n";
1597: return $output;
1598: }
1599:
1.88 www 1600: #-------------------------------------------
1601:
1602: =pod
1603:
1.648 raeburn 1604: =item * &select_form($defdom,$name,%hash)
1.88 www 1605:
1606: Returns a string containing a <select name='$name' size='1'> form to
1607: allow a user to select options from a hash option_name => displayed text.
1608: See lonrights.pm for an example invocation and use.
1609:
1610: =cut
1611:
1612: #-------------------------------------------
1613: sub select_form {
1614: my ($def,$name,%hash) = @_;
1615: my $selectform = "<select name=\"$name\" size=\"1\">\n";
1.128 albertel 1616: my @keys;
1617: if (exists($hash{'select_form_order'})) {
1618: @keys=@{$hash{'select_form_order'}};
1619: } else {
1620: @keys=sort(keys(%hash));
1621: }
1.356 albertel 1622: foreach my $key (@keys) {
1623: $selectform.=
1624: '<option value="'.&HTML::Entities::encode($key,'"<>&').'" '.
1625: ($key eq $def ? 'selected="selected" ' : '').
1626: ">".&mt($hash{$key})."</option>\n";
1.88 www 1627: }
1628: $selectform.="</select>";
1629: return $selectform;
1630: }
1631:
1.475 www 1632: # For display filters
1633:
1634: sub display_filter {
1635: if (!$env{'form.show'}) { $env{'form.show'}=10; }
1.477 www 1636: if (!$env{'form.displayfilter'}) { $env{'form.displayfilter'}='currentfolder'; }
1.475 www 1637: return '<nobr><label>'.&mt('Records [_1]',
1638: &Apache::lonmeta::selectbox('show',$env{'form.show'},undef,
1639: (&mt('all'),10,20,50,100,1000,10000))).
1.478 www 1640: '</label></nobr> <nobr>'.
1.475 www 1641: &mt('Filter [_1]',
1.477 www 1642: &select_form($env{'form.displayfilter'},
1643: 'displayfilter',
1644: ('currentfolder' => 'Current folder/page',
1645: 'containing' => 'Containing phrase',
1646: 'none' => 'None'))).
1.478 www 1647: '<input type="text" name="containingphrase" size="30" value="'.&HTML::Entities::encode($env{'form.containingphrase'}).'" /></nobr>';
1.475 www 1648: }
1649:
1.167 www 1650: sub gradeleveldescription {
1651: my $gradelevel=shift;
1652: my %gradelevels=(0 => 'Not specified',
1653: 1 => 'Grade 1',
1654: 2 => 'Grade 2',
1655: 3 => 'Grade 3',
1656: 4 => 'Grade 4',
1657: 5 => 'Grade 5',
1658: 6 => 'Grade 6',
1659: 7 => 'Grade 7',
1660: 8 => 'Grade 8',
1661: 9 => 'Grade 9',
1662: 10 => 'Grade 10',
1663: 11 => 'Grade 11',
1664: 12 => 'Grade 12',
1665: 13 => 'Grade 13',
1666: 14 => '100 Level',
1667: 15 => '200 Level',
1668: 16 => '300 Level',
1669: 17 => '400 Level',
1670: 18 => 'Graduate Level');
1671: return &mt($gradelevels{$gradelevel});
1672: }
1673:
1.163 www 1674: sub select_level_form {
1675: my ($deflevel,$name)=@_;
1676: unless ($deflevel) { $deflevel=0; }
1.167 www 1677: my $selectform = "<select name=\"$name\" size=\"1\">\n";
1678: for (my $i=0; $i<=18; $i++) {
1679: $selectform.="<option value=\"$i\" ".
1.253 albertel 1680: ($i==$deflevel ? 'selected="selected" ' : '').
1.167 www 1681: ">".&gradeleveldescription($i)."</option>\n";
1682: }
1683: $selectform.="</select>";
1684: return $selectform;
1.163 www 1685: }
1.167 www 1686:
1.35 matthew 1687: #-------------------------------------------
1688:
1.45 matthew 1689: =pod
1690:
1.648 raeburn 1691: =item * &select_dom_form($defdom,$name,$includeempty,$showdomdesc)
1.35 matthew 1692:
1693: Returns a string containing a <select name='$name' size='1'> form to
1694: allow a user to select the domain to preform an operation in.
1695: See loncreateuser.pm for an example invocation and use.
1696:
1.90 www 1697: If the $includeempty flag is set, it also includes an empty choice ("no domain
1698: selected");
1699:
1.563 raeburn 1700: If the $showdomdesc flag is set, the domain name is followed by the domain description.
1701:
1.35 matthew 1702: =cut
1703:
1704: #-------------------------------------------
1.34 matthew 1705: sub select_dom_form {
1.563 raeburn 1706: my ($defdom,$name,$includeempty,$showdomdesc) = @_;
1.550 albertel 1707: my @domains = sort {lc($a) cmp lc($b)} (&Apache::lonnet::all_domains());
1.90 www 1708: if ($includeempty) { @domains=('',@domains); }
1.34 matthew 1709: my $selectdomain = "<select name=\"$name\" size=\"1\">\n";
1.356 albertel 1710: foreach my $dom (@domains) {
1711: $selectdomain.="<option value=\"$dom\" ".
1.563 raeburn 1712: ($dom eq $defdom ? 'selected="selected" ' : '').'>'.$dom;
1713: if ($showdomdesc) {
1714: if ($dom ne '') {
1715: my $domdesc = &Apache::lonnet::domain($dom,'description');
1716: if ($domdesc ne '') {
1717: $selectdomain .= ' ('.$domdesc.')';
1718: }
1719: }
1720: }
1721: $selectdomain .= "</option>\n";
1.34 matthew 1722: }
1723: $selectdomain.="</select>";
1724: return $selectdomain;
1725: }
1726:
1.35 matthew 1727: #-------------------------------------------
1728:
1.45 matthew 1729: =pod
1730:
1.648 raeburn 1731: =item * &home_server_form_item($domain,$name,$defaultflag)
1.35 matthew 1732:
1.586 raeburn 1733: input: 4 arguments (two required, two optional) -
1734: $domain - domain of new user
1735: $name - name of form element
1736: $default - Value of 'default' causes a default item to be first
1737: option, and selected by default.
1738: $hide - Value of 'hide' causes hiding of the name of the server,
1739: if 1 server found, or default, if 0 found.
1.594 raeburn 1740: output: returns 2 items:
1.586 raeburn 1741: (a) form element which contains either:
1742: (i) <select name="$name">
1743: <option value="$hostid1">$hostid $servers{$hostid}</option>
1744: <option value="$hostid2">$hostid $servers{$hostid}</option>
1745: </select>
1746: form item if there are multiple library servers in $domain, or
1747: (ii) an <input type="hidden" name="$name" value="$hostid" /> form item
1748: if there is only one library server in $domain.
1749:
1750: (b) number of library servers found.
1751:
1752: See loncreateuser.pm for example of use.
1.35 matthew 1753:
1754: =cut
1755:
1756: #-------------------------------------------
1.586 raeburn 1757: sub home_server_form_item {
1758: my ($domain,$name,$default,$hide) = @_;
1.513 albertel 1759: my %servers = &Apache::lonnet::get_servers($domain,'library');
1.586 raeburn 1760: my $result;
1761: my $numlib = keys(%servers);
1762: if ($numlib > 1) {
1763: $result .= '<select name="'.$name.'" />'."\n";
1764: if ($default) {
1765: $result .= '<option value="default" selected>'.&mt('default').
1766: '</option>'."\n";
1767: }
1768: foreach my $hostid (sort(keys(%servers))) {
1769: $result.= '<option value="'.$hostid.'">'.
1770: $hostid.' '.$servers{$hostid}."</option>\n";
1771: }
1772: $result .= '</select>'."\n";
1773: } elsif ($numlib == 1) {
1774: my $hostid;
1775: foreach my $item (keys(%servers)) {
1776: $hostid = $item;
1777: }
1778: $result .= '<input type="hidden" name="'.$name.'" value="'.
1779: $hostid.'" />';
1780: if (!$hide) {
1781: $result .= $hostid.' '.$servers{$hostid};
1782: }
1783: $result .= "\n";
1784: } elsif ($default) {
1785: $result .= '<input type="hidden" name="'.$name.
1786: '" value="default" />';
1787: if (!$hide) {
1788: $result .= &mt('default');
1789: }
1790: $result .= "\n";
1.33 matthew 1791: }
1.586 raeburn 1792: return ($result,$numlib);
1.33 matthew 1793: }
1.112 bowersj2 1794:
1795: =pod
1796:
1.534 albertel 1797: =back
1798:
1.112 bowersj2 1799: =cut
1.87 matthew 1800:
1801: ###############################################################
1.112 bowersj2 1802: ## Decoding User Agent ##
1.87 matthew 1803: ###############################################################
1804:
1805: =pod
1806:
1.112 bowersj2 1807: =head1 Decoding the User Agent
1808:
1809: =over 4
1810:
1811: =item * &decode_user_agent()
1.87 matthew 1812:
1813: Inputs: $r
1814:
1815: Outputs:
1816:
1817: =over 4
1818:
1.112 bowersj2 1819: =item * $httpbrowser
1.87 matthew 1820:
1.112 bowersj2 1821: =item * $clientbrowser
1.87 matthew 1822:
1.112 bowersj2 1823: =item * $clientversion
1.87 matthew 1824:
1.112 bowersj2 1825: =item * $clientmathml
1.87 matthew 1826:
1.112 bowersj2 1827: =item * $clientunicode
1.87 matthew 1828:
1.112 bowersj2 1829: =item * $clientos
1.87 matthew 1830:
1831: =back
1832:
1.157 matthew 1833: =back
1834:
1.87 matthew 1835: =cut
1836:
1837: ###############################################################
1838: ###############################################################
1839: sub decode_user_agent {
1.247 albertel 1840: my ($r)=@_;
1.87 matthew 1841: my @browsertype=split(/\&/,$Apache::lonnet::perlvar{"lonBrowsDet"});
1842: my %mathcap=split(/\&/,$$Apache::lonnet::perlvar{"lonMathML"});
1843: my $httpbrowser=$ENV{"HTTP_USER_AGENT"};
1.247 albertel 1844: if (!$httpbrowser && $r) { $httpbrowser=$r->header_in('User-Agent'); }
1.87 matthew 1845: my $clientbrowser='unknown';
1846: my $clientversion='0';
1847: my $clientmathml='';
1848: my $clientunicode='0';
1849: for (my $i=0;$i<=$#browsertype;$i++) {
1850: my ($bname,$match,$notmatch,$vreg,$minv,$univ)=split(/\:/,$browsertype[$i]);
1851: if (($httpbrowser=~/$match/i) && ($httpbrowser!~/$notmatch/i)) {
1852: $clientbrowser=$bname;
1853: $httpbrowser=~/$vreg/i;
1854: $clientversion=$1;
1855: $clientmathml=($clientversion>=$minv);
1856: $clientunicode=($clientversion>=$univ);
1857: }
1858: }
1859: my $clientos='unknown';
1860: if (($httpbrowser=~/linux/i) ||
1861: ($httpbrowser=~/unix/i) ||
1862: ($httpbrowser=~/ux/i) ||
1863: ($httpbrowser=~/solaris/i)) { $clientos='unix'; }
1864: if (($httpbrowser=~/vax/i) ||
1865: ($httpbrowser=~/vms/i)) { $clientos='vms'; }
1866: if ($httpbrowser=~/next/i) { $clientos='next'; }
1867: if (($httpbrowser=~/mac/i) ||
1868: ($httpbrowser=~/powerpc/i)) { $clientos='mac'; }
1869: if ($httpbrowser=~/win/i) { $clientos='win'; }
1870: if ($httpbrowser=~/embed/i) { $clientos='pda'; }
1871: return ($httpbrowser,$clientbrowser,$clientversion,$clientmathml,
1872: $clientunicode,$clientos,);
1873: }
1874:
1.32 matthew 1875: ###############################################################
1876: ## Authentication changing form generation subroutines ##
1877: ###############################################################
1878: ##
1879: ## All of the authform_xxxxxxx subroutines take their inputs in a
1880: ## hash, and have reasonable default values.
1881: ##
1882: ## formname = the name given in the <form> tag.
1.35 matthew 1883: #-------------------------------------------
1884:
1.45 matthew 1885: =pod
1886:
1.112 bowersj2 1887: =head1 Authentication Routines
1888:
1889: =over 4
1890:
1.648 raeburn 1891: =item * &authform_xxxxxx()
1.35 matthew 1892:
1893: The authform_xxxxxx subroutines provide javascript and html forms which
1894: handle some of the conveniences required for authentication forms.
1895: This is not an optimal method, but it works.
1896:
1897: =over 4
1898:
1.112 bowersj2 1899: =item * authform_header
1.35 matthew 1900:
1.112 bowersj2 1901: =item * authform_authorwarning
1.35 matthew 1902:
1.112 bowersj2 1903: =item * authform_nochange
1.35 matthew 1904:
1.112 bowersj2 1905: =item * authform_kerberos
1.35 matthew 1906:
1.112 bowersj2 1907: =item * authform_internal
1.35 matthew 1908:
1.112 bowersj2 1909: =item * authform_filesystem
1.35 matthew 1910:
1911: =back
1912:
1.648 raeburn 1913: See loncreateuser.pm for invocation and use examples.
1.157 matthew 1914:
1.35 matthew 1915: =cut
1916:
1917: #-------------------------------------------
1.32 matthew 1918: sub authform_header{
1919: my %in = (
1920: formname => 'cu',
1.80 albertel 1921: kerb_def_dom => '',
1.32 matthew 1922: @_,
1923: );
1924: $in{'formname'} = 'document.' . $in{'formname'};
1925: my $result='';
1.80 albertel 1926:
1927: #---------------------------------------------- Code for upper case translation
1928: my $Javascript_toUpperCase;
1929: unless ($in{kerb_def_dom}) {
1930: $Javascript_toUpperCase =<<"END";
1931: switch (choice) {
1932: case 'krb': currentform.elements[choicearg].value =
1933: currentform.elements[choicearg].value.toUpperCase();
1934: break;
1935: default:
1936: }
1937: END
1938: } else {
1939: $Javascript_toUpperCase = "";
1940: }
1941:
1.165 raeburn 1942: my $radioval = "'nochange'";
1.591 raeburn 1943: if (defined($in{'curr_authtype'})) {
1944: if ($in{'curr_authtype'} ne '') {
1945: $radioval = "'".$in{'curr_authtype'}."arg'";
1946: }
1.174 matthew 1947: }
1.165 raeburn 1948: my $argfield = 'null';
1.591 raeburn 1949: if (defined($in{'mode'})) {
1.165 raeburn 1950: if ($in{'mode'} eq 'modifycourse') {
1.591 raeburn 1951: if (defined($in{'curr_autharg'})) {
1952: if ($in{'curr_autharg'} ne '') {
1.165 raeburn 1953: $argfield = "'$in{'curr_autharg'}'";
1954: }
1955: }
1956: }
1957: }
1958:
1.32 matthew 1959: $result.=<<"END";
1960: var current = new Object();
1.165 raeburn 1961: current.radiovalue = $radioval;
1962: current.argfield = $argfield;
1.32 matthew 1963:
1964: function changed_radio(choice,currentform) {
1965: var choicearg = choice + 'arg';
1966: // If a radio button in changed, we need to change the argfield
1967: if (current.radiovalue != choice) {
1968: current.radiovalue = choice;
1969: if (current.argfield != null) {
1970: currentform.elements[current.argfield].value = '';
1971: }
1972: if (choice == 'nochange') {
1973: current.argfield = null;
1974: } else {
1975: current.argfield = choicearg;
1976: switch(choice) {
1977: case 'krb':
1978: currentform.elements[current.argfield].value =
1979: "$in{'kerb_def_dom'}";
1980: break;
1981: default:
1982: break;
1983: }
1984: }
1985: }
1986: return;
1987: }
1.22 www 1988:
1.32 matthew 1989: function changed_text(choice,currentform) {
1990: var choicearg = choice + 'arg';
1991: if (currentform.elements[choicearg].value !='') {
1.80 albertel 1992: $Javascript_toUpperCase
1.32 matthew 1993: // clear old field
1994: if ((current.argfield != choicearg) && (current.argfield != null)) {
1995: currentform.elements[current.argfield].value = '';
1996: }
1997: current.argfield = choicearg;
1998: }
1999: set_auth_radio_buttons(choice,currentform);
2000: return;
1.20 www 2001: }
1.32 matthew 2002:
2003: function set_auth_radio_buttons(newvalue,currentform) {
2004: var i=0;
2005: while (i < currentform.login.length) {
2006: if (currentform.login[i].value == newvalue) { break; }
2007: i++;
2008: }
2009: if (i == currentform.login.length) {
2010: return;
2011: }
2012: current.radiovalue = newvalue;
2013: currentform.login[i].checked = true;
2014: return;
2015: }
2016: END
2017: return $result;
2018: }
2019:
2020: sub authform_authorwarning{
2021: my $result='';
1.144 matthew 2022: $result='<i>'.
2023: &mt('As a general rule, only authors or co-authors should be '.
2024: 'filesystem authenticated '.
2025: '(which allows access to the server filesystem).')."</i>\n";
1.32 matthew 2026: return $result;
2027: }
2028:
2029: sub authform_nochange{
2030: my %in = (
2031: formname => 'document.cu',
2032: kerb_def_dom => 'MSU.EDU',
2033: @_,
2034: );
1.586 raeburn 2035: my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'});
2036: my $result;
2037: if (keys(%can_assign) == 0) {
2038: $result = &mt('Under you current role you are not permitted to change login settings for this user');
2039: } else {
2040: $result = '<label>'.&mt('[_1] Do not change login data',
2041: '<input type="radio" name="login" value="nochange" '.
2042: 'checked="checked" onclick="'.
1.281 albertel 2043: "javascript:changed_radio('nochange',$in{'formname'});".'" />').
2044: '</label>';
1.586 raeburn 2045: }
1.32 matthew 2046: return $result;
2047: }
2048:
1.591 raeburn 2049: sub authform_kerberos {
1.32 matthew 2050: my %in = (
2051: formname => 'document.cu',
2052: kerb_def_dom => 'MSU.EDU',
1.80 albertel 2053: kerb_def_auth => 'krb4',
1.32 matthew 2054: @_,
2055: );
1.586 raeburn 2056: my ($check4,$check5,$krbcheck,$krbarg,$krbver,$result,$authtype,
2057: $autharg,$jscall);
2058: my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'});
1.80 albertel 2059: if ($in{'kerb_def_auth'} eq 'krb5') {
1.586 raeburn 2060: $check5 = ' checked="on"';
1.80 albertel 2061: } else {
1.586 raeburn 2062: $check4 = ' checked="on"';
1.80 albertel 2063: }
1.165 raeburn 2064: $krbarg = $in{'kerb_def_dom'};
1.591 raeburn 2065: if (defined($in{'curr_authtype'})) {
2066: if ($in{'curr_authtype'} eq 'krb') {
1.586 raeburn 2067: $krbcheck = ' checked="on"';
1.623 raeburn 2068: if (defined($in{'mode'})) {
2069: if ($in{'mode'} eq 'modifyuser') {
2070: $krbcheck = '';
2071: }
2072: }
1.591 raeburn 2073: if (defined($in{'curr_kerb_ver'})) {
2074: if ($in{'curr_krb_ver'} eq '5') {
2075: $check5 = ' checked="on"';
2076: $check4 = '';
2077: } else {
2078: $check4 = ' checked="on"';
2079: $check5 = '';
2080: }
1.586 raeburn 2081: }
1.591 raeburn 2082: if (defined($in{'curr_autharg'})) {
1.165 raeburn 2083: $krbarg = $in{'curr_autharg'};
2084: }
1.586 raeburn 2085: if (!$can_assign{'krb4'} && !$can_assign{'krb5'}) {
1.591 raeburn 2086: if (defined($in{'curr_autharg'})) {
1.586 raeburn 2087: $result =
2088: &mt('Currently Kerberos authenticated with domain [_1] Version [_2].',
2089: $in{'curr_autharg'},$krbver);
2090: } else {
2091: $result =
2092: &mt('Currently Kerberos authenticated, Version [_1].',$krbver);
2093: }
2094: return $result;
2095: }
2096: }
2097: } else {
2098: if ($authnum == 1) {
2099: $authtype = '<input type="hidden" name="login" value="krb">';
1.165 raeburn 2100: }
2101: }
1.586 raeburn 2102: if (!$can_assign{'krb4'} && !$can_assign{'krb5'}) {
2103: return;
1.587 raeburn 2104: } elsif ($authtype eq '') {
1.591 raeburn 2105: if (defined($in{'mode'})) {
1.587 raeburn 2106: if ($in{'mode'} eq 'modifycourse') {
2107: if ($authnum == 1) {
2108: $authtype = '<input type="hidden" name="login" value="krb">';
2109: }
2110: }
2111: }
1.586 raeburn 2112: }
2113: $jscall = "javascript:changed_radio('krb',$in{'formname'});";
2114: if ($authtype eq '') {
2115: $authtype = '<input type="radio" name="login" value="krb" '.
2116: 'onclick="'.$jscall.'" onchange="'.$jscall.'"'.
2117: $krbcheck.' />';
2118: }
2119: if (($can_assign{'krb4'} && $can_assign{'krb5'}) ||
2120: ($can_assign{'krb4'} && !$can_assign{'krb5'} &&
2121: $in{'curr_authtype'} eq 'krb5') ||
2122: (!$can_assign{'krb4'} && $can_assign{'krb5'} &&
2123: $in{'curr_authtype'} eq 'krb4')) {
2124: $result .= &mt
1.144 matthew 2125: ('[_1] Kerberos authenticated with domain [_2] '.
1.281 albertel 2126: '[_3] Version 4 [_4] Version 5 [_5]',
1.586 raeburn 2127: '<label>'.$authtype,
1.281 albertel 2128: '</label><input type="text" size="10" name="krbarg" '.
1.165 raeburn 2129: 'value="'.$krbarg.'" '.
1.144 matthew 2130: 'onchange="'.$jscall.'" />',
1.281 albertel 2131: '<label><input type="radio" name="krbver" value="4" '.$check4.' />',
2132: '</label><label><input type="radio" name="krbver" value="5" '.$check5.' />',
2133: '</label>');
1.586 raeburn 2134: } elsif ($can_assign{'krb4'}) {
2135: $result .= &mt
2136: ('[_1] Kerberos authenticated with domain [_2] '.
2137: '[_3] Version 4 [_4]',
2138: '<label>'.$authtype,
2139: '</label><input type="text" size="10" name="krbarg" '.
2140: 'value="'.$krbarg.'" '.
2141: 'onchange="'.$jscall.'" />',
2142: '<label><input type="hidden" name="krbver" value="4" />',
2143: '</label>');
2144: } elsif ($can_assign{'krb5'}) {
2145: $result .= &mt
2146: ('[_1] Kerberos authenticated with domain [_2] '.
2147: '[_3] Version 5 [_4]',
2148: '<label>'.$authtype,
2149: '</label><input type="text" size="10" name="krbarg" '.
2150: 'value="'.$krbarg.'" '.
2151: 'onchange="'.$jscall.'" />',
2152: '<label><input type="hidden" name="krbver" value="5" />',
2153: '</label>');
2154: }
1.32 matthew 2155: return $result;
2156: }
2157:
2158: sub authform_internal{
1.586 raeburn 2159: my %in = (
1.32 matthew 2160: formname => 'document.cu',
2161: kerb_def_dom => 'MSU.EDU',
2162: @_,
2163: );
1.586 raeburn 2164: my ($intcheck,$intarg,$result,$authtype,$autharg,$jscall);
2165: my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'});
1.591 raeburn 2166: if (defined($in{'curr_authtype'})) {
2167: if ($in{'curr_authtype'} eq 'int') {
1.586 raeburn 2168: if ($can_assign{'int'}) {
2169: $intcheck = 'checked="on" ';
1.623 raeburn 2170: if (defined($in{'mode'})) {
2171: if ($in{'mode'} eq 'modifyuser') {
2172: $intcheck = '';
2173: }
2174: }
1.591 raeburn 2175: if (defined($in{'curr_autharg'})) {
1.586 raeburn 2176: $intarg = $in{'curr_autharg'};
2177: }
2178: } else {
2179: $result = &mt('Currently internally authenticated.');
2180: return $result;
1.165 raeburn 2181: }
2182: }
1.586 raeburn 2183: } else {
2184: if ($authnum == 1) {
2185: $authtype = '<input type="hidden" name="login" value="int">';
2186: }
2187: }
2188: if (!$can_assign{'int'}) {
2189: return;
1.587 raeburn 2190: } elsif ($authtype eq '') {
1.591 raeburn 2191: if (defined($in{'mode'})) {
1.587 raeburn 2192: if ($in{'mode'} eq 'modifycourse') {
2193: if ($authnum == 1) {
2194: $authtype = '<input type="hidden" name="login" value="int">';
2195: }
2196: }
2197: }
1.165 raeburn 2198: }
1.586 raeburn 2199: $jscall = "javascript:changed_radio('int',$in{'formname'});";
2200: if ($authtype eq '') {
2201: $authtype = '<input type="radio" name="login" value="int" '.$intcheck.
2202: ' onchange="'.$jscall.'" onclick="'.$jscall.'" />';
2203: }
1.605 bisitz 2204: $autharg = '<input type="password" size="10" name="intarg" value="'.
1.586 raeburn 2205: $intarg.'" onchange="'.$jscall.'" />';
2206: $result = &mt
1.144 matthew 2207: ('[_1] Internally authenticated (with initial password [_2])',
1.586 raeburn 2208: '<label>'.$authtype,'</label>'.$autharg);
1.620 www 2209: $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 2210: return $result;
2211: }
2212:
2213: sub authform_local{
2214: my %in = (
2215: formname => 'document.cu',
2216: kerb_def_dom => 'MSU.EDU',
2217: @_,
2218: );
1.586 raeburn 2219: my ($loccheck,$locarg,$result,$authtype,$autharg,$jscall);
2220: my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'});
1.591 raeburn 2221: if (defined($in{'curr_authtype'})) {
2222: if ($in{'curr_authtype'} eq 'loc') {
1.586 raeburn 2223: if ($can_assign{'loc'}) {
2224: $loccheck = 'checked="on" ';
1.623 raeburn 2225: if (defined($in{'mode'})) {
2226: if ($in{'mode'} eq 'modifyuser') {
2227: $loccheck = '';
2228: }
2229: }
1.591 raeburn 2230: if (defined($in{'curr_autharg'})) {
1.586 raeburn 2231: $locarg = $in{'curr_autharg'};
2232: }
2233: } else {
2234: $result = &mt('Currently using local (institutional) authentication.');
2235: return $result;
1.165 raeburn 2236: }
2237: }
1.586 raeburn 2238: } else {
2239: if ($authnum == 1) {
2240: $authtype = '<input type="hidden" name="login" value="loc">';
2241: }
2242: }
2243: if (!$can_assign{'loc'}) {
2244: return;
1.587 raeburn 2245: } elsif ($authtype eq '') {
1.591 raeburn 2246: if (defined($in{'mode'})) {
1.587 raeburn 2247: if ($in{'mode'} eq 'modifycourse') {
2248: if ($authnum == 1) {
2249: $authtype = '<input type="hidden" name="login" value="loc">';
2250: }
2251: }
2252: }
1.165 raeburn 2253: }
1.586 raeburn 2254: $jscall = "javascript:changed_radio('loc',$in{'formname'});";
2255: if ($authtype eq '') {
2256: $authtype = '<input type="radio" name="login" value="loc" '.
2257: $loccheck.' onchange="'.$jscall.'" onclick="'.
2258: $jscall.'" />';
2259: }
2260: $autharg = '<input type="text" size="10" name="locarg" value="'.
2261: $locarg.'" onchange="'.$jscall.'" />';
2262: $result = &mt('[_1] Local Authentication with argument [_2]',
2263: '<label>'.$authtype,'</label>'.$autharg);
1.32 matthew 2264: return $result;
2265: }
2266:
2267: sub authform_filesystem{
2268: my %in = (
2269: formname => 'document.cu',
2270: kerb_def_dom => 'MSU.EDU',
2271: @_,
2272: );
1.586 raeburn 2273: my ($fsyscheck,$result,$authtype,$autharg,$jscall);
2274: my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'});
1.591 raeburn 2275: if (defined($in{'curr_authtype'})) {
2276: if ($in{'curr_authtype'} eq 'fsys') {
1.586 raeburn 2277: if ($can_assign{'fsys'}) {
2278: $fsyscheck = 'checked="on" ';
1.623 raeburn 2279: if (defined($in{'mode'})) {
2280: if ($in{'mode'} eq 'modifyuser') {
2281: $fsyscheck = '';
2282: }
2283: }
1.586 raeburn 2284: } else {
2285: $result = &mt('Currently Filesystem Authenticated.');
2286: return $result;
2287: }
2288: }
2289: } else {
2290: if ($authnum == 1) {
2291: $authtype = '<input type="hidden" name="login" value="fsys">';
2292: }
2293: }
2294: if (!$can_assign{'fsys'}) {
2295: return;
1.587 raeburn 2296: } elsif ($authtype eq '') {
1.591 raeburn 2297: if (defined($in{'mode'})) {
1.587 raeburn 2298: if ($in{'mode'} eq 'modifycourse') {
2299: if ($authnum == 1) {
2300: $authtype = '<input type="hidden" name="login" value="fsys">';
2301: }
2302: }
2303: }
1.586 raeburn 2304: }
2305: $jscall = "javascript:changed_radio('fsys',$in{'formname'});";
2306: if ($authtype eq '') {
2307: $authtype = '<input type="radio" name="login" value="fsys" '.
2308: $fsyscheck.' onchange="'.$jscall.'" onclick="'.
2309: $jscall.'" />';
2310: }
2311: $autharg = '<input type="text" size="10" name="fsysarg" value=""'.
2312: ' onchange="'.$jscall.'" />';
2313: $result = &mt
1.144 matthew 2314: ('[_1] Filesystem Authenticated (with initial password [_2])',
1.281 albertel 2315: '<label><input type="radio" name="login" value="fsys" '.
1.586 raeburn 2316: $fsyscheck.'onchange="'.$jscall.'" onclick="'.$jscall.'" />',
1.605 bisitz 2317: '</label><input type="password" size="10" name="fsysarg" value="" '.
1.144 matthew 2318: 'onchange="'.$jscall.'" />');
1.32 matthew 2319: return $result;
2320: }
2321:
1.586 raeburn 2322: sub get_assignable_auth {
2323: my ($dom) = @_;
2324: if ($dom eq '') {
2325: $dom = $env{'request.role.domain'};
2326: }
2327: my %can_assign = (
2328: krb4 => 1,
2329: krb5 => 1,
2330: int => 1,
2331: loc => 1,
2332: );
2333: my %domconfig = &Apache::lonnet::get_dom('configuration',['usercreation'],$dom);
2334: if (ref($domconfig{'usercreation'}) eq 'HASH') {
2335: if (ref($domconfig{'usercreation'}{'authtypes'}) eq 'HASH') {
2336: my $authhash = $domconfig{'usercreation'}{'authtypes'};
2337: my $context;
2338: if ($env{'request.role'} =~ /^au/) {
2339: $context = 'author';
2340: } elsif ($env{'request.role'} =~ /^dc/) {
2341: $context = 'domain';
2342: } elsif ($env{'request.course.id'}) {
2343: $context = 'course';
2344: }
2345: if ($context) {
2346: if (ref($authhash->{$context}) eq 'HASH') {
2347: %can_assign = %{$authhash->{$context}};
2348: }
2349: }
2350: }
2351: }
2352: my $authnum = 0;
2353: foreach my $key (keys(%can_assign)) {
2354: if ($can_assign{$key}) {
2355: $authnum ++;
2356: }
2357: }
2358: if ($can_assign{'krb4'} && $can_assign{'krb5'}) {
2359: $authnum --;
2360: }
2361: return ($authnum,%can_assign);
2362: }
2363:
1.80 albertel 2364: ###############################################################
2365: ## Get Kerberos Defaults for Domain ##
2366: ###############################################################
2367: ##
2368: ## Returns default kerberos version and an associated argument
2369: ## as listed in file domain.tab. If not listed, provides
2370: ## appropriate default domain and kerberos version.
2371: ##
2372: #-------------------------------------------
2373:
2374: =pod
2375:
1.648 raeburn 2376: =item * &get_kerberos_defaults()
1.80 albertel 2377:
2378: get_kerberos_defaults($target_domain) returns the default kerberos
1.641 raeburn 2379: version and domain. If not found, it defaults to version 4 and the
2380: domain of the server.
1.80 albertel 2381:
1.648 raeburn 2382: =over 4
2383:
1.80 albertel 2384: ($def_version, $def_krb_domain) = &get_kerberos_defaults($target_domain);
2385:
1.648 raeburn 2386: =back
2387:
2388: =back
2389:
1.80 albertel 2390: =cut
2391:
2392: #-------------------------------------------
2393: sub get_kerberos_defaults {
2394: my $domain=shift;
1.641 raeburn 2395: my ($krbdef,$krbdefdom);
2396: my %domdefaults = &Apache::lonnet::get_domain_defaults($domain);
2397: if (($domdefaults{'auth_def'} =~/^krb(4|5)$/) && ($domdefaults{'auth_arg_def'} ne '')) {
2398: $krbdef = $domdefaults{'auth_def'};
2399: $krbdefdom = $domdefaults{'auth_arg_def'};
2400: } else {
1.80 albertel 2401: $ENV{'SERVER_NAME'}=~/(\w+\.\w+)$/;
2402: my $krbdefdom=$1;
2403: $krbdefdom=~tr/a-z/A-Z/;
2404: $krbdef = "krb4";
2405: }
2406: return ($krbdef,$krbdefdom);
2407: }
1.112 bowersj2 2408:
1.32 matthew 2409:
1.46 matthew 2410: ###############################################################
2411: ## Thesaurus Functions ##
2412: ###############################################################
1.20 www 2413:
1.46 matthew 2414: =pod
1.20 www 2415:
1.112 bowersj2 2416: =head1 Thesaurus Functions
2417:
2418: =over 4
2419:
1.648 raeburn 2420: =item * &initialize_keywords()
1.46 matthew 2421:
2422: Initializes the package variable %Keywords if it is empty. Uses the
2423: package variable $thesaurus_db_file.
2424:
2425: =cut
2426:
2427: ###################################################
2428:
2429: sub initialize_keywords {
2430: return 1 if (scalar keys(%Keywords));
2431: # If we are here, %Keywords is empty, so fill it up
2432: # Make sure the file we need exists...
2433: if (! -e $thesaurus_db_file) {
2434: &Apache::lonnet::logthis("Attempt to access $thesaurus_db_file".
2435: " failed because it does not exist");
2436: return 0;
2437: }
2438: # Set up the hash as a database
2439: my %thesaurus_db;
2440: if (! tie(%thesaurus_db,'GDBM_File',
1.53 albertel 2441: $thesaurus_db_file,&GDBM_READER(),0640)){
1.46 matthew 2442: &Apache::lonnet::logthis("Could not tie \%thesaurus_db to ".
2443: $thesaurus_db_file);
2444: return 0;
2445: }
2446: # Get the average number of appearances of a word.
2447: my $avecount = $thesaurus_db{'average.count'};
2448: # Put keywords (those that appear > average) into %Keywords
2449: while (my ($word,$data)=each (%thesaurus_db)) {
2450: my ($count,undef) = split /:/,$data;
2451: $Keywords{$word}++ if ($count > $avecount);
2452: }
2453: untie %thesaurus_db;
2454: # Remove special values from %Keywords.
1.356 albertel 2455: foreach my $value ('total.count','average.count') {
2456: delete($Keywords{$value}) if (exists($Keywords{$value}));
1.586 raeburn 2457: }
1.46 matthew 2458: return 1;
2459: }
2460:
2461: ###################################################
2462:
2463: =pod
2464:
1.648 raeburn 2465: =item * &keyword($word)
1.46 matthew 2466:
2467: Returns true if $word is a keyword. A keyword is a word that appears more
2468: than the average number of times in the thesaurus database. Calls
2469: &initialize_keywords
2470:
2471: =cut
2472:
2473: ###################################################
1.20 www 2474:
2475: sub keyword {
1.46 matthew 2476: return if (!&initialize_keywords());
2477: my $word=lc(shift());
2478: $word=~s/\W//g;
2479: return exists($Keywords{$word});
1.20 www 2480: }
1.46 matthew 2481:
2482: ###############################################################
2483:
2484: =pod
1.20 www 2485:
1.648 raeburn 2486: =item * &get_related_words()
1.46 matthew 2487:
1.160 matthew 2488: Look up a word in the thesaurus. Takes a scalar argument and returns
1.46 matthew 2489: an array of words. If the keyword is not in the thesaurus, an empty array
2490: will be returned. The order of the words returned is determined by the
2491: database which holds them.
2492:
2493: Uses global $thesaurus_db_file.
2494:
2495: =cut
2496:
2497: ###############################################################
2498: sub get_related_words {
2499: my $keyword = shift;
2500: my %thesaurus_db;
2501: if (! -e $thesaurus_db_file) {
2502: &Apache::lonnet::logthis("Attempt to access $thesaurus_db_file ".
2503: "failed because the file does not exist");
2504: return ();
2505: }
2506: if (! tie(%thesaurus_db,'GDBM_File',
1.53 albertel 2507: $thesaurus_db_file,&GDBM_READER(),0640)){
1.46 matthew 2508: return ();
2509: }
2510: my @Words=();
1.429 www 2511: my $count=0;
1.46 matthew 2512: if (exists($thesaurus_db{$keyword})) {
1.356 albertel 2513: # The first element is the number of times
2514: # the word appears. We do not need it now.
1.429 www 2515: my (undef,@RelatedWords) = (split(/:/,$thesaurus_db{$keyword}));
2516: my (undef,$mostfrequentcount)=split(/\,/,$RelatedWords[0]);
2517: my $threshold=$mostfrequentcount/10;
2518: foreach my $possibleword (@RelatedWords) {
2519: my ($word,$wordcount)=split(/\,/,$possibleword);
2520: if ($wordcount>$threshold) {
2521: push(@Words,$word);
2522: $count++;
2523: if ($count>10) { last; }
2524: }
1.20 www 2525: }
2526: }
1.46 matthew 2527: untie %thesaurus_db;
2528: return @Words;
1.14 harris41 2529: }
1.46 matthew 2530:
1.112 bowersj2 2531: =pod
2532:
2533: =back
2534:
2535: =cut
1.61 www 2536:
2537: # -------------------------------------------------------------- Plaintext name
1.81 albertel 2538: =pod
2539:
1.112 bowersj2 2540: =head1 User Name Functions
2541:
2542: =over 4
2543:
1.648 raeburn 2544: =item * &plainname($uname,$udom,$first)
1.81 albertel 2545:
1.112 bowersj2 2546: Takes a users logon name and returns it as a string in
1.226 albertel 2547: "first middle last generation" form
2548: if $first is set to 'lastname' then it returns it as
2549: 'lastname generation, firstname middlename' if their is a lastname
1.81 albertel 2550:
2551: =cut
1.61 www 2552:
1.295 www 2553:
1.81 albertel 2554: ###############################################################
1.61 www 2555: sub plainname {
1.226 albertel 2556: my ($uname,$udom,$first)=@_;
1.537 albertel 2557: return if (!defined($uname) || !defined($udom));
1.295 www 2558: my %names=&getnames($uname,$udom);
1.226 albertel 2559: my $name=&Apache::lonnet::format_name($names{'firstname'},
2560: $names{'middlename'},
2561: $names{'lastname'},
2562: $names{'generation'},$first);
2563: $name=~s/^\s+//;
1.62 www 2564: $name=~s/\s+$//;
2565: $name=~s/\s+/ /g;
1.353 albertel 2566: if ($name !~ /\S/) { $name=$uname.':'.$udom; }
1.62 www 2567: return $name;
1.61 www 2568: }
1.66 www 2569:
2570: # -------------------------------------------------------------------- Nickname
1.81 albertel 2571: =pod
2572:
1.648 raeburn 2573: =item * &nickname($uname,$udom)
1.81 albertel 2574:
2575: Gets a users name and returns it as a string as
2576:
2577: ""nickname""
1.66 www 2578:
1.81 albertel 2579: if the user has a nickname or
2580:
2581: "first middle last generation"
2582:
2583: if the user does not
2584:
2585: =cut
1.66 www 2586:
2587: sub nickname {
2588: my ($uname,$udom)=@_;
1.537 albertel 2589: return if (!defined($uname) || !defined($udom));
1.295 www 2590: my %names=&getnames($uname,$udom);
1.68 albertel 2591: my $name=$names{'nickname'};
1.66 www 2592: if ($name) {
2593: $name='"'.$name.'"';
2594: } else {
2595: $name=$names{'firstname'}.' '.$names{'middlename'}.' '.
2596: $names{'lastname'}.' '.$names{'generation'};
2597: $name=~s/\s+$//;
2598: $name=~s/\s+/ /g;
2599: }
2600: return $name;
2601: }
2602:
1.295 www 2603: sub getnames {
2604: my ($uname,$udom)=@_;
1.537 albertel 2605: return if (!defined($uname) || !defined($udom));
1.433 albertel 2606: if ($udom eq 'public' && $uname eq 'public') {
2607: return ('lastname' => &mt('Public'));
2608: }
1.295 www 2609: my $id=$uname.':'.$udom;
2610: my ($names,$cached)=&Apache::lonnet::is_cached_new('namescache',$id);
2611: if ($cached) {
2612: return %{$names};
2613: } else {
2614: my %loadnames=&Apache::lonnet::get('environment',
2615: ['firstname','middlename','lastname','generation','nickname'],
2616: $udom,$uname);
2617: &Apache::lonnet::do_cache_new('namescache',$id,\%loadnames);
2618: return %loadnames;
2619: }
2620: }
1.61 www 2621:
1.542 raeburn 2622: # -------------------------------------------------------------------- getemails
1.648 raeburn 2623:
1.542 raeburn 2624: =pod
2625:
1.648 raeburn 2626: =item * &getemails($uname,$udom)
1.542 raeburn 2627:
2628: Gets a user's email information and returns it as a hash with keys:
2629: notification, critnotification, permanentemail
2630:
2631: For notification and critnotification, values are comma-separated lists
1.648 raeburn 2632: of e-mail addresses; for permanentemail, value is a single e-mail address.
1.542 raeburn 2633:
1.648 raeburn 2634:
1.542 raeburn 2635: =cut
2636:
1.648 raeburn 2637:
1.466 albertel 2638: sub getemails {
2639: my ($uname,$udom)=@_;
2640: if ($udom eq 'public' && $uname eq 'public') {
2641: return;
2642: }
1.467 www 2643: if (!$udom) { $udom=$env{'user.domain'}; }
2644: if (!$uname) { $uname=$env{'user.name'}; }
1.466 albertel 2645: my $id=$uname.':'.$udom;
2646: my ($names,$cached)=&Apache::lonnet::is_cached_new('emailscache',$id);
2647: if ($cached) {
2648: return %{$names};
2649: } else {
2650: my %loadnames=&Apache::lonnet::get('environment',
2651: ['notification','critnotification',
2652: 'permanentemail'],
2653: $udom,$uname);
2654: &Apache::lonnet::do_cache_new('emailscache',$id,\%loadnames);
2655: return %loadnames;
2656: }
2657: }
2658:
1.551 albertel 2659: sub flush_email_cache {
2660: my ($uname,$udom)=@_;
2661: if (!$udom) { $udom =$env{'user.domain'}; }
2662: if (!$uname) { $uname=$env{'user.name'}; }
2663: return if ($udom eq 'public' && $uname eq 'public');
2664: my $id=$uname.':'.$udom;
2665: &Apache::lonnet::devalidate_cache_new('emailscache',$id);
2666: }
2667:
1.61 www 2668: # ------------------------------------------------------------------ Screenname
1.81 albertel 2669:
2670: =pod
2671:
1.648 raeburn 2672: =item * &screenname($uname,$udom)
1.81 albertel 2673:
2674: Gets a users screenname and returns it as a string
2675:
2676: =cut
1.61 www 2677:
2678: sub screenname {
2679: my ($uname,$udom)=@_;
1.258 albertel 2680: if ($uname eq $env{'user.name'} &&
2681: $udom eq $env{'user.domain'}) {return $env{'environment.screenname'};}
1.212 albertel 2682: my %names=&Apache::lonnet::get('environment',['screenname'],$udom,$uname);
1.68 albertel 2683: return $names{'screenname'};
1.62 www 2684: }
2685:
1.212 albertel 2686:
1.62 www 2687: # ------------------------------------------------------------- Message Wrapper
2688:
2689: sub messagewrapper {
1.369 www 2690: my ($link,$username,$domain,$subject,$text)=@_;
1.62 www 2691: return
1.441 albertel 2692: '<a href="/adm/email?compose=individual&'.
2693: 'recname='.$username.'&recdom='.$domain.
2694: '&subject='.&escape($subject).'&text='.&escape($text).'" '.
1.200 matthew 2695: 'title="'.&mt('Send message').'">'.$link.'</a>';
1.74 www 2696: }
2697: # --------------------------------------------------------------- Notes Wrapper
2698:
2699: sub noteswrapper {
2700: my ($link,$un,$do)=@_;
2701: return
2702: "<a href='/adm/email?recordftf=retrieve&recname=$un&recdom=$do'>$link</a>";
1.62 www 2703: }
2704: # ------------------------------------------------------------- Aboutme Wrapper
2705:
2706: sub aboutmewrapper {
1.166 www 2707: my ($link,$username,$domain,$target)=@_;
1.447 raeburn 2708: if (!defined($username) && !defined($domain)) {
2709: return;
2710: }
1.205 www 2711: return '<a href="/adm/'.$domain.'/'.$username.'/aboutme"'.
1.454 banghart 2712: ($target?' target="$target"':'').' title="'.&mt("View this user's personal page").'">'.$link.'</a>';
1.62 www 2713: }
2714:
2715: # ------------------------------------------------------------ Syllabus Wrapper
2716:
2717:
2718: sub syllabuswrapper {
1.109 matthew 2719: my ($linktext,$coursedir,$domain,$fontcolor)=@_;
2720: if ($fontcolor) {
2721: $linktext='<font color="'.$fontcolor.'">'.$linktext.'</font>';
2722: }
1.208 matthew 2723: return qq{<a href="/public/$domain/$coursedir/syllabus">$linktext</a>};
1.61 www 2724: }
1.14 harris41 2725:
1.208 matthew 2726: sub track_student_link {
1.268 albertel 2727: my ($linktext,$sname,$sdom,$target,$start) = @_;
2728: my $link ="/adm/trackstudent?";
1.208 matthew 2729: my $title = 'View recent activity';
2730: if (defined($sname) && $sname !~ /^\s*$/ &&
2731: defined($sdom) && $sdom !~ /^\s*$/) {
1.268 albertel 2732: $link .= "selected_student=$sname:$sdom";
1.208 matthew 2733: $title .= ' of this student';
1.268 albertel 2734: }
1.208 matthew 2735: if (defined($target) && $target !~ /^\s*$/) {
2736: $target = qq{target="$target"};
2737: } else {
2738: $target = '';
2739: }
1.268 albertel 2740: if ($start) { $link.='&start='.$start; }
1.554 albertel 2741: $title = &mt($title);
2742: $linktext = &mt($linktext);
1.448 albertel 2743: return qq{<a href="$link" title="$title" $target>$linktext</a>}.
2744: &help_open_topic('View_recent_activity');
1.208 matthew 2745: }
2746:
1.508 www 2747: # ===================================================== Display a student photo
2748:
2749:
1.509 albertel 2750: sub student_image_tag {
1.508 www 2751: my ($domain,$user)=@_;
2752: my $imgsrc=&Apache::lonnet::studentphoto($domain,$user,'jpg');
2753: if (($imgsrc) && ($imgsrc ne '/adm/lonKaputt/lonlogo_broken.gif')) {
2754: return '<img src="'.$imgsrc.'" align="right" />';
2755: } else {
2756: return '';
2757: }
2758: }
2759:
1.112 bowersj2 2760: =pod
2761:
2762: =back
2763:
2764: =head1 Access .tab File Data
2765:
2766: =over 4
2767:
1.648 raeburn 2768: =item * &languageids()
1.112 bowersj2 2769:
2770: returns list of all language ids
2771:
2772: =cut
2773:
1.14 harris41 2774: sub languageids {
1.16 harris41 2775: return sort(keys(%language));
1.14 harris41 2776: }
2777:
1.112 bowersj2 2778: =pod
2779:
1.648 raeburn 2780: =item * &languagedescription()
1.112 bowersj2 2781:
2782: returns description of a specified language id
2783:
2784: =cut
2785:
1.14 harris41 2786: sub languagedescription {
1.125 www 2787: my $code=shift;
2788: return ($supported_language{$code}?'* ':'').
2789: $language{$code}.
1.126 www 2790: ($supported_language{$code}?' ('.&mt('interface available').')':'');
1.145 www 2791: }
2792:
2793: sub plainlanguagedescription {
2794: my $code=shift;
2795: return $language{$code};
2796: }
2797:
2798: sub supportedlanguagecode {
2799: my $code=shift;
2800: return $supported_language{$code};
1.97 www 2801: }
2802:
1.112 bowersj2 2803: =pod
2804:
1.648 raeburn 2805: =item * ©rightids()
1.112 bowersj2 2806:
2807: returns list of all copyrights
2808:
2809: =cut
2810:
2811: sub copyrightids {
2812: return sort(keys(%cprtag));
2813: }
2814:
2815: =pod
2816:
1.648 raeburn 2817: =item * ©rightdescription()
1.112 bowersj2 2818:
2819: returns description of a specified copyright id
2820:
2821: =cut
2822:
2823: sub copyrightdescription {
1.166 www 2824: return &mt($cprtag{shift(@_)});
1.112 bowersj2 2825: }
1.197 matthew 2826:
2827: =pod
2828:
1.648 raeburn 2829: =item * &source_copyrightids()
1.192 taceyjo1 2830:
2831: returns list of all source copyrights
2832:
2833: =cut
2834:
2835: sub source_copyrightids {
2836: return sort(keys(%scprtag));
2837: }
2838:
2839: =pod
2840:
1.648 raeburn 2841: =item * &source_copyrightdescription()
1.192 taceyjo1 2842:
2843: returns description of a specified source copyright id
2844:
2845: =cut
2846:
2847: sub source_copyrightdescription {
2848: return &mt($scprtag{shift(@_)});
2849: }
1.112 bowersj2 2850:
2851: =pod
2852:
1.648 raeburn 2853: =item * &filecategories()
1.112 bowersj2 2854:
2855: returns list of all file categories
2856:
2857: =cut
2858:
2859: sub filecategories {
2860: return sort(keys(%category_extensions));
2861: }
2862:
2863: =pod
2864:
1.648 raeburn 2865: =item * &filecategorytypes()
1.112 bowersj2 2866:
2867: returns list of file types belonging to a given file
2868: category
2869:
2870: =cut
2871:
2872: sub filecategorytypes {
1.356 albertel 2873: my ($cat) = @_;
2874: return @{$category_extensions{lc($cat)}};
1.112 bowersj2 2875: }
2876:
2877: =pod
2878:
1.648 raeburn 2879: =item * &fileembstyle()
1.112 bowersj2 2880:
2881: returns embedding style for a specified file type
2882:
2883: =cut
2884:
2885: sub fileembstyle {
2886: return $fe{lc(shift(@_))};
1.169 www 2887: }
2888:
1.351 www 2889: sub filemimetype {
2890: return $fm{lc(shift(@_))};
2891: }
2892:
1.169 www 2893:
2894: sub filecategoryselect {
2895: my ($name,$value)=@_;
1.189 matthew 2896: return &select_form($value,$name,
1.169 www 2897: '' => &mt('Any category'),
2898: map { $_,$_ } sort(keys(%category_extensions)));
1.112 bowersj2 2899: }
2900:
2901: =pod
2902:
1.648 raeburn 2903: =item * &filedescription()
1.112 bowersj2 2904:
2905: returns description for a specified file type
2906:
2907: =cut
2908:
2909: sub filedescription {
1.188 matthew 2910: my $file_description = $fd{lc(shift())};
2911: $file_description =~ s:([\[\]]):~$1:g;
2912: return &mt($file_description);
1.112 bowersj2 2913: }
2914:
2915: =pod
2916:
1.648 raeburn 2917: =item * &filedescriptionex()
1.112 bowersj2 2918:
2919: returns description for a specified file type with
2920: extra formatting
2921:
2922: =cut
2923:
2924: sub filedescriptionex {
2925: my $ex=shift;
1.188 matthew 2926: my $file_description = $fd{lc($ex)};
2927: $file_description =~ s:([\[\]]):~$1:g;
2928: return '.'.$ex.' '.&mt($file_description);
1.112 bowersj2 2929: }
2930:
2931: # End of .tab access
2932: =pod
2933:
2934: =back
2935:
2936: =cut
2937:
2938: # ------------------------------------------------------------------ File Types
2939: sub fileextensions {
2940: return sort(keys(%fe));
2941: }
2942:
1.97 www 2943: # ----------------------------------------------------------- Display Languages
2944: # returns a hash with all desired display languages
2945: #
2946:
2947: sub display_languages {
2948: my %languages=();
1.356 albertel 2949: foreach my $lang (&preferred_languages()) {
2950: $languages{$lang}=1;
1.97 www 2951: }
2952: &get_unprocessed_cgi($ENV{'QUERY_STRING'},['displaylanguage']);
1.258 albertel 2953: if ($env{'form.displaylanguage'}) {
1.356 albertel 2954: foreach my $lang (split(/\s*(\,|\;|\:)\s*/,$env{'form.displaylanguage'})) {
2955: $languages{$lang}=1;
1.97 www 2956: }
2957: }
2958: return %languages;
1.14 harris41 2959: }
2960:
1.117 www 2961: sub preferred_languages {
2962: my @languages=();
1.654 www 2963: if (($env{'request.role.adv'}) && ($env{'form.languages'})) {
2964: @languages=(@languages,split(/\s*(\,|\;|\:)\s*/,$env{'form.languages'}));
2965: }
1.258 albertel 2966: if ($env{'course.'.$env{'request.course.id'}.'.languages'}) {
1.117 www 2967: @languages=(@languages,split(/\s*(\,|\;|\:)\s*/,
1.258 albertel 2968: $env{'course.'.$env{'request.course.id'}.'.languages'}));
1.177 www 2969: }
1.654 www 2970:
1.258 albertel 2971: if ($env{'environment.languages'}) {
1.459 albertel 2972: @languages=(@languages,
2973: split(/\s*(\,|\;|\:)\s*/,$env{'environment.languages'}));
1.118 www 2974: }
1.583 albertel 2975: my $browser=$ENV{'HTTP_ACCEPT_LANGUAGE'};
1.162 www 2976: if ($browser) {
1.583 albertel 2977: my @browser =
2978: map { (split(/\s*;\s*/,$_))[0] } (split(/\s*,\s*/,$browser));
2979: push(@languages,@browser);
1.162 www 2980: }
1.641 raeburn 2981:
2982: foreach my $domtype ($env{'user.domain'},$env{'request.role.domain'},
2983: $Apache::lonnet::perlvar{'lonDefDomain'}) {
2984: if ($domtype ne '') {
2985: my %domdefs = &Apache::lonnet::get_domain_defaults($domtype);
2986: if ($domdefs{'lang_def'} ne '') {
2987: push(@languages,$domdefs{'lang_def'});
2988: }
2989: }
1.118 www 2990: }
2991: # turn "en-ca" into "en-ca,en"
2992: my @genlanguages;
1.356 albertel 2993: foreach my $lang (@languages) {
2994: unless ($lang=~/\w/) { next; }
1.583 albertel 2995: push(@genlanguages,$lang);
1.356 albertel 2996: if ($lang=~/(\-|\_)/) {
2997: push(@genlanguages,(split(/(\-|\_)/,$lang))[0]);
1.118 www 2998: }
2999: }
1.583 albertel 3000: #uniqueify the languages list
3001: my %count;
3002: @genlanguages = map { $count{$_}++ == 0 ? $_ : () } @genlanguages;
1.118 www 3003: return @genlanguages;
1.117 www 3004: }
3005:
1.582 albertel 3006: sub languages {
3007: my ($possible_langs) = @_;
3008: my @preferred_langs = &preferred_languages();
3009: if (!ref($possible_langs)) {
3010: if( wantarray ) {
3011: return @preferred_langs;
3012: } else {
3013: return $preferred_langs[0];
3014: }
3015: }
3016: my %possibilities = map { $_ => 1 } (@$possible_langs);
3017: my @preferred_possibilities;
3018: foreach my $preferred_lang (@preferred_langs) {
3019: if (exists($possibilities{$preferred_lang})) {
3020: push(@preferred_possibilities, $preferred_lang);
3021: }
3022: }
3023: if( wantarray ) {
3024: return @preferred_possibilities;
3025: }
3026: return $preferred_possibilities[0];
3027: }
3028:
1.112 bowersj2 3029: ###############################################################
3030: ## Student Answer Attempts ##
3031: ###############################################################
3032:
3033: =pod
3034:
3035: =head1 Alternate Problem Views
3036:
3037: =over 4
3038:
1.648 raeburn 3039: =item * &get_previous_attempt($symb, $username, $domain, $course,
1.112 bowersj2 3040: $getattempt, $regexp, $gradesub)
3041:
3042: Return string with previous attempt on problem. Arguments:
3043:
3044: =over 4
3045:
3046: =item * $symb: Problem, including path
3047:
3048: =item * $username: username of the desired student
3049:
3050: =item * $domain: domain of the desired student
1.14 harris41 3051:
1.112 bowersj2 3052: =item * $course: Course ID
1.14 harris41 3053:
1.112 bowersj2 3054: =item * $getattempt: Leave blank for all attempts, otherwise put
3055: something
1.14 harris41 3056:
1.112 bowersj2 3057: =item * $regexp: if string matches this regexp, the string will be
3058: sent to $gradesub
1.14 harris41 3059:
1.112 bowersj2 3060: =item * $gradesub: routine that processes the string if it matches $regexp
1.14 harris41 3061:
1.112 bowersj2 3062: =back
1.14 harris41 3063:
1.112 bowersj2 3064: The output string is a table containing all desired attempts, if any.
1.16 harris41 3065:
1.112 bowersj2 3066: =cut
1.1 albertel 3067:
3068: sub get_previous_attempt {
1.43 ng 3069: my ($symb,$username,$domain,$course,$getattempt,$regexp,$gradesub)=@_;
1.1 albertel 3070: my $prevattempts='';
1.43 ng 3071: no strict 'refs';
1.1 albertel 3072: if ($symb) {
1.3 albertel 3073: my (%returnhash)=
3074: &Apache::lonnet::restore($symb,$course,$domain,$username);
1.1 albertel 3075: if ($returnhash{'version'}) {
3076: my %lasthash=();
3077: my $version;
3078: for ($version=1;$version<=$returnhash{'version'};$version++) {
1.356 albertel 3079: foreach my $key (sort(split(/\:/,$returnhash{$version.':keys'}))) {
3080: $lasthash{$key}=$returnhash{$version.':'.$key};
1.19 harris41 3081: }
1.1 albertel 3082: }
1.596 albertel 3083: $prevattempts=&start_data_table().&start_data_table_header_row();
3084: $prevattempts.='<th>'.&mt('History').'</th>';
1.356 albertel 3085: foreach my $key (sort(keys(%lasthash))) {
3086: my ($ign,@parts) = split(/\./,$key);
1.41 ng 3087: if ($#parts > 0) {
1.31 albertel 3088: my $data=$parts[-1];
3089: pop(@parts);
1.596 albertel 3090: $prevattempts.='<th>'.&mt('Part ').join('.',@parts).'<br />'.$data.' </th>';
1.31 albertel 3091: } else {
1.41 ng 3092: if ($#parts == 0) {
3093: $prevattempts.='<th>'.$parts[0].'</th>';
3094: } else {
3095: $prevattempts.='<th>'.$ign.'</th>';
3096: }
1.31 albertel 3097: }
1.16 harris41 3098: }
1.596 albertel 3099: $prevattempts.=&end_data_table_header_row();
1.40 ng 3100: if ($getattempt eq '') {
3101: for ($version=1;$version<=$returnhash{'version'};$version++) {
1.596 albertel 3102: $prevattempts.=&start_data_table_row().
3103: '<td>'.&mt('Transaction [_1]',$version).'</td>';
1.356 albertel 3104: foreach my $key (sort(keys(%lasthash))) {
1.581 albertel 3105: my $value = &format_previous_attempt_value($key,
3106: $returnhash{$version.':'.$key});
3107: $prevattempts.='<td>'.$value.' </td>';
1.40 ng 3108: }
1.596 albertel 3109: $prevattempts.=&end_data_table_row();
1.40 ng 3110: }
1.1 albertel 3111: }
1.596 albertel 3112: $prevattempts.=&start_data_table_row().'<td>'.&mt('Current').'</td>';
1.356 albertel 3113: foreach my $key (sort(keys(%lasthash))) {
1.581 albertel 3114: my $value = &format_previous_attempt_value($key,$lasthash{$key});
1.356 albertel 3115: if ($key =~/$regexp$/ && (defined &$gradesub)) {$value = &$gradesub($value)}
1.40 ng 3116: $prevattempts.='<td>'.$value.' </td>';
1.16 harris41 3117: }
1.596 albertel 3118: $prevattempts.= &end_data_table_row().&end_data_table();
1.1 albertel 3119: } else {
1.596 albertel 3120: $prevattempts=
3121: &start_data_table().&start_data_table_row().
3122: '<td>'.&mt('Nothing submitted - no attempts.').'</td>'.
3123: &end_data_table_row().&end_data_table();
1.1 albertel 3124: }
3125: } else {
1.596 albertel 3126: $prevattempts=
3127: &start_data_table().&start_data_table_row().
3128: '<td>'.&mt('No data.').'</td>'.
3129: &end_data_table_row().&end_data_table();
1.1 albertel 3130: }
1.10 albertel 3131: }
3132:
1.581 albertel 3133: sub format_previous_attempt_value {
3134: my ($key,$value) = @_;
3135: if ($key =~ /timestamp/) {
3136: $value = &Apache::lonlocal::locallocaltime($value);
3137: } elsif (ref($value) eq 'ARRAY') {
3138: $value = '('.join(', ', @{ $value }).')';
3139: } else {
3140: $value = &unescape($value);
3141: }
3142: return $value;
3143: }
3144:
3145:
1.107 albertel 3146: sub relative_to_absolute {
3147: my ($url,$output)=@_;
3148: my $parser=HTML::TokeParser->new(\$output);
3149: my $token;
3150: my $thisdir=$url;
3151: my @rlinks=();
3152: while ($token=$parser->get_token) {
3153: if ($token->[0] eq 'S') {
3154: if ($token->[1] eq 'a') {
3155: if ($token->[2]->{'href'}) {
3156: $rlinks[$#rlinks+1]=$token->[2]->{'href'};
3157: }
3158: } elsif ($token->[1] eq 'img' || $token->[1] eq 'embed' ) {
3159: $rlinks[$#rlinks+1]=$token->[2]->{'src'};
3160: } elsif ($token->[1] eq 'base') {
3161: $thisdir=$token->[2]->{'href'};
3162: }
3163: }
3164: }
3165: $thisdir=~s-/[^/]*$--;
1.356 albertel 3166: foreach my $link (@rlinks) {
3167: unless (($link=~/^http:\/\//i) ||
3168: ($link=~/^\//) ||
3169: ($link=~/^javascript:/i) ||
3170: ($link=~/^mailto:/i) ||
3171: ($link=~/^\#/)) {
3172: my $newlocation=&Apache::lonnet::hreflocation($thisdir,$link);
3173: $output=~s/(\"|\'|\=\s*)\Q$link\E(\"|\'|\s|\>)/$1$newlocation$2/;
1.107 albertel 3174: }
3175: }
3176: # -------------------------------------------------- Deal with Applet codebases
3177: $output=~s/(\<applet[^\>]+)(codebase\=[^\S\>]+)*([^\>]*)\>/$1.($2?$2:' codebase="'.$thisdir.'"').$3.'>'/gei;
3178: return $output;
3179: }
3180:
1.112 bowersj2 3181: =pod
3182:
1.648 raeburn 3183: =item * &get_student_view()
1.112 bowersj2 3184:
3185: show a snapshot of what student was looking at
3186:
3187: =cut
3188:
1.10 albertel 3189: sub get_student_view {
1.186 albertel 3190: my ($symb,$username,$domain,$courseid,$target,$moreenv) = @_;
1.114 www 3191: my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb);
1.186 albertel 3192: my (%form);
1.10 albertel 3193: my @elements=('symb','courseid','domain','username');
3194: foreach my $element (@elements) {
1.186 albertel 3195: $form{'grade_'.$element}=eval '$'.$element #'
1.10 albertel 3196: }
1.186 albertel 3197: if (defined($moreenv)) {
3198: %form=(%form,%{$moreenv});
3199: }
1.236 albertel 3200: if (defined($target)) { $form{'grade_target'} = $target; }
1.107 albertel 3201: $feedurl=&Apache::lonnet::clutter($feedurl);
1.650 www 3202: my ($userview,$response)=&Apache::lonnet::ssi_body($feedurl,%form);
1.11 albertel 3203: $userview=~s/\<body[^\>]*\>//gi;
3204: $userview=~s/\<\/body\>//gi;
3205: $userview=~s/\<html\>//gi;
3206: $userview=~s/\<\/html\>//gi;
3207: $userview=~s/\<head\>//gi;
3208: $userview=~s/\<\/head\>//gi;
3209: $userview=~s/action\s*\=/would_be_action\=/gi;
1.107 albertel 3210: $userview=&relative_to_absolute($feedurl,$userview);
1.650 www 3211: if (wantarray) {
3212: return ($userview,$response);
3213: } else {
3214: return $userview;
3215: }
3216: }
3217:
3218: sub get_student_view_with_retries {
3219: my ($symb,$retries,$username,$domain,$courseid,$target,$moreenv) = @_;
3220:
3221: my $ok = 0; # True if we got a good response.
3222: my $content;
3223: my $response;
3224:
3225: # Try to get the student_view done. within the retries count:
3226:
3227: do {
3228: ($content, $response) = &get_student_view($symb,$username,$domain,$courseid,$target,$moreenv);
3229: $ok = $response->is_success;
3230: if (!$ok) {
3231: &Apache::lonnet::logthis("Failed get_student_view_with_retries on $symb: ".$response->is_success.', '.$response->code.', '.$response->message);
3232: }
3233: $retries--;
3234: } while (!$ok && ($retries > 0));
3235:
3236: if (!$ok) {
3237: $content = ''; # On error return an empty content.
3238: }
1.651 www 3239: if (wantarray) {
3240: return ($content, $response);
3241: } else {
3242: return $content;
3243: }
1.11 albertel 3244: }
3245:
1.112 bowersj2 3246: =pod
3247:
1.648 raeburn 3248: =item * &get_student_answers()
1.112 bowersj2 3249:
3250: show a snapshot of how student was answering problem
3251:
3252: =cut
3253:
1.11 albertel 3254: sub get_student_answers {
1.100 sakharuk 3255: my ($symb,$username,$domain,$courseid,%form) = @_;
1.114 www 3256: my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb);
1.186 albertel 3257: my (%moreenv);
1.11 albertel 3258: my @elements=('symb','courseid','domain','username');
3259: foreach my $element (@elements) {
1.186 albertel 3260: $moreenv{'grade_'.$element}=eval '$'.$element #'
1.10 albertel 3261: }
1.186 albertel 3262: $moreenv{'grade_target'}='answer';
3263: %moreenv=(%form,%moreenv);
1.497 raeburn 3264: $feedurl = &Apache::lonnet::clutter($feedurl);
3265: my $userview=&Apache::lonnet::ssi($feedurl,%moreenv);
1.10 albertel 3266: return $userview;
1.1 albertel 3267: }
1.116 albertel 3268:
3269: =pod
3270:
3271: =item * &submlink()
3272:
1.242 albertel 3273: Inputs: $text $uname $udom $symb $target
1.116 albertel 3274:
3275: Returns: A link to grades.pm such as to see the SUBM view of a student
3276:
3277: =cut
3278:
3279: ###############################################
3280: sub submlink {
1.242 albertel 3281: my ($text,$uname,$udom,$symb,$target)=@_;
1.116 albertel 3282: if (!($uname && $udom)) {
3283: (my $cursymb, my $courseid,$udom,$uname)=
1.463 albertel 3284: &Apache::lonnet::whichuser($symb);
1.116 albertel 3285: if (!$symb) { $symb=$cursymb; }
3286: }
1.254 matthew 3287: if (!$symb) { $symb=&Apache::lonnet::symbread(); }
1.369 www 3288: $symb=&escape($symb);
1.242 albertel 3289: if ($target) { $target="target=\"$target\""; }
3290: return '<a href="/adm/grades?&command=submission&'.
3291: 'symb='.$symb.'&student='.$uname.
3292: '&userdom='.$udom.'" '.$target.'>'.$text.'</a>';
3293: }
3294: ##############################################
3295:
3296: =pod
3297:
3298: =item * &pgrdlink()
3299:
3300: Inputs: $text $uname $udom $symb $target
3301:
3302: Returns: A link to grades.pm such as to see the PGRD view of a student
3303:
3304: =cut
3305:
3306: ###############################################
3307: sub pgrdlink {
3308: my $link=&submlink(@_);
3309: $link=~s/(&command=submission)/$1&showgrading=yes/;
3310: return $link;
3311: }
3312: ##############################################
3313:
3314: =pod
3315:
3316: =item * &pprmlink()
3317:
3318: Inputs: $text $uname $udom $symb $target
3319:
3320: Returns: A link to parmset.pm such as to see the PPRM view of a
1.283 albertel 3321: student and a specific resource
1.242 albertel 3322:
3323: =cut
3324:
3325: ###############################################
3326: sub pprmlink {
3327: my ($text,$uname,$udom,$symb,$target)=@_;
3328: if (!($uname && $udom)) {
3329: (my $cursymb, my $courseid,$udom,$uname)=
1.463 albertel 3330: &Apache::lonnet::whichuser($symb);
1.242 albertel 3331: if (!$symb) { $symb=$cursymb; }
3332: }
1.254 matthew 3333: if (!$symb) { $symb=&Apache::lonnet::symbread(); }
1.369 www 3334: $symb=&escape($symb);
1.242 albertel 3335: if ($target) { $target="target=\"$target\""; }
1.595 albertel 3336: return '<a href="/adm/parmset?command=set&'.
3337: 'symb='.$symb.'&uname='.$uname.
3338: '&udom='.$udom.'" '.$target.'>'.$text.'</a>';
1.116 albertel 3339: }
3340: ##############################################
1.37 matthew 3341:
1.112 bowersj2 3342: =pod
3343:
3344: =back
3345:
3346: =cut
3347:
1.37 matthew 3348: ###############################################
1.51 www 3349:
3350:
3351: sub timehash {
3352: my @ltime=localtime(shift);
3353: return ( 'seconds' => $ltime[0],
3354: 'minutes' => $ltime[1],
3355: 'hours' => $ltime[2],
3356: 'day' => $ltime[3],
3357: 'month' => $ltime[4]+1,
3358: 'year' => $ltime[5]+1900,
3359: 'weekday' => $ltime[6],
3360: 'dayyear' => $ltime[7]+1,
3361: 'dlsav' => $ltime[8] );
3362: }
3363:
1.370 www 3364: sub utc_string {
3365: my ($date)=@_;
1.371 www 3366: return strftime("%Y%m%dT%H%M%SZ",gmtime($date));
1.370 www 3367: }
3368:
1.51 www 3369: sub maketime {
3370: my %th=@_;
3371: return POSIX::mktime(
3372: ($th{'seconds'},$th{'minutes'},$th{'hours'},
1.210 www 3373: $th{'day'},$th{'month'}-1,$th{'year'}-1900,0,0,-1));
1.70 www 3374: }
3375:
3376: #########################################
1.51 www 3377:
3378: sub findallcourses {
1.482 raeburn 3379: my ($roles,$uname,$udom) = @_;
1.355 albertel 3380: my %roles;
3381: if (ref($roles)) { %roles = map { $_ => 1 } @{$roles}; }
1.348 albertel 3382: my %courses;
1.51 www 3383: my $now=time;
1.482 raeburn 3384: if (!defined($uname)) {
3385: $uname = $env{'user.name'};
3386: }
3387: if (!defined($udom)) {
3388: $udom = $env{'user.domain'};
3389: }
3390: if (($uname ne $env{'user.name'}) || ($udom ne $env{'user.domain'})) {
3391: my %roleshash = &Apache::lonnet::dump('roles',$udom,$uname);
3392: if (!%roles) {
3393: %roles = (
3394: cc => 1,
3395: in => 1,
3396: ep => 1,
3397: ta => 1,
3398: cr => 1,
3399: st => 1,
3400: );
3401: }
3402: foreach my $entry (keys(%roleshash)) {
3403: my ($trole,$tend,$tstart) = split(/_/,$roleshash{$entry});
3404: if ($trole =~ /^cr/) {
3405: next if (!exists($roles{$trole}) && !exists($roles{'cr'}));
3406: } else {
3407: next if (!exists($roles{$trole}));
3408: }
3409: if ($tend) {
3410: next if ($tend < $now);
3411: }
3412: if ($tstart) {
3413: next if ($tstart > $now);
3414: }
3415: my ($cdom,$cnum,$sec,$cnumpart,$secpart,$role,$realsec);
3416: (undef,$cdom,$cnumpart,$secpart) = split(/\//,$entry);
3417: if ($secpart eq '') {
3418: ($cnum,$role) = split(/_/,$cnumpart);
3419: $sec = 'none';
3420: $realsec = '';
3421: } else {
3422: $cnum = $cnumpart;
3423: ($sec,$role) = split(/_/,$secpart);
3424: $realsec = $sec;
1.490 raeburn 3425: }
1.482 raeburn 3426: $courses{$cdom.'_'.$cnum}{$sec} = $trole.'/'.$cdom.'/'.$cnum.'/'.$realsec;
3427: }
3428: } else {
3429: foreach my $key (keys(%env)) {
1.483 albertel 3430: if ( $key=~m{^user\.role\.(\w+)\./($match_domain)/($match_courseid)/?(\w*)$} ||
3431: $key=~m{^user\.role\.(cr/$match_domain/$match_username/\w+)\./($match_domain)/($match_courseid)/?(\w*)$}) {
1.482 raeburn 3432: my ($role,$cdom,$cnum,$sec) = ($1,$2,$3,$4);
3433: next if ($role eq 'ca' || $role eq 'aa');
3434: next if (%roles && !exists($roles{$role}));
3435: my ($starttime,$endtime)=split(/\./,$env{$key});
3436: my $active=1;
3437: if ($starttime) {
3438: if ($now<$starttime) { $active=0; }
3439: }
3440: if ($endtime) {
3441: if ($now>$endtime) { $active=0; }
3442: }
3443: if ($active) {
3444: if ($sec eq '') {
3445: $sec = 'none';
3446: }
3447: $courses{$cdom.'_'.$cnum}{$sec} =
3448: $role.'/'.$cdom.'/'.$cnum.'/'.$sec;
1.474 raeburn 3449: }
3450: }
1.51 www 3451: }
3452: }
1.474 raeburn 3453: return %courses;
1.51 www 3454: }
1.37 matthew 3455:
1.54 www 3456: ###############################################
1.474 raeburn 3457:
3458: sub blockcheck {
1.482 raeburn 3459: my ($setters,$activity,$uname,$udom) = @_;
1.490 raeburn 3460:
3461: if (!defined($udom)) {
3462: $udom = $env{'user.domain'};
3463: }
3464: if (!defined($uname)) {
3465: $uname = $env{'user.name'};
3466: }
3467:
3468: # If uname and udom are for a course, check for blocks in the course.
3469:
3470: if (&Apache::lonnet::is_course($udom,$uname)) {
3471: my %records = &Apache::lonnet::dump('comm_block',$udom,$uname);
1.502 raeburn 3472: my ($startblock,$endblock)=&get_blocks($setters,$activity,$udom,$uname);
1.490 raeburn 3473: return ($startblock,$endblock);
3474: }
1.474 raeburn 3475:
1.502 raeburn 3476: my $startblock = 0;
3477: my $endblock = 0;
1.482 raeburn 3478: my %live_courses = &findallcourses(undef,$uname,$udom);
1.474 raeburn 3479:
1.490 raeburn 3480: # If uname is for a user, and activity is course-specific, i.e.,
3481: # boards, chat or groups, check for blocking in current course only.
1.474 raeburn 3482:
1.490 raeburn 3483: if (($activity eq 'boards' || $activity eq 'chat' ||
3484: $activity eq 'groups') && ($env{'request.course.id'})) {
3485: foreach my $key (keys(%live_courses)) {
3486: if ($key ne $env{'request.course.id'}) {
3487: delete($live_courses{$key});
3488: }
3489: }
3490: }
3491:
3492: my $otheruser = 0;
3493: my %own_courses;
3494: if ((($uname ne $env{'user.name'})) || ($udom ne $env{'user.domain'})) {
3495: # Resource belongs to user other than current user.
3496: $otheruser = 1;
3497: # Gather courses for current user
3498: %own_courses =
3499: &findallcourses(undef,$env{'user.name'},$env{'user.domain'});
3500: }
3501:
3502: # Gather active course roles - course coordinator, instructor,
3503: # exam proctor, ta, student, or custom role.
1.474 raeburn 3504:
3505: foreach my $course (keys(%live_courses)) {
1.482 raeburn 3506: my ($cdom,$cnum);
3507: if ((defined($env{'course.'.$course.'.domain'})) && (defined($env{'course.'.$course.'.num'}))) {
3508: $cdom = $env{'course.'.$course.'.domain'};
3509: $cnum = $env{'course.'.$course.'.num'};
3510: } else {
1.490 raeburn 3511: ($cdom,$cnum) = split(/_/,$course);
1.482 raeburn 3512: }
3513: my $no_ownblock = 0;
3514: my $no_userblock = 0;
1.533 raeburn 3515: if ($otheruser && $activity ne 'com') {
1.490 raeburn 3516: # Check if current user has 'evb' priv for this
3517: if (defined($own_courses{$course})) {
3518: foreach my $sec (keys(%{$own_courses{$course}})) {
3519: my $checkrole = 'cm./'.$cdom.'/'.$cnum;
3520: if ($sec ne 'none') {
3521: $checkrole .= '/'.$sec;
3522: }
3523: if (&Apache::lonnet::allowed('evb',undef,undef,$checkrole)) {
3524: $no_ownblock = 1;
3525: last;
3526: }
3527: }
3528: }
3529: # if they have 'evb' priv and are currently not playing student
3530: next if (($no_ownblock) &&
3531: ($env{'request.role'} !~ m{^st\./$cdom/$cnum}));
3532: }
1.474 raeburn 3533: foreach my $sec (keys(%{$live_courses{$course}})) {
1.482 raeburn 3534: my $checkrole = 'cm./'.$cdom.'/'.$cnum;
1.474 raeburn 3535: if ($sec ne 'none') {
1.482 raeburn 3536: $checkrole .= '/'.$sec;
1.474 raeburn 3537: }
1.490 raeburn 3538: if ($otheruser) {
3539: # Resource belongs to user other than current user.
3540: # Assemble privs for that user, and check for 'evb' priv.
1.482 raeburn 3541: my ($trole,$tdom,$tnum,$tsec);
3542: my $entry = $live_courses{$course}{$sec};
3543: if ($entry =~ /^cr/) {
3544: ($trole,$tdom,$tnum,$tsec) =
3545: ($entry =~ m|^(cr/$match_domain/$match_username/\w+)\./($match_domain)/($match_username)/?(\w*)$|);
3546: } else {
3547: ($trole,$tdom,$tnum,$tsec) = split(/\//,$entry);
3548: }
3549: my ($spec,$area,$trest,%allroles,%userroles);
3550: $area = '/'.$tdom.'/'.$tnum;
3551: $trest = $tnum;
3552: if ($tsec ne '') {
3553: $area .= '/'.$tsec;
3554: $trest .= '/'.$tsec;
3555: }
3556: $spec = $trole.'.'.$area;
3557: if ($trole =~ /^cr/) {
3558: &Apache::lonnet::custom_roleprivs(\%allroles,$trole,
3559: $tdom,$spec,$trest,$area);
3560: } else {
3561: &Apache::lonnet::standard_roleprivs(\%allroles,$trole,
3562: $tdom,$spec,$trest,$area);
3563: }
3564: my ($author,$adv) = &Apache::lonnet::set_userprivs(\%userroles,\%allroles);
1.486 raeburn 3565: if ($userroles{'user.priv.'.$checkrole} =~ /evb\&([^\:]*)/) {
3566: if ($1) {
3567: $no_userblock = 1;
3568: last;
3569: }
3570: }
1.490 raeburn 3571: } else {
3572: # Resource belongs to current user
3573: # Check for 'evb' priv via lonnet::allowed().
1.482 raeburn 3574: if (&Apache::lonnet::allowed('evb',undef,undef,$checkrole)) {
3575: $no_ownblock = 1;
3576: last;
3577: }
1.474 raeburn 3578: }
3579: }
3580: # if they have the evb priv and are currently not playing student
1.482 raeburn 3581: next if (($no_ownblock) &&
1.491 albertel 3582: ($env{'request.role'} !~ m{^st\./\Q$cdom\E/\Q$cnum\E}));
1.482 raeburn 3583: next if ($no_userblock);
1.474 raeburn 3584:
1.490 raeburn 3585: # Retrieve blocking times and identity of blocker for course
3586: # of specified user, unless user has 'evb' privilege.
1.502 raeburn 3587:
3588: my ($start,$end)=&get_blocks($setters,$activity,$cdom,$cnum);
3589: if (($start != 0) &&
3590: (($startblock == 0) || ($startblock > $start))) {
3591: $startblock = $start;
3592: }
3593: if (($end != 0) &&
3594: (($endblock == 0) || ($endblock < $end))) {
3595: $endblock = $end;
3596: }
1.490 raeburn 3597: }
3598: return ($startblock,$endblock);
3599: }
3600:
3601: sub get_blocks {
3602: my ($setters,$activity,$cdom,$cnum) = @_;
3603: my $startblock = 0;
3604: my $endblock = 0;
3605: my $course = $cdom.'_'.$cnum;
3606: $setters->{$course} = {};
3607: $setters->{$course}{'staff'} = [];
3608: $setters->{$course}{'times'} = [];
3609: my %records = &Apache::lonnet::dump('comm_block',$cdom,$cnum);
3610: foreach my $record (keys(%records)) {
3611: my ($start,$end) = ($record =~ m/^(\d+)____(\d+)$/);
3612: if ($start <= time && $end >= time) {
3613: my ($staff_name,$staff_dom,$title,$blocks) =
3614: &parse_block_record($records{$record});
3615: if ($blocks->{$activity} eq 'on') {
3616: push(@{$$setters{$course}{'staff'}},[$staff_name,$staff_dom]);
3617: push(@{$$setters{$course}{'times'}}, [$start,$end]);
1.491 albertel 3618: if ( ($startblock == 0) || ($startblock > $start) ) {
3619: $startblock = $start;
1.490 raeburn 3620: }
1.491 albertel 3621: if ( ($endblock == 0) || ($endblock < $end) ) {
3622: $endblock = $end;
1.474 raeburn 3623: }
3624: }
3625: }
3626: }
3627: return ($startblock,$endblock);
3628: }
3629:
3630: sub parse_block_record {
3631: my ($record) = @_;
3632: my ($setuname,$setudom,$title,$blocks);
3633: if (ref($record) eq 'HASH') {
3634: ($setuname,$setudom) = split(/:/,$record->{'setter'});
3635: $title = &unescape($record->{'event'});
3636: $blocks = $record->{'blocks'};
3637: } else {
3638: my @data = split(/:/,$record,3);
3639: if (scalar(@data) eq 2) {
3640: $title = $data[1];
3641: ($setuname,$setudom) = split(/@/,$data[0]);
3642: } else {
3643: ($setuname,$setudom,$title) = @data;
3644: }
3645: $blocks = { 'com' => 'on' };
3646: }
3647: return ($setuname,$setudom,$title,$blocks);
3648: }
3649:
3650: sub build_block_table {
3651: my ($startblock,$endblock,$setters) = @_;
3652: my %lt = &Apache::lonlocal::texthash(
3653: 'cacb' => 'Currently active communication blocks',
3654: 'cour' => 'Course',
3655: 'dura' => 'Duration',
3656: 'blse' => 'Block set by'
3657: );
3658: my $output;
1.476 raeburn 3659: $output = '<br />'.$lt{'cacb'}.':<br />';
1.474 raeburn 3660: $output .= &start_data_table();
3661: $output .= '
3662: <tr>
3663: <th>'.$lt{'cour'}.'</th>
3664: <th>'.$lt{'dura'}.'</th>
3665: <th>'.$lt{'blse'}.'</th>
3666: </tr>
3667: ';
3668: foreach my $course (keys(%{$setters})) {
3669: my %courseinfo=&Apache::lonnet::coursedescription($course);
3670: for (my $i=0; $i<@{$$setters{$course}{staff}}; $i++) {
3671: my ($uname,$udom) = @{$$setters{$course}{staff}[$i]};
1.490 raeburn 3672: my $fullname = &plainname($uname,$udom);
3673: if (defined($env{'user.name'}) && defined($env{'user.domain'})
3674: && $env{'user.name'} ne 'public'
3675: && $env{'user.domain'} ne 'public') {
3676: $fullname = &aboutmewrapper($fullname,$uname,$udom);
3677: }
1.474 raeburn 3678: my ($openblock,$closeblock) = @{$$setters{$course}{times}[$i]};
3679: $openblock = &Apache::lonlocal::locallocaltime($openblock);
3680: $closeblock= &Apache::lonlocal::locallocaltime($closeblock);
3681: $output .= &Apache::loncommon::start_data_table_row().
3682: '<td>'.$courseinfo{'description'}.'</td>'.
3683: '<td>'.$openblock.' to '.$closeblock.'</td>'.
1.490 raeburn 3684: '<td>'.$fullname.'</td>'.
1.474 raeburn 3685: &Apache::loncommon::end_data_table_row();
3686: }
3687: }
3688: $output .= &end_data_table();
3689: }
3690:
1.490 raeburn 3691: sub blocking_status {
3692: my ($activity,$uname,$udom) = @_;
3693: my %setters;
3694: my ($blocked,$output,$ownitem,$is_course);
3695: my ($startblock,$endblock)=&blockcheck(\%setters,$activity,$uname,$udom);
3696: if ($startblock && $endblock) {
3697: $blocked = 1;
3698: if (wantarray) {
3699: my $category;
3700: if ($activity eq 'boards') {
3701: $category = 'Discussion posts in this course';
3702: } elsif ($activity eq 'blogs') {
3703: $category = 'Blogs';
3704: } elsif ($activity eq 'port') {
3705: if (defined($uname) && defined($udom)) {
3706: if ($uname eq $env{'user.name'} &&
3707: $udom eq $env{'user.domain'}) {
3708: $ownitem = 1;
3709: }
3710: }
3711: $is_course = &Apache::lonnet::is_course($udom,$uname);
3712: if ($ownitem) {
3713: $category = 'Your portfolio files';
3714: } elsif ($is_course) {
3715: my $coursedesc;
3716: foreach my $course (keys(%setters)) {
3717: my %courseinfo =
3718: &Apache::lonnet::coursedescription($course);
3719: $coursedesc = $courseinfo{'description'};
3720: }
3721: $category = "Group files in the course '$coursedesc'";
3722: } else {
3723: $category = 'Portfolio files belonging to ';
3724: if ($env{'user.name'} eq 'public' &&
3725: $env{'user.domain'} eq 'public') {
3726: $category .= &plainname($uname,$udom);
3727: } else {
3728: $category .= &aboutmewrapper(&plainname($uname,$udom),$uname,$udom);
3729: }
3730: }
3731: } elsif ($activity eq 'groups') {
3732: $category = 'Groups in this course';
3733: }
3734: my $showstart = &Apache::lonlocal::locallocaltime($startblock);
3735: my $showend = &Apache::lonlocal::locallocaltime($endblock);
3736: $output = '<br />'.&mt('[_1] will be inaccessible between [_2] and [_3] because communication is being blocked.',$category,$showstart,$showend).'<br />';
3737: if (!($activity eq 'port' && !($ownitem) && !($is_course))) {
3738: $output .= &build_block_table($startblock,$endblock,\%setters);
3739: }
3740: }
3741: }
3742: if (wantarray) {
3743: return ($blocked,$output);
3744: } else {
3745: return $blocked;
3746: }
3747: }
3748:
1.60 matthew 3749: ###############################################
3750:
1.682 raeburn 3751: sub check_ip_acc {
3752: my ($acc)=@_;
3753: &Apache::lonxml::debug("acc is $acc");
3754: if (!defined($acc) || $acc =~ /^\s*$/ || $acc =~/^\s*no\s*$/i) {
3755: return 1;
3756: }
3757: my $allowed=0;
3758: my $ip=$env{'request.host'} || $ENV{'REMOTE_ADDR'};
3759:
3760: my $name;
3761: foreach my $pattern (split(',',$acc)) {
3762: $pattern =~ s/^\s*//;
3763: $pattern =~ s/\s*$//;
3764: if ($pattern =~ /\*$/) {
3765: #35.8.*
3766: $pattern=~s/\*//;
3767: if ($ip =~ /^\Q$pattern\E/) { $allowed=1; }
3768: } elsif ($pattern =~ /(\d+\.\d+\.\d+)\.\[(\d+)-(\d+)\]$/) {
3769: #35.8.3.[34-56]
3770: my $low=$2;
3771: my $high=$3;
3772: $pattern=$1;
3773: if ($ip =~ /^\Q$pattern\E/) {
3774: my $last=(split(/\./,$ip))[3];
3775: if ($last <=$high && $last >=$low) { $allowed=1; }
3776: }
3777: } elsif ($pattern =~ /^\*/) {
3778: #*.msu.edu
3779: $pattern=~s/\*//;
3780: if (!defined($name)) {
3781: use Socket;
3782: my $netaddr=inet_aton($ip);
3783: ($name)=gethostbyaddr($netaddr,AF_INET);
3784: }
3785: if ($name =~ /\Q$pattern\E$/i) { $allowed=1; }
3786: } elsif ($pattern =~ /\d+\.\d+\.\d+\.\d+/) {
3787: #127.0.0.1
3788: if ($ip =~ /^\Q$pattern\E/) { $allowed=1; }
3789: } else {
3790: #some.name.com
3791: if (!defined($name)) {
3792: use Socket;
3793: my $netaddr=inet_aton($ip);
3794: ($name)=gethostbyaddr($netaddr,AF_INET);
3795: }
3796: if ($name =~ /\Q$pattern\E$/i) { $allowed=1; }
3797: }
3798: if ($allowed) { last; }
3799: }
3800: return $allowed;
3801: }
3802:
3803: ###############################################
3804:
1.60 matthew 3805: =pod
3806:
1.112 bowersj2 3807: =head1 Domain Template Functions
3808:
3809: =over 4
3810:
3811: =item * &determinedomain()
1.60 matthew 3812:
3813: Inputs: $domain (usually will be undef)
3814:
1.63 www 3815: Returns: Determines which domain should be used for designs
1.60 matthew 3816:
3817: =cut
1.54 www 3818:
1.60 matthew 3819: ###############################################
1.63 www 3820: sub determinedomain {
3821: my $domain=shift;
1.531 albertel 3822: if (! $domain) {
1.60 matthew 3823: # Determine domain if we have not been given one
3824: $domain = $Apache::lonnet::perlvar{'lonDefDomain'};
1.258 albertel 3825: if ($env{'user.domain'}) { $domain=$env{'user.domain'}; }
3826: if ($env{'request.role.domain'}) {
3827: $domain=$env{'request.role.domain'};
1.60 matthew 3828: }
3829: }
1.63 www 3830: return $domain;
3831: }
3832: ###############################################
1.517 raeburn 3833:
1.518 albertel 3834: sub devalidate_domconfig_cache {
3835: my ($udom)=@_;
3836: &Apache::lonnet::devalidate_cache_new('domainconfig',$udom);
3837: }
3838:
3839: # ---------------------- Get domain configuration for a domain
3840: sub get_domainconf {
3841: my ($udom) = @_;
3842: my $cachetime=1800;
3843: my ($result,$cached)=&Apache::lonnet::is_cached_new('domainconfig',$udom);
3844: if (defined($cached)) { return %{$result}; }
3845:
3846: my %domconfig = &Apache::lonnet::get_dom('configuration',
3847: ['login','rolecolors'],$udom);
1.632 raeburn 3848: my (%designhash,%legacy);
1.518 albertel 3849: if (keys(%domconfig) > 0) {
3850: if (ref($domconfig{'login'}) eq 'HASH') {
1.632 raeburn 3851: if (keys(%{$domconfig{'login'}})) {
3852: foreach my $key (keys(%{$domconfig{'login'}})) {
3853: $designhash{$udom.'.login.'.$key}=$domconfig{'login'}{$key};
3854: }
3855: } else {
3856: $legacy{'login'} = 1;
1.518 albertel 3857: }
1.632 raeburn 3858: } else {
3859: $legacy{'login'} = 1;
1.518 albertel 3860: }
3861: if (ref($domconfig{'rolecolors'}) eq 'HASH') {
1.632 raeburn 3862: if (keys(%{$domconfig{'rolecolors'}})) {
3863: foreach my $role (keys(%{$domconfig{'rolecolors'}})) {
3864: if (ref($domconfig{'rolecolors'}{$role}) eq 'HASH') {
3865: foreach my $item (keys(%{$domconfig{'rolecolors'}{$role}})) {
3866: $designhash{$udom.'.'.$role.'.'.$item}=$domconfig{'rolecolors'}{$role}{$item};
3867: }
1.518 albertel 3868: }
3869: }
1.632 raeburn 3870: } else {
3871: $legacy{'rolecolors'} = 1;
1.518 albertel 3872: }
1.632 raeburn 3873: } else {
3874: $legacy{'rolecolors'} = 1;
1.518 albertel 3875: }
1.632 raeburn 3876: if (keys(%legacy) > 0) {
3877: my %legacyhash = &get_legacy_domconf($udom);
3878: foreach my $item (keys(%legacyhash)) {
3879: if ($item =~ /^\Q$udom\E\.login/) {
3880: if ($legacy{'login'}) {
3881: $designhash{$item} = $legacyhash{$item};
3882: }
3883: } else {
3884: if ($legacy{'rolecolors'}) {
3885: $designhash{$item} = $legacyhash{$item};
3886: }
1.518 albertel 3887: }
3888: }
3889: }
1.632 raeburn 3890: } else {
3891: %designhash = &get_legacy_domconf($udom);
1.518 albertel 3892: }
3893: &Apache::lonnet::do_cache_new('domainconfig',$udom,\%designhash,
3894: $cachetime);
3895: return %designhash;
3896: }
3897:
1.632 raeburn 3898: sub get_legacy_domconf {
3899: my ($udom) = @_;
3900: my %legacyhash;
3901: my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors';
3902: my $designfile = $designdir.'/'.$udom.'.tab';
3903: if (-e $designfile) {
3904: if ( open (my $fh,"<$designfile") ) {
3905: while (my $line = <$fh>) {
3906: next if ($line =~ /^\#/);
3907: chomp($line);
3908: my ($key,$val)=(split(/\=/,$line));
3909: if ($val) { $legacyhash{$udom.'.'.$key}=$val; }
3910: }
3911: close($fh);
3912: }
3913: }
3914: if (-e '/home/httpd/html/adm/lonDomLogos/'.$udom.'.gif') {
3915: $legacyhash{$udom.'.login.domlogo'} = "/adm/lonDomLogos/$udom.gif";
3916: }
3917: return %legacyhash;
3918: }
3919:
1.63 www 3920: =pod
3921:
1.112 bowersj2 3922: =item * &domainlogo()
1.63 www 3923:
3924: Inputs: $domain (usually will be undef)
3925:
3926: Returns: A link to a domain logo, if the domain logo exists.
3927: If the domain logo does not exist, a description of the domain.
3928:
3929: =cut
1.112 bowersj2 3930:
1.63 www 3931: ###############################################
3932: sub domainlogo {
1.517 raeburn 3933: my $domain = &determinedomain(shift);
1.518 albertel 3934: my %designhash = &get_domainconf($domain);
1.517 raeburn 3935: # See if there is a logo
3936: if ($designhash{$domain.'.login.domlogo'} ne '') {
1.519 raeburn 3937: my $imgsrc = $designhash{$domain.'.login.domlogo'};
1.538 albertel 3938: if ($imgsrc =~ m{^/(adm|res)/}) {
3939: if ($imgsrc =~ m{^/res/}) {
3940: my $local_name = &Apache::lonnet::filelocation('',$imgsrc);
3941: &Apache::lonnet::repcopy($local_name);
3942: }
3943: $imgsrc = &lonhttpdurl($imgsrc);
1.519 raeburn 3944: }
3945: return '<img src="'.$imgsrc.'" alt="'.$domain.'" />';
1.514 albertel 3946: } elsif (defined(&Apache::lonnet::domain($domain,'description'))) {
3947: return &Apache::lonnet::domain($domain,'description');
1.59 www 3948: } else {
1.60 matthew 3949: return '';
1.59 www 3950: }
3951: }
1.63 www 3952: ##############################################
3953:
3954: =pod
3955:
1.112 bowersj2 3956: =item * &designparm()
1.63 www 3957:
3958: Inputs: $which parameter; $domain (usually will be undef)
3959:
3960: Returns: value of designparamter $which
3961:
3962: =cut
1.112 bowersj2 3963:
1.397 albertel 3964:
1.400 albertel 3965: ##############################################
1.397 albertel 3966: sub designparm {
3967: my ($which,$domain)=@_;
1.258 albertel 3968: if ($env{'browser.blackwhite'} eq 'on') {
1.635 raeburn 3969: if ($which=~/\.(font|alink|vlink|link|textcol)$/) {
1.110 www 3970: return '#000000';
3971: }
1.635 raeburn 3972: if ($which=~/\.(pgbg|sidebg|bgcol)$/) {
1.110 www 3973: return '#FFFFFF';
3974: }
3975: if ($which=~/\.tabbg$/) {
3976: return '#CCCCCC';
3977: }
3978: }
1.397 albertel 3979: if (exists($env{'environment.color.'.$which})) {
1.258 albertel 3980: return $env{'environment.color.'.$which};
1.96 www 3981: }
1.63 www 3982: $domain=&determinedomain($domain);
1.518 albertel 3983: my %domdesign = &get_domainconf($domain);
1.520 raeburn 3984: my $output;
1.517 raeburn 3985: if ($domdesign{$domain.'.'.$which} ne '') {
1.520 raeburn 3986: $output = $domdesign{$domain.'.'.$which};
1.63 www 3987: } else {
1.520 raeburn 3988: $output = $defaultdesign{$which};
3989: }
3990: if (($which =~ /^(student|coordinator|author|admin)\.img$/) ||
1.635 raeburn 3991: ($which =~ /login\.(img|logo|domlogo|login)/)) {
1.538 albertel 3992: if ($output =~ m{^/(adm|res)/}) {
3993: if ($output =~ m{^/res/}) {
3994: my $local_name = &Apache::lonnet::filelocation('',$output);
3995: &Apache::lonnet::repcopy($local_name);
3996: }
1.520 raeburn 3997: $output = &lonhttpdurl($output);
3998: }
1.63 www 3999: }
1.520 raeburn 4000: return $output;
1.63 www 4001: }
1.59 www 4002:
1.60 matthew 4003: ###############################################
4004: ###############################################
4005:
4006: =pod
4007:
1.112 bowersj2 4008: =back
4009:
1.549 albertel 4010: =head1 HTML Helpers
1.112 bowersj2 4011:
4012: =over 4
4013:
4014: =item * &bodytag()
1.60 matthew 4015:
4016: Returns a uniform header for LON-CAPA web pages.
4017:
4018: Inputs:
4019:
1.112 bowersj2 4020: =over 4
4021:
4022: =item * $title, A title to be displayed on the page.
4023:
4024: =item * $function, the current role (can be undef).
4025:
4026: =item * $addentries, extra parameters for the <body> tag.
4027:
4028: =item * $bodyonly, if defined, only return the <body> tag.
4029:
4030: =item * $domain, if defined, force a given domain.
4031:
4032: =item * $forcereg, if page should register as content page (relevant for
1.86 www 4033: text interface only)
1.60 matthew 4034:
1.326 albertel 4035: =item * $customtitle, alternate text to use instead of $title
4036: in the title box that appears, this text
4037: is not auto translated like the $title is
1.309 albertel 4038:
4039: =item * $notopbar, if true, keep the 'what is this' info but remove the
4040: navigational links
1.317 albertel 4041:
1.338 albertel 4042: =item * $bgcolor, used to override the bgcolor on a webpage to a specific value
4043:
4044: =item * $notitle, if true keep the nav controls, but remove the title bar
4045:
1.361 albertel 4046: =item * $no_inline_link, if true and in remote mode, don't show the
4047: 'Switch To Inline Menu' link
4048:
1.460 albertel 4049: =item * $args, optional argument valid values are
4050: no_auto_mt_title -> prevents &mt()ing the title arg
1.562 albertel 4051: inherit_jsmath -> when creating popup window in a page,
4052: should it have jsmath forced on by the
4053: current page
1.460 albertel 4054:
1.112 bowersj2 4055: =back
4056:
1.60 matthew 4057: Returns: A uniform header for LON-CAPA web pages.
4058: If $bodyonly is nonzero, a string containing a <body> tag will be returned.
4059: If $bodyonly is undef or zero, an html string containing a <body> tag and
4060: other decorations will be returned.
4061:
4062: =cut
4063:
1.54 www 4064: sub bodytag {
1.309 albertel 4065: my ($title,$function,$addentries,$bodyonly,$domain,$forcereg,$customtitle,
1.460 albertel 4066: $notopbar,$bgcolor,$notitle,$no_inline_link,$args)=@_;
1.339 albertel 4067:
1.460 albertel 4068: if (!$args->{'no_auto_mt_title'}) { $title = &mt($title); }
1.339 albertel 4069:
1.183 matthew 4070: $function = &get_users_function() if (!$function);
1.339 albertel 4071: my $img = &designparm($function.'.img',$domain);
4072: my $font = &designparm($function.'.font',$domain);
4073: my $pgbg = $bgcolor || &designparm($function.'.pgbg',$domain);
4074:
4075: my %design = ( 'style' => 'margin-top: 0px',
1.535 albertel 4076: 'bgcolor' => $pgbg,
1.339 albertel 4077: 'text' => $font,
4078: 'alink' => &designparm($function.'.alink',$domain),
4079: 'vlink' => &designparm($function.'.vlink',$domain),
4080: 'link' => &designparm($function.'.link',$domain),);
1.438 albertel 4081: @design{keys(%$addentries)} = @$addentries{keys(%$addentries)};
1.339 albertel 4082:
1.63 www 4083: # role and realm
1.378 raeburn 4084: my ($role,$realm) = split(/\./,$env{'request.role'},2);
4085: if ($role eq 'ca') {
1.479 albertel 4086: my ($rdom,$rname) = ($realm =~ m{^/($match_domain)/($match_username)$});
1.500 albertel 4087: $realm = &plainname($rname,$rdom);
1.378 raeburn 4088: }
1.55 www 4089: # realm
1.258 albertel 4090: if ($env{'request.course.id'}) {
1.378 raeburn 4091: if ($env{'request.role'} !~ /^cr/) {
4092: $role = &Apache::lonnet::plaintext($role,&course_type());
4093: }
1.359 albertel 4094: $realm = $env{'course.'.$env{'request.course.id'}.'.description'};
1.378 raeburn 4095: } else {
4096: $role = &Apache::lonnet::plaintext($role);
1.54 www 4097: }
1.433 albertel 4098:
1.359 albertel 4099: if (!$realm) { $realm=' '; }
1.55 www 4100: # Set messages
1.60 matthew 4101: my $messages=&domainlogo($domain);
1.330 albertel 4102:
1.438 albertel 4103: my $extra_body_attr = &make_attr_string($forcereg,\%design);
1.329 albertel 4104:
1.101 www 4105: # construct main body tag
1.359 albertel 4106: my $bodytag = "<body $extra_body_attr>".
1.562 albertel 4107: &Apache::lontexconvert::init_math_support($args->{'inherit_jsmath'});
1.252 albertel 4108:
1.530 albertel 4109: if ($bodyonly) {
1.60 matthew 4110: return $bodytag;
1.258 albertel 4111: } elsif ($env{'browser.interface'} eq 'textual') {
1.95 www 4112: # Accessibility
1.224 raeburn 4113:
1.337 albertel 4114: $bodytag.=&Apache::lonmenu::menubuttons($forcereg,$forcereg);
1.338 albertel 4115: if (!$notitle) {
1.337 albertel 4116: $bodytag.='<h1>LON-CAPA: '.$title.'</h1>';
4117: }
4118: return $bodytag;
1.359 albertel 4119: }
4120:
1.410 albertel 4121: my $name = &plainname($env{'user.name'},$env{'user.domain'});
1.433 albertel 4122: if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
4123: undef($role);
1.434 albertel 4124: } else {
4125: $name = &aboutmewrapper($name,$env{'user.name'},$env{'user.domain'});
1.433 albertel 4126: }
1.359 albertel 4127:
4128: my $roleinfo=(<<ENDROLE);
4129: <td class="LC_title_bar_who">
4130: <div class="LC_title_bar_name">
1.410 albertel 4131: $name
1.361 albertel 4132:
1.359 albertel 4133: </div>
4134: <div class="LC_title_bar_role">
1.361 albertel 4135: $role
1.359 albertel 4136: </div>
4137: <div class="LC_title_bar_realm">
1.361 albertel 4138: $realm
1.359 albertel 4139: </div>
1.206 albertel 4140: </td>
4141: ENDROLE
1.235 raeburn 4142:
1.359 albertel 4143: my $titleinfo = '<span class="LC_title_bar_title">'.$title.'</span>';
4144: if ($customtitle) {
4145: $titleinfo = $customtitle;
4146: }
4147: #
4148: # Extra info if you are the DC
4149: my $dc_info = '';
4150: if ($env{'user.adv'} && exists($env{'user.role.dc./'.
4151: $env{'course.'.$env{'request.course.id'}.
4152: '.domain'}.'/'})) {
4153: my $cid = $env{'request.course.id'};
4154: $dc_info.= $cid.' '.$env{'course.'.$cid.'.internal.coursecode'};
1.380 www 4155: $dc_info =~ s/\s+$//;
1.359 albertel 4156: $dc_info = '('.$dc_info.')';
4157: }
4158:
1.644 www 4159: if (($env{'environment.remote'} eq 'off') || ($args->{'suppress_header_logos'})) {
1.359 albertel 4160: # No Remote
1.258 albertel 4161: if ($env{'request.state'} eq 'construct') {
1.359 albertel 4162: $forcereg=1;
4163: }
4164:
4165: if (!$customtitle && $env{'request.state'} eq 'construct') {
4166: # this is for resources; directories have customtitle, and crumbs
4167: # and select recent are created in lonpubdir.pm
1.229 albertel 4168: my ($uname,$thisdisfn)=
1.258 albertel 4169: ($env{'request.filename'} =~ m|^/home/([^/]+)/public_html/(.*)|);
1.229 albertel 4170: my $formaction='/priv/'.$uname.'/'.$thisdisfn;
4171: $formaction=~s/\/+/\//g;
4172:
1.359 albertel 4173: my $parentpath = '';
4174: my $lastitem = '';
4175: if ($thisdisfn =~ m-(.+/)([^/]*)$-) {
4176: $parentpath = $1;
4177: $lastitem = $2;
4178: } else {
4179: $lastitem = $thisdisfn;
4180: }
4181: $titleinfo =
1.640 bisitz 4182: &Apache::loncommon::help_open_menu('','',3,'Authoring')
4183: .'<b>'.&mt('Construction Space').'</b>: '
4184: .'<form name="dirs" method="post" action="'.$formaction
1.359 albertel 4185: .'" target="_top"><tt><b>'
4186: .&Apache::lonhtmlcommon::crumbs($uname.'/'.$parentpath,'_top','/priv','','+1',1)."<font size=\"+1\">$lastitem</font></b></tt><br />"
4187: .&Apache::lonhtmlcommon::select_recent('construct','recent','this.form.action=this.form.recent.value;this.form.submit()')
4188: .'</form>'
4189: .&Apache::lonmenu::constspaceform();
1.235 raeburn 4190: }
1.359 albertel 4191:
1.337 albertel 4192: my $titletable;
1.338 albertel 4193: if (!$notitle) {
1.337 albertel 4194: $titletable =
1.359 albertel 4195: '<table id="LC_title_bar">'.
4196: "<tr><td> $titleinfo $dc_info</td>".$roleinfo.
4197: '</tr></table>';
1.337 albertel 4198: }
1.359 albertel 4199: if ($notopbar) {
4200: $bodytag .= $titletable;
4201: } else {
4202: if ($env{'request.state'} eq 'construct') {
1.337 albertel 4203: $bodytag .= &Apache::lonmenu::menubuttons($forcereg,$forcereg,
4204: $titletable);
1.272 raeburn 4205: } else {
1.336 albertel 4206: $bodytag .= &Apache::lonmenu::menubuttons($forcereg,$forcereg).
1.359 albertel 4207: $titletable;
1.272 raeburn 4208: }
1.235 raeburn 4209: }
4210: return $bodytag;
1.94 www 4211: }
1.95 www 4212:
1.93 www 4213: #
1.95 www 4214: # Top frame rendering, Remote is up
1.93 www 4215: #
1.359 albertel 4216:
1.517 raeburn 4217: my $imgsrc = $img;
4218: if ($img =~ /^\/adm/) {
1.575 albertel 4219: $imgsrc = &lonhttpdurl($img);
1.517 raeburn 4220: }
4221: my $upperleft='<img src="'.$imgsrc.'" alt="'.$function.'" />';
1.359 albertel 4222:
1.305 www 4223: # Explicit link to get inline menu
1.361 albertel 4224: my $menu= ($no_inline_link?''
4225: :'<br /><a href="/adm/remote?action=collapse">'.&mt('Switch to Inline Menu Mode').'</a>');
1.245 matthew 4226: #
1.338 albertel 4227: if ($notitle) {
1.337 albertel 4228: return $bodytag;
4229: }
1.94 www 4230: return(<<ENDBODY);
1.60 matthew 4231: $bodytag
1.359 albertel 4232: <table id="LC_title_bar" class="LC_with_remote">
1.368 albertel 4233: <tr><td class="LC_title_bar_role_logo">$upperleft</td>
1.359 albertel 4234: <td class="LC_title_bar_domain_logo">$messages </td>
1.54 www 4235: </tr>
1.359 albertel 4236: <tr><td>$titleinfo $dc_info $menu</td>
4237: $roleinfo
1.368 albertel 4238: </tr>
1.356 albertel 4239: </table>
1.54 www 4240: ENDBODY
1.182 matthew 4241: }
4242:
1.330 albertel 4243: sub make_attr_string {
4244: my ($register,$attr_ref) = @_;
4245:
4246: if ($attr_ref && !ref($attr_ref)) {
4247: die("addentries Must be a hash ref ".
4248: join(':',caller(1))." ".
4249: join(':',caller(0))." ");
4250: }
4251:
4252: if ($register) {
1.339 albertel 4253: my ($on_load,$on_unload);
4254: foreach my $key (keys(%{$attr_ref})) {
4255: if (lc($key) eq 'onload') {
4256: $on_load.=$attr_ref->{$key}.';';
4257: delete($attr_ref->{$key});
4258:
4259: } elsif (lc($key) eq 'onunload') {
4260: $on_unload.=$attr_ref->{$key}.';';
4261: delete($attr_ref->{$key});
4262: }
4263: }
4264: $attr_ref->{'onload'} =
4265: &Apache::lonmenu::loadevents(). $on_load;
4266: $attr_ref->{'onunload'}=
4267: &Apache::lonmenu::unloadevents().$on_unload;
4268: }
4269:
4270: # Accessibility font enhance
4271: if ($env{'browser.fontenhance'} eq 'on') {
4272: my $style;
4273: foreach my $key (keys(%{$attr_ref})) {
4274: if (lc($key) eq 'style') {
4275: $style.=$attr_ref->{$key}.';';
4276: delete($attr_ref->{$key});
4277: }
4278: }
4279: $attr_ref->{'style'}=$style.'; font-size: x-large;';
1.330 albertel 4280: }
1.339 albertel 4281:
4282: if ($env{'browser.blackwhite'} eq 'on') {
4283: delete($attr_ref->{'font'});
4284: delete($attr_ref->{'link'});
4285: delete($attr_ref->{'alink'});
4286: delete($attr_ref->{'vlink'});
4287: delete($attr_ref->{'bgcolor'});
4288: delete($attr_ref->{'background'});
4289: }
4290:
1.330 albertel 4291: my $attr_string;
4292: foreach my $attr (keys(%$attr_ref)) {
4293: $attr_string .= " $attr=\"".$attr_ref->{$attr}.'" ';
4294: }
4295: return $attr_string;
4296: }
4297:
4298:
1.182 matthew 4299: ###############################################
1.251 albertel 4300: ###############################################
4301:
4302: =pod
4303:
4304: =item * &endbodytag()
4305:
4306: Returns a uniform footer for LON-CAPA web pages.
4307:
1.635 raeburn 4308: Inputs: 1 - optional reference to an args hash
4309: If in the hash, key for noredirectlink has a value which evaluates to true,
4310: a 'Continue' link is not displayed if the page contains an
4311: internal redirect in the <head></head> section,
4312: i.e., $env{'internal.head.redirect'} exists
1.251 albertel 4313:
4314: =cut
4315:
4316: sub endbodytag {
1.635 raeburn 4317: my ($args) = @_;
1.251 albertel 4318: my $endbodytag='</body>';
1.269 albertel 4319: $endbodytag=&Apache::lontexconvert::jsMath_process()."\n".$endbodytag;
1.315 albertel 4320: if ( exists( $env{'internal.head.redirect'} ) ) {
1.635 raeburn 4321: if (!(ref($args) eq 'HASH' && $args->{'noredirectlink'})) {
4322: $endbodytag=
4323: "<br /><a href=\"$env{'internal.head.redirect'}\">".
4324: &mt('Continue').'</a>'.
4325: $endbodytag;
4326: }
1.315 albertel 4327: }
1.251 albertel 4328: return $endbodytag;
4329: }
4330:
1.352 albertel 4331: =pod
4332:
4333: =item * &standard_css()
4334:
4335: Returns a style sheet
4336:
4337: Inputs: (all optional)
4338: domain -> force to color decorate a page for a specific
4339: domain
4340: function -> force usage of a specific rolish color scheme
4341: bgcolor -> override the default page bgcolor
4342:
4343: =cut
4344:
1.343 albertel 4345: sub standard_css {
1.345 albertel 4346: my ($function,$domain,$bgcolor) = @_;
1.352 albertel 4347: $function = &get_users_function() if (!$function);
4348: my $img = &designparm($function.'.img', $domain);
4349: my $tabbg = &designparm($function.'.tabbg', $domain);
4350: my $font = &designparm($function.'.font', $domain);
1.345 albertel 4351: my $sidebg = &designparm($function.'.sidebg',$domain);
1.382 albertel 4352: my $pgbg_or_bgcolor =
4353: $bgcolor ||
1.352 albertel 4354: &designparm($function.'.pgbg', $domain);
1.382 albertel 4355: my $pgbg = &designparm($function.'.pgbg', $domain);
1.352 albertel 4356: my $alink = &designparm($function.'.alink', $domain);
4357: my $vlink = &designparm($function.'.vlink', $domain);
4358: my $link = &designparm($function.'.link', $domain);
4359:
1.602 albertel 4360: my $sans = 'Verdana,Arial,Helvetica,sans-serif';
1.395 albertel 4361: my $mono = 'monospace';
1.352 albertel 4362: my $data_table_head = $tabbg;
4363: my $data_table_light = '#EEEEEE';
1.470 banghart 4364: my $data_table_dark = '#DDDDDD';
4365: my $data_table_darker = '#CCCCCC';
1.349 albertel 4366: my $data_table_highlight = '#FFFF00';
1.352 albertel 4367: my $mail_new = '#FFBB77';
4368: my $mail_new_hover = '#DD9955';
4369: my $mail_read = '#BBBB77';
4370: my $mail_read_hover = '#999944';
4371: my $mail_replied = '#AAAA88';
4372: my $mail_replied_hover = '#888855';
4373: my $mail_other = '#99BBBB';
4374: my $mail_other_hover = '#669999';
1.391 albertel 4375: my $table_header = '#DDDDDD';
1.489 raeburn 4376: my $feedback_link_bg = '#BBBBBB';
1.392 albertel 4377:
1.608 albertel 4378: my $border = ($env{'browser.type'} eq 'explorer' ||
4379: $env{'browser.type'} eq 'safari' ) ? '0px 2px 0px 2px'
4380: : '0px 3px 0px 4px';
1.448 albertel 4381:
1.523 albertel 4382:
1.343 albertel 4383: return <<END;
1.345 albertel 4384: h1, h2, h3, th { font-family: $sans }
1.343 albertel 4385: a:focus { color: red; background: yellow }
1.510 albertel 4386: table.thinborder,
1.523 albertel 4387:
1.510 albertel 4388: table.thinborder tr th {
4389: border-style: solid;
4390: border-width: 1px;
4391: background: $tabbg;
4392: }
1.523 albertel 4393: table.thinborder tr td {
1.510 albertel 4394: border-style: solid;
4395: border-width: 1px
4396: }
1.426 albertel 4397:
1.343 albertel 4398: form, .inline { display: inline; }
4399: .center { text-align: center; }
1.593 albertel 4400: .LC_filename {font-family: $mono; white-space:pre;}
1.350 albertel 4401: .LC_error {
4402: color: red;
4403: font-size: larger;
4404: }
1.457 albertel 4405: .LC_warning,
4406: .LC_diff_removed {
1.394 albertel 4407: color: red;
4408: }
1.532 albertel 4409:
4410: .LC_info,
1.457 albertel 4411: .LC_success,
4412: .LC_diff_added {
1.350 albertel 4413: color: green;
4414: }
1.543 albertel 4415: .LC_unknown {
4416: color: yellow;
4417: }
4418:
1.440 albertel 4419: .LC_icon {
4420: border: 0px;
4421: }
1.539 albertel 4422: .LC_indexer_icon {
4423: border: 0px;
4424: height: 22px;
4425: }
1.543 albertel 4426: .LC_docs_spacer {
4427: width: 25px;
4428: height: 1px;
4429: border: 0px;
4430: }
1.346 albertel 4431:
1.532 albertel 4432: .LC_internal_info {
4433: color: #999;
4434: }
4435:
1.458 albertel 4436: table.LC_pastsubmission {
4437: border: 1px solid black;
4438: margin: 2px;
4439: }
4440:
1.606 albertel 4441: table#LC_top_nav, table#LC_menubuttons,table#LC_nav_location {
1.345 albertel 4442: width: 100%;
4443: background: $pgbg;
1.392 albertel 4444: border: 2px;
1.402 albertel 4445: border-collapse: separate;
1.403 albertel 4446: padding: 0px;
1.345 albertel 4447: }
1.392 albertel 4448:
1.606 albertel 4449: table#LC_title_bar, table.LC_breadcrumbs,
1.393 albertel 4450: table#LC_title_bar.LC_with_remote {
1.359 albertel 4451: width: 100%;
1.392 albertel 4452: border-color: $pgbg;
4453: border-style: solid;
4454: border-width: $border;
4455:
1.379 albertel 4456: background: $pgbg;
4457: font-family: $sans;
1.392 albertel 4458: border-collapse: collapse;
1.403 albertel 4459: padding: 0px;
1.359 albertel 4460: }
1.392 albertel 4461:
1.409 albertel 4462: table.LC_docs_path {
4463: width: 100%;
4464: border: 0;
4465: background: $pgbg;
4466: font-family: $sans;
4467: border-collapse: collapse;
4468: padding: 0px;
4469: }
4470:
1.359 albertel 4471: table#LC_title_bar td {
4472: background: $tabbg;
4473: }
4474: table#LC_title_bar td.LC_title_bar_who {
4475: background: $tabbg;
4476: color: $font;
1.427 albertel 4477: font: small $sans;
1.359 albertel 4478: text-align: right;
4479: }
1.469 banghart 4480: span.LC_metadata {
4481: font-family: $sans;
4482: }
1.359 albertel 4483: span.LC_title_bar_title {
1.416 albertel 4484: font: bold x-large $sans;
1.359 albertel 4485: }
4486: table#LC_title_bar td.LC_title_bar_domain_logo {
4487: background: $sidebg;
4488: text-align: right;
1.368 albertel 4489: padding: 0px;
4490: }
4491: table#LC_title_bar td.LC_title_bar_role_logo {
4492: background: $sidebg;
4493: padding: 0px;
1.359 albertel 4494: }
4495:
1.346 albertel 4496: table#LC_menubuttons_mainmenu {
1.526 www 4497: width: 100%;
1.346 albertel 4498: border: 0px;
4499: border-spacing: 1px;
1.372 albertel 4500: padding: 0px 1px;
1.346 albertel 4501: margin: 0px;
4502: border-collapse: separate;
4503: }
4504: table#LC_menubuttons img, table#LC_menubuttons_mainmenu img {
4505: border: 0px;
4506: }
1.345 albertel 4507: table#LC_top_nav td {
4508: background: $tabbg;
1.392 albertel 4509: border: 0px;
1.407 albertel 4510: font-size: small;
1.345 albertel 4511: }
4512: table#LC_top_nav td a, div#LC_top_nav a {
4513: color: $font;
4514: font-family: $sans;
4515: }
1.364 albertel 4516: table#LC_top_nav td.LC_top_nav_logo {
4517: background: $tabbg;
1.432 albertel 4518: text-align: left;
1.408 albertel 4519: white-space: nowrap;
1.432 albertel 4520: width: 31px;
1.408 albertel 4521: }
4522: table#LC_top_nav td.LC_top_nav_logo img {
1.432 albertel 4523: border: 0px;
1.408 albertel 4524: vertical-align: bottom;
1.364 albertel 4525: }
1.432 albertel 4526: table#LC_top_nav td.LC_top_nav_exit,
4527: table#LC_top_nav td.LC_top_nav_help {
4528: width: 2.0em;
4529: }
1.442 albertel 4530: table#LC_top_nav td.LC_top_nav_login {
4531: width: 4.0em;
4532: text-align: center;
4533: }
1.409 albertel 4534: table.LC_breadcrumbs td, table.LC_docs_path td {
1.357 albertel 4535: background: $tabbg;
4536: color: $font;
4537: font-family: $sans;
1.358 albertel 4538: font-size: smaller;
1.357 albertel 4539: }
1.411 albertel 4540: table.LC_breadcrumbs td.LC_breadcrumbs_component,
1.409 albertel 4541: table.LC_docs_path td.LC_docs_path_component {
1.357 albertel 4542: background: $tabbg;
4543: color: $font;
4544: font-family: $sans;
4545: font-size: larger;
4546: text-align: right;
4547: }
1.383 albertel 4548: td.LC_table_cell_checkbox {
4549: text-align: center;
4550: }
1.522 albertel 4551: table#LC_mainmenu td.LC_mainmenu_column {
4552: vertical-align: top;
4553: }
4554:
1.346 albertel 4555: .LC_menubuttons_inline_text {
4556: color: $font;
4557: font-family: $sans;
4558: font-size: smaller;
4559: }
4560:
1.526 www 4561: .LC_menubuttons_link {
4562: text-decoration: none;
4563: }
1.680 riegler 4564: #2008--9-5: new menu style sheet.Changed category
1.522 albertel 4565: .LC_menubuttons_category {
1.521 www 4566: color: $font;
1.526 www 4567: background: $pgbg;
1.521 www 4568: font-family: $sans;
4569: font-size: larger;
4570: font-weight: bold;
4571: }
4572:
1.346 albertel 4573: td.LC_menubuttons_text {
1.526 www 4574: width: 90%;
1.346 albertel 4575: color: $font;
4576: font-family: $sans;
4577: }
1.526 www 4578:
1.346 albertel 4579: td.LC_menubuttons_img {
4580: }
1.526 www 4581:
1.346 albertel 4582: .LC_current_location {
4583: font-family: $sans;
4584: background: $tabbg;
4585: }
4586: .LC_new_mail {
4587: font-family: $sans;
1.634 www 4588: background: $tabbg;
1.346 albertel 4589: font-weight: bold;
4590: }
1.347 albertel 4591:
1.526 www 4592: .LC_rolesmenu_is {
4593: font-family: $sans;
4594: }
4595:
4596: .LC_rolesmenu_selected {
4597: font-family: $sans;
4598: }
4599:
4600: .LC_rolesmenu_future {
4601: font-family: $sans;
4602: }
4603:
4604:
4605: .LC_rolesmenu_will {
4606: font-family: $sans;
4607: }
4608:
4609: .LC_rolesmenu_will_not {
4610: font-family: $sans;
4611: }
4612:
4613: .LC_rolesmenu_expired {
4614: font-family: $sans;
4615: }
4616:
4617: .LC_rolesinfo {
4618: font-family: $sans;
4619: }
4620:
1.527 www 4621: .LC_dropadd_labeltext {
4622: font-family: $sans;
4623: text-align: right;
4624: }
4625:
4626: .LC_preferences_labeltext {
4627: font-family: $sans;
4628: text-align: right;
4629: }
4630:
1.666 raeburn 4631: .LC_roleslog_note {
4632: font-size: smaller;
4633: }
4634:
1.440 albertel 4635: table.LC_aboutme_port {
4636: border: 0px;
4637: border-collapse: collapse;
4638: border-spacing: 0px;
4639: }
1.349 albertel 4640: table.LC_data_table, table.LC_mail_list {
1.347 albertel 4641: border: 1px solid #000000;
1.402 albertel 4642: border-collapse: separate;
1.426 albertel 4643: border-spacing: 1px;
1.610 albertel 4644: background: $pgbg;
1.347 albertel 4645: }
1.422 albertel 4646: .LC_data_table_dense {
4647: font-size: small;
4648: }
1.507 raeburn 4649: table.LC_nested_outer {
4650: border: 1px solid #000000;
1.589 raeburn 4651: border-collapse: collapse;
1.507 raeburn 4652: border-spacing: 0px;
4653: width: 100%;
4654: }
4655: table.LC_nested {
4656: border: 0px;
1.589 raeburn 4657: border-collapse: collapse;
1.507 raeburn 4658: border-spacing: 0px;
4659: width: 100%;
4660: }
1.523 albertel 4661: table.LC_data_table tr th, table.LC_calendar tr th, table.LC_mail_list tr th,
4662: table.LC_prior_tries tr th {
1.349 albertel 4663: font-weight: bold;
4664: background-color: $data_table_head;
1.421 albertel 4665: font-size: smaller;
1.347 albertel 4666: }
1.610 albertel 4667: table.LC_data_table tr.LC_odd_row > td,
1.440 albertel 4668: table.LC_aboutme_port tr td {
1.349 albertel 4669: background-color: $data_table_light;
1.425 albertel 4670: padding: 2px;
1.347 albertel 4671: }
1.610 albertel 4672: table.LC_data_table tr.LC_even_row > td,
1.440 albertel 4673: table.LC_aboutme_port tr.LC_even_row td {
1.349 albertel 4674: background-color: $data_table_dark;
1.347 albertel 4675: }
1.425 albertel 4676: table.LC_data_table tr.LC_data_table_highlight td {
4677: background-color: $data_table_darker;
4678: }
1.639 raeburn 4679: table.LC_data_table tr td.LC_leftcol_header {
4680: background-color: $data_table_head;
4681: font-weight: bold;
4682: }
1.451 albertel 4683: table.LC_data_table tr.LC_empty_row td,
1.507 raeburn 4684: table.LC_nested tr.LC_empty_row td {
1.347 albertel 4685: background-color: #FFFFFF;
1.421 albertel 4686: font-weight: bold;
4687: font-style: italic;
4688: text-align: center;
4689: padding: 8px;
1.347 albertel 4690: }
1.507 raeburn 4691: table.LC_nested tr.LC_empty_row td {
1.465 albertel 4692: padding: 4ex
4693: }
1.507 raeburn 4694: table.LC_nested_outer tr th {
4695: font-weight: bold;
4696: background-color: $data_table_head;
4697: font-size: smaller;
4698: border-bottom: 1px solid #000000;
4699: }
4700: table.LC_nested_outer tr td.LC_subheader {
4701: background-color: $data_table_head;
4702: font-weight: bold;
4703: font-size: small;
4704: border-bottom: 1px solid #000000;
4705: text-align: right;
1.451 albertel 4706: }
1.507 raeburn 4707: table.LC_nested tr.LC_info_row td {
1.451 albertel 4708: background-color: #CCC;
4709: font-weight: bold;
4710: font-size: small;
1.507 raeburn 4711: text-align: center;
4712: }
1.589 raeburn 4713: table.LC_nested tr.LC_info_row td.LC_left_item,
4714: table.LC_nested_outer tr th.LC_left_item {
1.507 raeburn 4715: text-align: left;
1.451 albertel 4716: }
1.507 raeburn 4717: table.LC_nested td {
1.451 albertel 4718: background-color: #FFF;
4719: font-size: small;
1.507 raeburn 4720: }
4721: table.LC_nested_outer tr th.LC_right_item,
4722: table.LC_nested tr.LC_info_row td.LC_right_item,
4723: table.LC_nested tr.LC_odd_row td.LC_right_item,
4724: table.LC_nested tr td.LC_right_item {
1.451 albertel 4725: text-align: right;
4726: }
4727:
1.507 raeburn 4728: table.LC_nested tr.LC_odd_row td {
1.451 albertel 4729: background-color: #EEE;
4730: }
4731:
1.473 raeburn 4732: table.LC_createuser {
4733: }
4734:
4735: table.LC_createuser tr.LC_section_row td {
4736: font-size: smaller;
4737: }
4738:
4739: table.LC_createuser tr.LC_info_row td {
4740: background-color: #CCC;
4741: font-weight: bold;
4742: text-align: center;
4743: }
4744:
1.349 albertel 4745: table.LC_calendar {
4746: border: 1px solid #000000;
4747: border-collapse: collapse;
4748: }
4749: table.LC_calendar_pickdate {
4750: font-size: xx-small;
4751: }
4752: table.LC_calendar tr td {
4753: border: 1px solid #000000;
4754: vertical-align: top;
4755: }
4756: table.LC_calendar tr td.LC_calendar_day_empty {
4757: background-color: $data_table_dark;
4758: }
4759: table.LC_calendar tr td.LC_calendar_day_current {
4760: background-color: $data_table_highlight;
4761: }
4762:
4763: table.LC_mail_list tr.LC_mail_new {
4764: background-color: $mail_new;
4765: }
4766: table.LC_mail_list tr.LC_mail_new:hover {
4767: background-color: $mail_new_hover;
4768: }
4769: table.LC_mail_list tr.LC_mail_read {
4770: background-color: $mail_read;
4771: }
4772: table.LC_mail_list tr.LC_mail_read:hover {
4773: background-color: $mail_read_hover;
4774: }
4775: table.LC_mail_list tr.LC_mail_replied {
4776: background-color: $mail_replied;
4777: }
4778: table.LC_mail_list tr.LC_mail_replied:hover {
4779: background-color: $mail_replied_hover;
4780: }
4781: table.LC_mail_list tr.LC_mail_other {
4782: background-color: $mail_other;
4783: }
4784: table.LC_mail_list tr.LC_mail_other:hover {
4785: background-color: $mail_other_hover;
4786: }
1.494 raeburn 4787: table.LC_mail_list tr.LC_mail_even {
4788: }
4789: table.LC_mail_list tr.LC_mail_odd {
4790: }
4791:
1.385 albertel 4792:
1.386 albertel 4793: table#LC_portfolio_actions {
4794: width: auto;
4795: background: $pgbg;
4796: border: 0px;
4797: border-spacing: 2px 2px;
4798: padding: 0px;
4799: margin: 0px;
4800: border-collapse: separate;
4801: }
4802: table#LC_portfolio_actions td.LC_label {
4803: background: $tabbg;
4804: text-align: right;
4805: }
4806: table#LC_portfolio_actions td.LC_value {
4807: background: $tabbg;
4808: }
1.385 albertel 4809:
1.391 albertel 4810: table#LC_cstr_controls {
4811: width: 100%;
4812: border-collapse: collapse;
4813: }
4814: table#LC_cstr_controls tr td {
4815: border: 4px solid $pgbg;
4816: padding: 4px;
4817: text-align: center;
4818: background: $tabbg;
4819: }
4820: table#LC_cstr_controls tr th {
4821: border: 4px solid $pgbg;
4822: background: $table_header;
4823: text-align: center;
4824: font-family: $sans;
4825: font-size: smaller;
4826: }
4827:
1.389 albertel 4828: table#LC_browser {
4829:
4830: }
4831: table#LC_browser tr th {
1.391 albertel 4832: background: $table_header;
1.389 albertel 4833: }
1.390 albertel 4834: table#LC_browser tr td {
4835: padding: 2px;
4836: }
1.389 albertel 4837: table#LC_browser tr.LC_browser_file,
4838: table#LC_browser tr.LC_browser_file_published {
4839: background: #CCFF88;
4840: }
4841: table#LC_browser tr.LC_browser_file_locked,
4842: table#LC_browser tr.LC_browser_file_unpublished {
4843: background: #FFAA99;
1.387 albertel 4844: }
1.389 albertel 4845: table#LC_browser tr.LC_browser_file_obsolete {
4846: background: #AAAAAA;
1.387 albertel 4847: }
1.455 albertel 4848: table#LC_browser tr.LC_browser_file_modified,
4849: table#LC_browser tr.LC_browser_file_metamodified {
1.389 albertel 4850: background: #FFFF77;
1.387 albertel 4851: }
1.389 albertel 4852: table#LC_browser tr.LC_browser_folder {
4853: background: #CCCCFF;
1.387 albertel 4854: }
1.388 albertel 4855: span.LC_current_location {
4856: font-size: x-large;
4857: background: $pgbg;
4858: }
1.387 albertel 4859:
1.395 albertel 4860: span.LC_parm_menu_item {
4861: font-size: larger;
4862: font-family: $sans;
4863: }
4864: span.LC_parm_scope_all {
4865: color: red;
4866: }
4867: span.LC_parm_scope_folder {
4868: color: green;
4869: }
4870: span.LC_parm_scope_resource {
4871: color: orange;
4872: }
4873: span.LC_parm_part {
4874: color: blue;
4875: }
4876: span.LC_parm_folder, span.LC_parm_symb {
4877: font-size: x-small;
4878: font-family: $mono;
4879: color: #AAAAAA;
4880: }
4881:
1.396 albertel 4882: td.LC_parm_overview_level_menu, td.LC_parm_overview_map_menu,
4883: td.LC_parm_overview_parm_selectors, td.LC_parm_overview_parm_restrictions {
4884: border: 1px solid black;
4885: border-collapse: collapse;
4886: }
4887: table.LC_parm_overview_restrictions td {
4888: border-width: 1px 4px 1px 4px;
4889: border-style: solid;
4890: border-color: $pgbg;
4891: text-align: center;
4892: }
4893: table.LC_parm_overview_restrictions th {
4894: background: $tabbg;
4895: border-width: 1px 4px 1px 4px;
4896: border-style: solid;
4897: border-color: $pgbg;
4898: }
1.398 albertel 4899: table#LC_helpmenu {
4900: border: 0px;
4901: height: 55px;
4902: border-spacing: 0px;
4903: }
4904:
4905: table#LC_helpmenu fieldset legend {
4906: font-size: larger;
4907: font-weight: bold;
4908: }
1.397 albertel 4909: table#LC_helpmenu_links {
4910: width: 100%;
4911: border: 1px solid black;
4912: background: $pgbg;
4913: padding: 0px;
4914: border-spacing: 1px;
4915: }
4916: table#LC_helpmenu_links tr td {
4917: padding: 1px;
4918: background: $tabbg;
1.399 albertel 4919: text-align: center;
4920: font-weight: bold;
1.397 albertel 4921: }
1.396 albertel 4922:
1.397 albertel 4923: table#LC_helpmenu_links a:link, table#LC_helpmenu_links a:visited,
4924: table#LC_helpmenu_links a:active {
4925: text-decoration: none;
4926: color: $font;
4927: }
4928: table#LC_helpmenu_links a:hover {
4929: text-decoration: underline;
4930: color: $vlink;
4931: }
1.396 albertel 4932:
1.417 albertel 4933: .LC_chrt_popup_exists {
4934: border: 1px solid #339933;
4935: margin: -1px;
4936: }
4937: .LC_chrt_popup_up {
4938: border: 1px solid yellow;
4939: margin: -1px;
4940: }
4941: .LC_chrt_popup {
4942: border: 1px solid #8888FF;
4943: background: #CCCCFF;
4944: }
1.421 albertel 4945: table.LC_pick_box {
4946: border-collapse: separate;
4947: background: white;
4948: border: 1px solid black;
4949: border-spacing: 1px;
4950: }
4951: table.LC_pick_box td.LC_pick_box_title {
4952: background: $tabbg;
4953: font-weight: bold;
4954: text-align: right;
4955: width: 184px;
4956: padding: 8px;
4957: }
1.645 raeburn 4958: table.LC_pick_box td.LC_selfenroll_pick_box_title {
4959: background: $tabbg;
4960: font-weight: bold;
4961: text-align: right;
4962: width: 350px;
4963: padding: 8px;
4964: }
4965:
1.579 raeburn 4966: table.LC_pick_box td.LC_pick_box_value {
4967: text-align: left;
4968: padding: 8px;
4969: }
4970: table.LC_pick_box td.LC_pick_box_select {
4971: text-align: left;
4972: padding: 8px;
4973: }
1.424 albertel 4974: table.LC_pick_box td.LC_pick_box_separator {
1.421 albertel 4975: padding: 0px;
4976: height: 1px;
4977: background: black;
4978: }
4979: table.LC_pick_box td.LC_pick_box_submit {
4980: text-align: right;
4981: }
1.579 raeburn 4982: table.LC_pick_box td.LC_evenrow_value {
4983: text-align: left;
4984: padding: 8px;
4985: background-color: $data_table_light;
4986: }
4987: table.LC_pick_box td.LC_oddrow_value {
4988: text-align: left;
4989: padding: 8px;
4990: background-color: $data_table_light;
4991: }
4992: table.LC_helpform_receipt {
4993: width: 620px;
4994: border-collapse: separate;
4995: background: white;
4996: border: 1px solid black;
4997: border-spacing: 1px;
4998: }
4999: table.LC_helpform_receipt td.LC_pick_box_title {
5000: background: $tabbg;
5001: font-weight: bold;
5002: text-align: right;
5003: width: 184px;
5004: padding: 8px;
5005: }
5006: table.LC_helpform_receipt td.LC_evenrow_value {
5007: text-align: left;
5008: padding: 8px;
5009: background-color: $data_table_light;
5010: }
5011: table.LC_helpform_receipt td.LC_oddrow_value {
5012: text-align: left;
5013: padding: 8px;
5014: background-color: $data_table_light;
5015: }
5016: table.LC_helpform_receipt td.LC_pick_box_separator {
5017: padding: 0px;
5018: height: 1px;
5019: background: black;
5020: }
5021: span.LC_helpform_receipt_cat {
5022: font-weight: bold;
5023: }
1.424 albertel 5024: table.LC_group_priv_box {
5025: background: white;
5026: border: 1px solid black;
5027: border-spacing: 1px;
5028: }
5029: table.LC_group_priv_box td.LC_pick_box_title {
5030: background: $tabbg;
5031: font-weight: bold;
5032: text-align: right;
5033: width: 184px;
5034: }
5035: table.LC_group_priv_box td.LC_groups_fixed {
5036: background: $data_table_light;
5037: text-align: center;
5038: }
5039: table.LC_group_priv_box td.LC_groups_optional {
5040: background: $data_table_dark;
5041: text-align: center;
5042: }
5043: table.LC_group_priv_box td.LC_groups_functionality {
5044: background: $data_table_darker;
5045: text-align: center;
5046: font-weight: bold;
5047: }
5048: table.LC_group_priv td {
5049: text-align: left;
5050: padding: 0px;
5051: }
5052:
1.421 albertel 5053: table.LC_notify_front_page {
5054: background: white;
5055: border: 1px solid black;
5056: padding: 8px;
5057: }
5058: table.LC_notify_front_page td {
5059: padding: 8px;
5060: }
1.424 albertel 5061: .LC_navbuttons {
5062: margin: 2ex 0ex 2ex 0ex;
5063: }
1.423 albertel 5064: .LC_topic_bar {
5065: font-family: $sans;
5066: font-weight: bold;
5067: width: 100%;
5068: background: $tabbg;
5069: vertical-align: middle;
5070: margin: 2ex 0ex 2ex 0ex;
5071: }
5072: .LC_topic_bar span {
5073: vertical-align: middle;
5074: }
5075: .LC_topic_bar img {
5076: vertical-align: bottom;
5077: }
5078: table.LC_course_group_status {
5079: margin: 20px;
5080: }
5081: table.LC_status_selector td {
5082: vertical-align: top;
5083: text-align: center;
1.424 albertel 5084: padding: 4px;
5085: }
5086: table.LC_descriptive_input td.LC_description {
5087: vertical-align: top;
5088: text-align: right;
5089: font-weight: bold;
1.423 albertel 5090: }
1.599 albertel 5091: div.LC_feedback_link {
1.616 albertel 5092: clear: both;
1.599 albertel 5093: background: white;
5094: width: 100%;
1.489 raeburn 5095: }
5096: span.LC_feedback_link {
1.599 albertel 5097: background: $feedback_link_bg;
5098: font-size: larger;
5099: }
5100: span.LC_message_link {
5101: background: $feedback_link_bg;
5102: font-size: larger;
5103: position: absolute;
5104: right: 1em;
1.489 raeburn 5105: }
1.421 albertel 5106:
1.515 albertel 5107: table.LC_prior_tries {
1.524 albertel 5108: border: 1px solid #000000;
5109: border-collapse: separate;
5110: border-spacing: 1px;
1.515 albertel 5111: }
1.523 albertel 5112:
1.515 albertel 5113: table.LC_prior_tries td {
1.524 albertel 5114: padding: 2px;
1.515 albertel 5115: }
1.523 albertel 5116:
5117: .LC_answer_correct {
5118: background: #AAFFAA;
5119: color: black;
5120: }
5121: .LC_answer_charged_try {
5122: background: #FFAAAA ! important;
5123: color: black;
5124: }
5125: .LC_answer_not_charged_try,
5126: .LC_answer_no_grade,
5127: .LC_answer_late {
5128: background: #FFFFAA;
5129: color: black;
5130: }
5131: .LC_answer_previous {
5132: background: #AAAAFF;
5133: color: black;
5134: }
5135: .LC_answer_no_message {
5136: background: #FFFFFF;
5137: color: black;
5138: }
5139: .LC_answer_unknown {
5140: background: orange;
5141: color: black;
5142: }
5143:
5144:
1.529 albertel 5145: span.LC_prior_numerical,
5146: span.LC_prior_string,
5147: span.LC_prior_custom,
5148: span.LC_prior_reaction,
5149: span.LC_prior_math {
1.523 albertel 5150: font-family: monospace;
5151: white-space: pre;
5152: }
5153:
1.525 albertel 5154: span.LC_prior_string {
5155: font-family: monospace;
5156: white-space: pre;
5157: }
5158:
1.523 albertel 5159: table.LC_prior_option {
5160: width: 100%;
5161: border-collapse: collapse;
5162: }
1.528 albertel 5163: table.LC_prior_rank, table.LC_prior_match {
5164: border-collapse: collapse;
5165: }
5166: table.LC_prior_option tr td,
5167: table.LC_prior_rank tr td,
5168: table.LC_prior_match tr td {
1.524 albertel 5169: border: 1px solid #000000;
1.515 albertel 5170: }
5171:
1.519 raeburn 5172: span.LC_nobreak {
1.544 albertel 5173: white-space: nowrap;
1.519 raeburn 5174: }
5175:
1.576 raeburn 5176: span.LC_cusr_emph {
5177: font-style: italic;
5178: }
5179:
1.633 raeburn 5180: span.LC_cusr_subheading {
5181: font-weight: normal;
5182: font-size: 85%;
5183: }
5184:
1.545 albertel 5185: table.LC_docs_documents {
5186: background: #BBBBBB;
1.547 albertel 5187: border-width: 0px;
1.545 albertel 5188: border-collapse: collapse;
5189: }
5190:
5191: table.LC_docs_documents td.LC_docs_document {
5192: border: 2px solid black;
5193: padding: 4px;
5194: }
5195:
5196: .LC_docs_course_commands div {
5197: float: left;
5198: border: 4px solid #AAAAAA;
5199: padding: 4px;
5200: background: #DDDDCC;
5201: }
5202:
5203: .LC_docs_entry_move {
5204: border: 0px;
5205: border-collapse: collapse;
1.544 albertel 5206: }
5207:
1.545 albertel 5208: .LC_docs_entry_move td {
5209: border: 2px solid #BBBBBB;
5210: background: #DDDDDD;
5211: }
5212:
5213: .LC_docs_editor td.LC_docs_entry_commands {
5214: background: #DDDDDD;
5215: font-size: x-small;
5216: }
1.544 albertel 5217: .LC_docs_copy {
1.545 albertel 5218: color: #000099;
1.544 albertel 5219: }
5220: .LC_docs_cut {
1.545 albertel 5221: color: #550044;
1.544 albertel 5222: }
5223: .LC_docs_rename {
1.545 albertel 5224: color: #009900;
1.544 albertel 5225: }
5226: .LC_docs_remove {
1.545 albertel 5227: color: #990000;
5228: }
5229:
1.547 albertel 5230: .LC_docs_reinit_warn,
5231: .LC_docs_ext_edit {
5232: font-size: x-small;
5233: }
5234:
1.545 albertel 5235: .LC_docs_editor td.LC_docs_entry_title,
5236: .LC_docs_editor td.LC_docs_entry_icon {
5237: background: #FFFFBB;
5238: }
5239: .LC_docs_editor td.LC_docs_entry_parameter {
5240: background: #BBBBFF;
5241: font-size: x-small;
5242: white-space: nowrap;
5243: }
5244:
5245: table.LC_docs_adddocs td,
5246: table.LC_docs_adddocs th {
5247: border: 1px solid #BBBBBB;
5248: padding: 4px;
5249: background: #DDDDDD;
1.543 albertel 5250: }
5251:
1.584 albertel 5252: table.LC_sty_begin {
5253: background: #BBFFBB;
5254: }
5255: table.LC_sty_end {
5256: background: #FFBBBB;
5257: }
5258:
1.589 raeburn 5259: table.LC_double_column {
5260: border-width: 0px;
5261: border-collapse: collapse;
5262: width: 100%;
5263: padding: 2px;
5264: }
5265:
5266: table.LC_double_column tr td.LC_left_col {
1.590 raeburn 5267: top: 2px;
1.589 raeburn 5268: left: 2px;
5269: width: 47%;
5270: vertical-align: top;
5271: }
5272:
5273: table.LC_double_column tr td.LC_right_col {
5274: top: 2px;
5275: right: 2px;
5276: width: 47%;
5277: vertical-align: top;
5278: }
5279:
1.594 raeburn 5280: span.LC_role_level {
5281: font-weight: bold;
5282: }
5283:
1.591 raeburn 5284: div.LC_left_float {
5285: float: left;
5286: padding-right: 5%;
1.597 albertel 5287: padding-bottom: 4px;
1.591 raeburn 5288: }
5289:
5290: div.LC_clear_float_header {
1.597 albertel 5291: padding-bottom: 2px;
1.591 raeburn 5292: }
5293:
5294: div.LC_clear_float_footer {
1.597 albertel 5295: padding-top: 10px;
1.591 raeburn 5296: clear: both;
5297: }
5298:
1.597 albertel 5299:
1.601 albertel 5300: div.LC_grade_select_mode {
1.604 albertel 5301: font-family: $sans;
1.601 albertel 5302: }
5303: div.LC_grade_select_mode div div {
5304: margin: 5px;
5305: }
5306: div.LC_grade_select_mode_selector {
5307: margin: 5px;
5308: float: left;
5309: }
5310: div.LC_grade_select_mode_selector_header {
5311: font: bold medium $sans;
5312: }
5313: div.LC_grade_select_mode_type {
5314: clear: left;
5315: }
5316:
1.597 albertel 5317: div.LC_grade_show_user {
5318: margin-top: 20px;
5319: border: 1px solid black;
5320: }
5321: div.LC_grade_user_name {
5322: background: #DDDDEE;
5323: border-bottom: 1px solid black;
5324: font: bold large $sans;
5325: }
5326: div.LC_grade_show_user_odd_row div.LC_grade_user_name {
5327: background: #DDEEDD;
5328: }
5329:
5330: div.LC_grade_show_problem,
5331: div.LC_grade_submissions,
5332: div.LC_grade_message_center,
5333: div.LC_grade_info_links,
5334: div.LC_grade_assign {
5335: margin: 5px;
5336: width: 99%;
5337: background: #FFFFFF;
5338: }
5339: div.LC_grade_show_problem_header,
5340: div.LC_grade_submissions_header,
5341: div.LC_grade_message_center_header,
5342: div.LC_grade_assign_header {
5343: font: bold large $sans;
5344: }
5345: div.LC_grade_show_problem_problem,
5346: div.LC_grade_submissions_body,
5347: div.LC_grade_message_center_body,
5348: div.LC_grade_assign_body {
5349: border: 1px solid black;
5350: width: 99%;
5351: background: #FFFFFF;
5352: }
1.598 albertel 5353: span.LC_grade_check_note {
5354: font: normal medium $sans;
5355: display: inline;
5356: position: absolute;
5357: right: 1em;
5358: }
1.597 albertel 5359:
1.613 albertel 5360: table.LC_scantron_action {
5361: width: 100%;
5362: }
5363: table.LC_scantron_action tr th {
5364: font: normal bold $sans;
5365: }
1.600 albertel 5366:
1.614 albertel 5367: div.LC_edit_problem_header,
5368: div.LC_edit_problem_footer {
1.600 albertel 5369: font: normal medium $sans;
1.602 albertel 5370: margin: 2px;
1.600 albertel 5371: }
5372: div.LC_edit_problem_header,
1.602 albertel 5373: div.LC_edit_problem_header div,
1.614 albertel 5374: div.LC_edit_problem_footer,
5375: div.LC_edit_problem_footer div,
1.602 albertel 5376: div.LC_edit_problem_editxml_header,
5377: div.LC_edit_problem_editxml_header div {
1.600 albertel 5378: margin-top: 5px;
5379: }
1.602 albertel 5380: div.LC_edit_problem_header_edit_row {
5381: background: $tabbg;
5382: padding: 3px;
5383: margin-bottom: 5px;
5384: }
1.600 albertel 5385: div.LC_edit_problem_header_title {
1.602 albertel 5386: font: larger bold $sans;
5387: background: $tabbg;
5388: padding: 3px;
5389: }
5390: table.LC_edit_problem_header_title {
5391: font: larger bold $sans;
5392: width: 100%;
5393: border-color: $pgbg;
5394: border-style: solid;
5395: border-width: $border;
5396:
1.600 albertel 5397: background: $tabbg;
1.602 albertel 5398: border-collapse: collapse;
5399: padding: 0px
5400: }
5401:
5402: div.LC_edit_problem_discards {
5403: float: left;
5404: padding-bottom: 5px;
5405: }
5406: div.LC_edit_problem_saves {
5407: float: right;
5408: padding-bottom: 5px;
1.600 albertel 5409: }
5410: hr.LC_edit_problem_divide {
1.602 albertel 5411: clear: both;
1.600 albertel 5412: color: $tabbg;
5413: background-color: $tabbg;
5414: height: 3px;
5415: border: 0px;
5416: }
1.679 riegler 5417: img.stift{
1.678 riegler 5418: border-width:0;
1.679 riegler 5419: vertical-align:middle;
1.677 riegler 5420: }
1.680 riegler 5421:
1.681 riegler 5422: table#LC_mainmenu{
5423: margin-top:10px;
5424: width:80%;
5425:
5426: }
5427:
1.680 riegler 5428: table#LC_mainmenu td.LC_mainmenu_col_fieldset{
5429: vertical-align: top;
5430: width: 45%;
5431: }
5432: .LC_mainmenu_fieldset_category {
5433: color: $font;
5434: background: $pgbg;
5435: font-family: $sans;
5436: font-size: small;
5437: font-weight: bold;
5438: }
5439: fieldset#LC_mainmenu_fieldset {
1.681 riegler 5440: margin:0px 10px 10px 0px;
1.680 riegler 5441:
5442: }
1.343 albertel 5443: END
5444: }
5445:
1.306 albertel 5446: =pod
5447:
5448: =item * &headtag()
5449:
5450: Returns a uniform footer for LON-CAPA web pages.
5451:
1.307 albertel 5452: Inputs: $title - optional title for the head
5453: $head_extra - optional extra HTML to put inside the <head>
1.315 albertel 5454: $args - optional arguments
1.319 albertel 5455: force_register - if is true call registerurl so the remote is
5456: informed
1.415 albertel 5457: redirect -> array ref of
5458: 1- seconds before redirect occurs
5459: 2- url to redirect to
5460: 3- whether the side effect should occur
1.315 albertel 5461: (side effect of setting
5462: $env{'internal.head.redirect'} to the url
5463: redirected too)
1.352 albertel 5464: domain -> force to color decorate a page for a specific
5465: domain
5466: function -> force usage of a specific rolish color scheme
5467: bgcolor -> override the default page bgcolor
1.460 albertel 5468: no_auto_mt_title
5469: -> prevent &mt()ing the title arg
1.464 albertel 5470:
1.306 albertel 5471: =cut
5472:
5473: sub headtag {
1.313 albertel 5474: my ($title,$head_extra,$args) = @_;
1.306 albertel 5475:
1.363 albertel 5476: my $function = $args->{'function'} || &get_users_function();
5477: my $domain = $args->{'domain'} || &determinedomain();
5478: my $bgcolor = $args->{'bgcolor'} || &designparm($function.'.pgbg',$domain);
1.418 albertel 5479: my $url = join(':',$env{'user.name'},$env{'user.domain'},
1.458 albertel 5480: $Apache::lonnet::perlvar{'lonVersion'},
1.531 albertel 5481: #time(),
1.418 albertel 5482: $env{'environment.color.timestamp'},
1.363 albertel 5483: $function,$domain,$bgcolor);
5484:
1.369 www 5485: $url = '/adm/css/'.&escape($url).'.css';
1.363 albertel 5486:
1.308 albertel 5487: my $result =
5488: '<head>'.
1.461 albertel 5489: &font_settings();
1.319 albertel 5490:
1.461 albertel 5491: if (!$args->{'frameset'}) {
5492: $result .= &Apache::lonhtmlcommon::htmlareaheaders();
5493: }
1.319 albertel 5494: if ($args->{'force_register'}) {
5495: $result .= &Apache::lonmenu::registerurl(1);
5496: }
1.436 albertel 5497: if (!$args->{'no_nav_bar'}
5498: && !$args->{'only_body'}
5499: && !$args->{'frameset'}) {
5500: $result .= &help_menu_js();
5501: }
1.319 albertel 5502:
1.314 albertel 5503: if (ref($args->{'redirect'})) {
1.414 albertel 5504: my ($time,$url,$inhibit_continue) = @{$args->{'redirect'}};
1.315 albertel 5505: $url = &Apache::lonenc::check_encrypt($url);
1.414 albertel 5506: if (!$inhibit_continue) {
5507: $env{'internal.head.redirect'} = $url;
5508: }
1.313 albertel 5509: $result.=<<ADDMETA
5510: <meta http-equiv="pragma" content="no-cache" />
1.344 albertel 5511: <meta http-equiv="Refresh" content="$time; url=$url" />
1.313 albertel 5512: ADDMETA
5513: }
1.306 albertel 5514: if (!defined($title)) {
5515: $title = 'The LearningOnline Network with CAPA';
5516: }
1.460 albertel 5517: if (!$args->{'no_auto_mt_title'}) { $title = &mt($title); }
5518: $result .= '<title> LON-CAPA '.$title.'</title>'
1.414 albertel 5519: .'<link rel="stylesheet" type="text/css" href="'.$url.'" />'
5520: .$head_extra;
1.306 albertel 5521: return $result;
5522: }
5523:
5524: =pod
5525:
1.340 albertel 5526: =item * &font_settings()
5527:
5528: Returns neccessary <meta> to set the proper encoding
5529:
5530: Inputs: none
5531:
5532: =cut
5533:
5534: sub font_settings {
5535: my $headerstring='';
1.647 www 5536: if (!$env{'browser.mathml'} && $env{'browser.unicode'}) {
1.340 albertel 5537: $headerstring.=
5538: '<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />';
5539: }
5540: return $headerstring;
5541: }
5542:
1.341 albertel 5543: =pod
5544:
5545: =item * &xml_begin()
5546:
5547: Returns the needed doctype and <html>
5548:
5549: Inputs: none
5550:
5551: =cut
5552:
5553: sub xml_begin {
5554: my $output='';
5555:
1.592 albertel 5556: if ($env{'internal.start_page'}==1) {
5557: &Apache::lonhtmlcommon::init_htmlareafields();
5558: }
1.342 albertel 5559:
1.341 albertel 5560: if ($env{'browser.mathml'}) {
5561: $output='<?xml version="1.0"?>'
5562: #.'<?xml-stylesheet type="text/css" href="/adm/MathML/mathml.css"?>'."\n"
5563: # .'<!DOCTYPE html SYSTEM "/adm/MathML/mathml.dtd" '
5564:
5565: # .'<!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">] >'
5566: .'<!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">'
5567: .'<html xmlns:math="http://www.w3.org/1998/Math/MathML" '
5568: .'xmlns="http://www.w3.org/1999/xhtml">';
5569: } else {
5570: $output='<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"><html>';
5571: }
5572: return $output;
5573: }
1.340 albertel 5574:
5575: =pod
5576:
1.306 albertel 5577: =item * &endheadtag()
5578:
5579: Returns a uniform </head> for LON-CAPA web pages.
5580:
5581: Inputs: none
5582:
5583: =cut
5584:
5585: sub endheadtag {
5586: return '</head>';
5587: }
5588:
5589: =pod
5590:
5591: =item * &head()
5592:
5593: Returns a uniform complete <head>..</head> section for LON-CAPA web pages.
5594:
1.648 raeburn 5595: Inputs:
5596:
5597: =over 4
5598:
5599: $title - optional title for the page
5600:
5601: $head_extra - optional extra HTML to put inside the <head>
5602:
5603: =back
1.405 albertel 5604:
1.306 albertel 5605: =cut
5606:
5607: sub head {
1.325 albertel 5608: my ($title,$head_extra,$args) = @_;
5609: return &headtag($title,$head_extra,$args).&endheadtag();
1.306 albertel 5610: }
5611:
5612: =pod
5613:
5614: =item * &start_page()
5615:
5616: Returns a complete <html> .. <body> section for LON-CAPA web pages.
5617:
1.648 raeburn 5618: Inputs:
5619:
5620: =over 4
5621:
5622: $title - optional title for the page
5623:
5624: $head_extra - optional extra HTML to incude inside the <head>
5625:
5626: $args - additional optional args supported are:
5627:
5628: =over 8
5629:
5630: only_body -> is true will set &bodytag() onlybodytag
1.317 albertel 5631: arg on
1.648 raeburn 5632: no_nav_bar -> is true will set &bodytag() notopbar arg on
5633: add_entries -> additional attributes to add to the <body>
5634: domain -> force to color decorate a page for a
1.317 albertel 5635: specific domain
1.648 raeburn 5636: function -> force usage of a specific rolish color
1.317 albertel 5637: scheme
1.648 raeburn 5638: redirect -> see &headtag()
5639: bgcolor -> override the default page bg color
5640: js_ready -> return a string ready for being used in
1.317 albertel 5641: a javascript writeln
1.648 raeburn 5642: html_encode -> return a string ready for being used in
1.320 albertel 5643: a html attribute
1.648 raeburn 5644: force_register -> if is true will turn on the &bodytag()
1.317 albertel 5645: $forcereg arg
1.648 raeburn 5646: body_title -> alternate text to use instead of $title
1.326 albertel 5647: in the title box that appears, this text
5648: is not auto translated like the $title is
1.648 raeburn 5649: frameset -> if true will start with a <frameset>
1.330 albertel 5650: rather than <body>
1.648 raeburn 5651: no_title -> if true the title bar won't be shown
5652: skip_phases -> hash ref of
1.338 albertel 5653: head -> skip the <html><head> generation
5654: body -> skip all <body> generation
1.648 raeburn 5655: no_inline_link -> if true and in remote mode, don't show the
1.361 albertel 5656: 'Switch To Inline Menu' link
1.648 raeburn 5657: no_auto_mt_title -> prevent &mt()ing the title arg
5658: inherit_jsmath -> when creating popup window in a page,
5659: should it have jsmath forced on by the
5660: current page
1.361 albertel 5661:
1.648 raeburn 5662: =back
1.460 albertel 5663:
1.648 raeburn 5664: =back
1.562 albertel 5665:
1.306 albertel 5666: =cut
5667:
5668: sub start_page {
1.309 albertel 5669: my ($title,$head_extra,$args) = @_;
1.318 albertel 5670: #&Apache::lonnet::logthis("start_page ".join(':',caller(0)));
1.313 albertel 5671: my %head_args;
1.352 albertel 5672: foreach my $arg ('redirect','force_register','domain','function',
1.460 albertel 5673: 'bgcolor','frameset','no_nav_bar','only_body',
5674: 'no_auto_mt_title') {
1.319 albertel 5675: if (defined($args->{$arg})) {
1.324 raeburn 5676: $head_args{$arg} = $args->{$arg};
1.319 albertel 5677: }
1.313 albertel 5678: }
1.319 albertel 5679:
1.315 albertel 5680: $env{'internal.start_page'}++;
1.338 albertel 5681: my $result;
5682: if (! exists($args->{'skip_phases'}{'head'}) ) {
5683: $result.=
1.341 albertel 5684: &xml_begin().
1.338 albertel 5685: &headtag($title,$head_extra,\%head_args).&endheadtag();
5686: }
5687:
5688: if (! exists($args->{'skip_phases'}{'body'}) ) {
5689: if ($args->{'frameset'}) {
5690: my $attr_string = &make_attr_string($args->{'force_register'},
5691: $args->{'add_entries'});
5692: $result .= "\n<frameset $attr_string>\n";
5693: } else {
5694: $result .=
5695: &bodytag($title,
5696: $args->{'function'}, $args->{'add_entries'},
5697: $args->{'only_body'}, $args->{'domain'},
5698: $args->{'force_register'}, $args->{'body_title'},
5699: $args->{'no_nav_bar'}, $args->{'bgcolor'},
1.460 albertel 5700: $args->{'no_title'}, $args->{'no_inline_link'},
5701: $args);
1.338 albertel 5702: }
1.330 albertel 5703: }
1.338 albertel 5704:
1.315 albertel 5705: if ($args->{'js_ready'}) {
1.317 albertel 5706: $result = &js_ready($result);
1.315 albertel 5707: }
1.320 albertel 5708: if ($args->{'html_encode'}) {
5709: $result = &html_encode($result);
5710: }
1.315 albertel 5711: return $result;
1.306 albertel 5712: }
5713:
1.330 albertel 5714:
1.306 albertel 5715: =pod
5716:
5717: =item * &head()
5718:
5719: Returns a complete </body></html> section for LON-CAPA web pages.
5720:
1.315 albertel 5721: Inputs: $args - additional optional args supported are:
5722: js_ready -> return a string ready for being used in
5723: a javascript writeln
1.320 albertel 5724: html_encode -> return a string ready for being used in
5725: a html attribute
1.330 albertel 5726: frameset -> if true will start with a <frameset>
5727: rather than <body>
1.493 albertel 5728: dicsussion -> if true will get discussion from
5729: lonxml::xmlend
5730: (you can pass the target and parser arguments
5731: through optional 'target' and 'parser' args
5732: to this routine)
1.306 albertel 5733:
5734: =cut
5735:
5736: sub end_page {
1.315 albertel 5737: my ($args) = @_;
5738: $env{'internal.end_page'}++;
1.330 albertel 5739: my $result;
1.335 albertel 5740: if ($args->{'discussion'}) {
5741: my ($target,$parser);
5742: if (ref($args->{'discussion'})) {
5743: ($target,$parser) =($args->{'discussion'}{'target'},
5744: $args->{'discussion'}{'parser'});
5745: }
5746: $result .= &Apache::lonxml::xmlend($target,$parser);
5747: }
5748:
1.330 albertel 5749: if ($args->{'frameset'}) {
5750: $result .= '</frameset>';
5751: } else {
1.635 raeburn 5752: $result .= &endbodytag($args);
1.330 albertel 5753: }
5754: $result .= "\n</html>";
5755:
1.315 albertel 5756: if ($args->{'js_ready'}) {
1.317 albertel 5757: $result = &js_ready($result);
1.315 albertel 5758: }
1.335 albertel 5759:
1.320 albertel 5760: if ($args->{'html_encode'}) {
5761: $result = &html_encode($result);
5762: }
1.335 albertel 5763:
1.315 albertel 5764: return $result;
5765: }
5766:
1.320 albertel 5767: sub html_encode {
5768: my ($result) = @_;
5769:
1.322 albertel 5770: $result = &HTML::Entities::encode($result,'<>&"');
1.320 albertel 5771:
5772: return $result;
5773: }
1.317 albertel 5774: sub js_ready {
5775: my ($result) = @_;
5776:
1.323 albertel 5777: $result =~ s/[\n\r]/ /xmsg;
5778: $result =~ s/\\/\\\\/xmsg;
5779: $result =~ s/'/\\'/xmsg;
1.372 albertel 5780: $result =~ s{</}{<\\/}xmsg;
1.317 albertel 5781:
5782: return $result;
5783: }
5784:
1.315 albertel 5785: sub validate_page {
5786: if ( exists($env{'internal.start_page'})
1.316 albertel 5787: && $env{'internal.start_page'} > 1) {
5788: &Apache::lonnet::logthis('start_page called multiple times '.
1.318 albertel 5789: $env{'internal.start_page'}.' '.
1.316 albertel 5790: $ENV{'request.filename'});
1.315 albertel 5791: }
5792: if ( exists($env{'internal.end_page'})
1.316 albertel 5793: && $env{'internal.end_page'} > 1) {
5794: &Apache::lonnet::logthis('end_page called multiple times '.
1.318 albertel 5795: $env{'internal.end_page'}.' '.
1.316 albertel 5796: $env{'request.filename'});
1.315 albertel 5797: }
5798: if ( exists($env{'internal.start_page'})
5799: && ! exists($env{'internal.end_page'})) {
1.316 albertel 5800: &Apache::lonnet::logthis('start_page called without end_page '.
5801: $env{'request.filename'});
1.315 albertel 5802: }
5803: if ( ! exists($env{'internal.start_page'})
5804: && exists($env{'internal.end_page'})) {
1.316 albertel 5805: &Apache::lonnet::logthis('end_page called without start_page'.
5806: $env{'request.filename'});
1.315 albertel 5807: }
1.306 albertel 5808: }
1.315 albertel 5809:
1.318 albertel 5810: sub simple_error_page {
5811: my ($r,$title,$msg) = @_;
5812: my $page =
5813: &Apache::loncommon::start_page($title).
5814: &mt($msg).
5815: &Apache::loncommon::end_page();
5816: if (ref($r)) {
5817: $r->print($page);
1.327 albertel 5818: return;
1.318 albertel 5819: }
5820: return $page;
5821: }
1.347 albertel 5822:
5823: {
1.610 albertel 5824: my @row_count;
1.347 albertel 5825: sub start_data_table {
1.422 albertel 5826: my ($add_class) = @_;
5827: my $css_class = (join(' ','LC_data_table',$add_class));
1.610 albertel 5828: unshift(@row_count,0);
1.422 albertel 5829: return '<table class="'.$css_class.'">'."\n";
1.347 albertel 5830: }
5831:
5832: sub end_data_table {
1.610 albertel 5833: shift(@row_count);
1.389 albertel 5834: return '</table>'."\n";;
1.347 albertel 5835: }
5836:
5837: sub start_data_table_row {
1.422 albertel 5838: my ($add_class) = @_;
1.610 albertel 5839: $row_count[0]++;
5840: my $css_class = ($row_count[0] % 2)?'LC_odd_row':'LC_even_row';
1.428 albertel 5841: $css_class = (join(' ',$css_class,$add_class));
1.422 albertel 5842: return '<tr class="'.$css_class.'">'."\n";;
1.347 albertel 5843: }
1.471 banghart 5844:
5845: sub continue_data_table_row {
5846: my ($add_class) = @_;
1.610 albertel 5847: my $css_class = ($row_count[0] % 2)?'LC_odd_row':'LC_even_row';
1.471 banghart 5848: $css_class = (join(' ',$css_class,$add_class));
5849: return '<tr class="'.$css_class.'">'."\n";;
5850: }
1.347 albertel 5851:
5852: sub end_data_table_row {
1.389 albertel 5853: return '</tr>'."\n";;
1.347 albertel 5854: }
1.367 www 5855:
1.421 albertel 5856: sub start_data_table_empty_row {
1.610 albertel 5857: $row_count[0]++;
1.421 albertel 5858: return '<tr class="LC_empty_row" >'."\n";;
5859: }
5860:
5861: sub end_data_table_empty_row {
5862: return '</tr>'."\n";;
5863: }
5864:
1.367 www 5865: sub start_data_table_header_row {
1.389 albertel 5866: return '<tr class="LC_header_row">'."\n";;
1.367 www 5867: }
5868:
5869: sub end_data_table_header_row {
1.389 albertel 5870: return '</tr>'."\n";;
1.367 www 5871: }
1.347 albertel 5872: }
5873:
1.548 albertel 5874: =pod
5875:
5876: =item * &inhibit_menu_check($arg)
5877:
5878: Checks for a inhibitmenu state and generates output to preserve it
5879:
5880: Inputs: $arg - can be any of
5881: - undef - in which case the return value is a string
5882: to add into arguments list of a uri
5883: - 'input' - in which case the return value is a HTML
5884: <form> <input> field of type hidden to
5885: preserve the value
5886: - a url - in which case the return value is the url with
5887: the neccesary cgi args added to preserve the
5888: inhibitmenu state
5889: - a ref to a url - no return value, but the string is
5890: updated to include the neccessary cgi
5891: args to preserve the inhibitmenu state
5892:
5893: =cut
5894:
5895: sub inhibit_menu_check {
5896: my ($arg) = @_;
5897: &get_unprocessed_cgi($ENV{'QUERY_STRING'}, ['inhibitmenu']);
5898: if ($arg eq 'input') {
5899: if ($env{'form.inhibitmenu'}) {
5900: return '<input type="hidden" name="inhibitmenu" value="'.$env{'form.inhibitmenu'}.'" />';
5901: } else {
5902: return
5903: }
5904: }
5905: if ($env{'form.inhibitmenu'}) {
5906: if (ref($arg)) {
5907: $$arg .= '?inhibitmenu='.$env{'form.inhibitmenu'};
5908: } elsif ($arg eq '') {
5909: $arg .= 'inhibitmenu='.$env{'form.inhibitmenu'};
5910: } else {
5911: $arg .= '?inhibitmenu='.$env{'form.inhibitmenu'};
5912: }
5913: }
5914: if (!ref($arg)) {
5915: return $arg;
5916: }
5917: }
5918:
1.251 albertel 5919: ###############################################
1.182 matthew 5920:
5921: =pod
5922:
1.549 albertel 5923: =back
5924:
5925: =head1 User Information Routines
5926:
5927: =over 4
5928:
1.405 albertel 5929: =item * &get_users_function()
1.182 matthew 5930:
5931: Used by &bodytag to determine the current users primary role.
5932: Returns either 'student','coordinator','admin', or 'author'.
5933:
5934: =cut
5935:
5936: ###############################################
5937: sub get_users_function {
5938: my $function = 'student';
1.258 albertel 5939: if ($env{'request.role'}=~/^(cc|in|ta|ep)/) {
1.182 matthew 5940: $function='coordinator';
5941: }
1.258 albertel 5942: if ($env{'request.role'}=~/^(su|dc|ad|li)/) {
1.182 matthew 5943: $function='admin';
5944: }
1.258 albertel 5945: if (($env{'request.role'}=~/^(au|ca)/) ||
1.182 matthew 5946: ($ENV{'REQUEST_URI'}=~/^(\/priv|\~)/)) {
5947: $function='author';
5948: }
5949: return $function;
1.54 www 5950: }
1.99 www 5951:
5952: ###############################################
5953:
1.233 raeburn 5954: =pod
5955:
1.542 raeburn 5956: =item * &check_user_status()
1.274 raeburn 5957:
5958: Determines current status of supplied role for a
5959: specific user. Roles can be active, previous or future.
5960:
5961: Inputs:
5962: user's domain, user's username, course's domain,
1.375 raeburn 5963: course's number, optional section ID.
1.274 raeburn 5964:
5965: Outputs:
5966: role status: active, previous or future.
5967:
5968: =cut
5969:
5970: sub check_user_status {
1.412 raeburn 5971: my ($udom,$uname,$cdom,$crs,$role,$sec) = @_;
1.274 raeburn 5972: my %userinfo = &Apache::lonnet::dump('roles',$udom,$uname);
5973: my @uroles = keys %userinfo;
5974: my $srchstr;
5975: my $active_chk = 'none';
1.412 raeburn 5976: my $now = time;
1.274 raeburn 5977: if (@uroles > 0) {
1.412 raeburn 5978: if (($role eq 'cc') || ($sec eq '') || (!defined($sec))) {
1.274 raeburn 5979: $srchstr = '/'.$cdom.'/'.$crs.'_'.$role;
5980: } else {
1.412 raeburn 5981: $srchstr = '/'.$cdom.'/'.$crs.'/'.$sec.'_'.$role;
5982: }
5983: if (grep/^\Q$srchstr\E$/,@uroles) {
1.274 raeburn 5984: my $role_end = 0;
5985: my $role_start = 0;
5986: $active_chk = 'active';
1.412 raeburn 5987: if ($userinfo{$srchstr} =~ m/^\Q$role\E_(\d+)/) {
5988: $role_end = $1;
5989: if ($userinfo{$srchstr} =~ m/^\Q$role\E_\Q$role_end\E_(\d+)$/) {
5990: $role_start = $1;
1.274 raeburn 5991: }
5992: }
5993: if ($role_start > 0) {
1.412 raeburn 5994: if ($now < $role_start) {
1.274 raeburn 5995: $active_chk = 'future';
5996: }
5997: }
5998: if ($role_end > 0) {
1.412 raeburn 5999: if ($now > $role_end) {
1.274 raeburn 6000: $active_chk = 'previous';
6001: }
6002: }
6003: }
6004: }
6005: return $active_chk;
6006: }
6007:
6008: ###############################################
6009:
6010: =pod
6011:
1.405 albertel 6012: =item * &get_sections()
1.233 raeburn 6013:
6014: Determines all the sections for a course including
6015: sections with students and sections containing other roles.
1.419 raeburn 6016: Incoming parameters:
6017:
6018: 1. domain
6019: 2. course number
6020: 3. reference to array containing roles for which sections should
6021: be gathered (optional).
6022: 4. reference to array containing status types for which sections
6023: should be gathered (optional).
6024:
6025: If the third argument is undefined, sections are gathered for any role.
6026: If the fourth argument is undefined, sections are gathered for any status.
6027: Permissible values are 'active' or 'future' or 'previous'.
1.233 raeburn 6028:
1.374 raeburn 6029: Returns section hash (keys are section IDs, values are
6030: number of users in each section), subject to the
1.419 raeburn 6031: optional roles filter, optional status filter
1.233 raeburn 6032:
6033: =cut
6034:
6035: ###############################################
6036: sub get_sections {
1.419 raeburn 6037: my ($cdom,$cnum,$possible_roles,$possible_status) = @_;
1.366 albertel 6038: if (!defined($cdom) || !defined($cnum)) {
6039: my $cid = $env{'request.course.id'};
6040:
6041: return if (!defined($cid));
6042:
6043: $cdom = $env{'course.'.$cid.'.domain'};
6044: $cnum = $env{'course.'.$cid.'.num'};
6045: }
6046:
6047: my %sectioncount;
1.419 raeburn 6048: my $now = time;
1.240 albertel 6049:
1.366 albertel 6050: if (!defined($possible_roles) || (grep(/^st$/,@$possible_roles))) {
1.276 albertel 6051: my ($classlist) = &Apache::loncoursedata::get_classlist($cdom,$cnum);
1.240 albertel 6052: my $sec_index = &Apache::loncoursedata::CL_SECTION();
6053: my $status_index = &Apache::loncoursedata::CL_STATUS();
1.419 raeburn 6054: my $start_index = &Apache::loncoursedata::CL_START();
6055: my $end_index = &Apache::loncoursedata::CL_END();
6056: my $status;
1.366 albertel 6057: while (my ($student,$data) = each(%$classlist)) {
1.419 raeburn 6058: my ($section,$stu_status,$start,$end) = ($data->[$sec_index],
6059: $data->[$status_index],
6060: $data->[$start_index],
6061: $data->[$end_index]);
6062: if ($stu_status eq 'Active') {
6063: $status = 'active';
6064: } elsif ($end < $now) {
6065: $status = 'previous';
6066: } elsif ($start > $now) {
6067: $status = 'future';
6068: }
6069: if ($section ne '-1' && $section !~ /^\s*$/) {
6070: if ((!defined($possible_status)) || (($status ne '') &&
6071: (grep/^\Q$status\E$/,@{$possible_status}))) {
6072: $sectioncount{$section}++;
6073: }
1.240 albertel 6074: }
6075: }
6076: }
6077: my %courseroles = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum);
6078: foreach my $user (sort(keys(%courseroles))) {
6079: if ($user !~ /^(\w{2})/) { next; }
6080: my ($role) = ($user =~ /^(\w{2})/);
6081: if ($possible_roles && !(grep(/^$role$/,@$possible_roles))) { next; }
1.419 raeburn 6082: my ($section,$status);
1.240 albertel 6083: if ($role eq 'cr' &&
6084: $user =~ m-^$role/[^/]*/[^/]*/[^/]*:[^:]*:[^:]*:(\w+)-) {
6085: $section=$1;
6086: }
6087: if ($user =~ /^$role:[^:]*:[^:]*:(\w+)/) { $section=$1; }
6088: if (!defined($section) || $section eq '-1') { next; }
1.419 raeburn 6089: my ($end,$start) = ($courseroles{$user} =~ /^([^:]*):([^:]*)$/);
6090: if ($end == -1 && $start == -1) {
6091: next; #deleted role
6092: }
6093: if (!defined($possible_status)) {
6094: $sectioncount{$section}++;
6095: } else {
6096: if ((!$end || $end >= $now) && (!$start || $start <= $now)) {
6097: $status = 'active';
6098: } elsif ($end < $now) {
6099: $status = 'future';
6100: } elsif ($start > $now) {
6101: $status = 'previous';
6102: }
6103: if (($status ne '') && (grep/^\Q$status\E$/,@{$possible_status})) {
6104: $sectioncount{$section}++;
6105: }
6106: }
1.233 raeburn 6107: }
1.366 albertel 6108: return %sectioncount;
1.233 raeburn 6109: }
6110:
1.274 raeburn 6111: ###############################################
1.294 raeburn 6112:
6113: =pod
1.405 albertel 6114:
6115: =item * &get_course_users()
6116:
1.275 raeburn 6117: Retrieves usernames:domains for users in the specified course
6118: with specific role(s), and access status.
6119:
6120: Incoming parameters:
1.277 albertel 6121: 1. course domain
6122: 2. course number
6123: 3. access status: users must have - either active,
1.275 raeburn 6124: previous, future, or all.
1.277 albertel 6125: 4. reference to array of permissible roles
1.288 raeburn 6126: 5. reference to array of section restrictions (optional)
6127: 6. reference to results object (hash of hashes).
6128: 7. reference to optional userdata hash
1.609 raeburn 6129: 8. reference to optional statushash
1.630 raeburn 6130: 9. flag if privileged users (except those set to unhide in
6131: course settings) should be excluded
1.609 raeburn 6132: Keys of top level results hash are roles.
1.275 raeburn 6133: Keys of inner hashes are username:domain, with
6134: values set to access type.
1.288 raeburn 6135: Optional userdata hash returns an array with arguments in the
6136: same order as loncoursedata::get_classlist() for student data.
6137:
1.609 raeburn 6138: Optional statushash returns
6139:
1.288 raeburn 6140: Entries for end, start, section and status are blank because
6141: of the possibility of multiple values for non-student roles.
6142:
1.275 raeburn 6143: =cut
1.405 albertel 6144:
1.275 raeburn 6145: ###############################################
1.405 albertel 6146:
1.275 raeburn 6147: sub get_course_users {
1.630 raeburn 6148: my ($cdom,$cnum,$types,$roles,$sections,$users,$userdata,$statushash,$hidepriv) = @_;
1.288 raeburn 6149: my %idx = ();
1.419 raeburn 6150: my %seclists;
1.288 raeburn 6151:
6152: $idx{udom} = &Apache::loncoursedata::CL_SDOM();
6153: $idx{uname} = &Apache::loncoursedata::CL_SNAME();
6154: $idx{end} = &Apache::loncoursedata::CL_END();
6155: $idx{start} = &Apache::loncoursedata::CL_START();
6156: $idx{id} = &Apache::loncoursedata::CL_ID();
6157: $idx{section} = &Apache::loncoursedata::CL_SECTION();
6158: $idx{fullname} = &Apache::loncoursedata::CL_FULLNAME();
6159: $idx{status} = &Apache::loncoursedata::CL_STATUS();
6160:
1.290 albertel 6161: if (grep(/^st$/,@{$roles})) {
1.276 albertel 6162: my ($classlist,$keylist)=&Apache::loncoursedata::get_classlist($cdom,$cnum);
1.278 raeburn 6163: my $now = time;
1.277 albertel 6164: foreach my $student (keys(%{$classlist})) {
1.288 raeburn 6165: my $match = 0;
1.412 raeburn 6166: my $secmatch = 0;
1.419 raeburn 6167: my $section = $$classlist{$student}[$idx{section}];
1.609 raeburn 6168: my $status = $$classlist{$student}[$idx{status}];
1.419 raeburn 6169: if ($section eq '') {
6170: $section = 'none';
6171: }
1.291 albertel 6172: if ((ref($sections) eq 'ARRAY') && (@{$sections} > 0)) {
1.420 albertel 6173: if (grep(/^all$/,@{$sections})) {
1.412 raeburn 6174: $secmatch = 1;
6175: } elsif ($$classlist{$student}[$idx{section}] eq '') {
1.420 albertel 6176: if (grep(/^none$/,@{$sections})) {
1.412 raeburn 6177: $secmatch = 1;
6178: }
6179: } else {
1.419 raeburn 6180: if (grep(/^\Q$section\E$/,@{$sections})) {
1.412 raeburn 6181: $secmatch = 1;
6182: }
1.290 albertel 6183: }
1.412 raeburn 6184: if (!$secmatch) {
6185: next;
6186: }
1.419 raeburn 6187: }
1.275 raeburn 6188: if (defined($$types{'active'})) {
1.288 raeburn 6189: if ($$classlist{$student}[$idx{status}] eq 'Active') {
1.275 raeburn 6190: push(@{$$users{st}{$student}},'active');
1.288 raeburn 6191: $match = 1;
1.275 raeburn 6192: }
6193: }
6194: if (defined($$types{'previous'})) {
1.609 raeburn 6195: if ($$classlist{$student}[$idx{status}] eq 'Expired') {
1.275 raeburn 6196: push(@{$$users{st}{$student}},'previous');
1.288 raeburn 6197: $match = 1;
1.275 raeburn 6198: }
6199: }
6200: if (defined($$types{'future'})) {
1.609 raeburn 6201: if ($$classlist{$student}[$idx{status}] eq 'Future') {
1.275 raeburn 6202: push(@{$$users{st}{$student}},'future');
1.288 raeburn 6203: $match = 1;
1.275 raeburn 6204: }
6205: }
1.609 raeburn 6206: if ($match) {
6207: push(@{$seclists{$student}},$section);
6208: if (ref($userdata) eq 'HASH') {
6209: $$userdata{$student} = $$classlist{$student};
6210: }
6211: if (ref($statushash) eq 'HASH') {
6212: $statushash->{$student}{'st'}{$section} = $status;
6213: }
1.288 raeburn 6214: }
1.275 raeburn 6215: }
6216: }
1.412 raeburn 6217: if ((@{$roles} > 1) || ((@{$roles} == 1) && ($$roles[0] ne "st"))) {
1.439 raeburn 6218: my %coursepersonnel = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum);
6219: my $now = time;
1.609 raeburn 6220: my %displaystatus = ( previous => 'Expired',
6221: active => 'Active',
6222: future => 'Future',
6223: );
1.630 raeburn 6224: my %nothide;
6225: if ($hidepriv) {
6226: my %coursehash=&Apache::lonnet::coursedescription($cdom.'_'.$cnum);
6227: foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
6228: if ($user !~ /:/) {
6229: $nothide{join(':',split(/[\@]/,$user))}=1;
6230: } else {
6231: $nothide{$user} = 1;
6232: }
6233: }
6234: }
1.439 raeburn 6235: foreach my $person (sort(keys(%coursepersonnel))) {
1.288 raeburn 6236: my $match = 0;
1.412 raeburn 6237: my $secmatch = 0;
1.439 raeburn 6238: my $status;
1.412 raeburn 6239: my ($role,$user,$usec) = ($person =~ /^([^:]*):([^:]+:[^:]+):([^:]*)/);
1.275 raeburn 6240: $user =~ s/:$//;
1.439 raeburn 6241: my ($end,$start) = split(/:/,$coursepersonnel{$person});
6242: if ($end == -1 || $start == -1) {
6243: next;
6244: }
6245: if (($role) && ((grep(/^\Q$role\E$/,@{$roles})) ||
6246: (grep(/^cr$/,@{$roles}) && $role =~ /^cr\//))) {
1.412 raeburn 6247: my ($uname,$udom) = split(/:/,$user);
6248: if ((ref($sections) eq 'ARRAY') && (@{$sections} > 0)) {
1.420 albertel 6249: if (grep(/^all$/,@{$sections})) {
1.412 raeburn 6250: $secmatch = 1;
6251: } elsif ($usec eq '') {
1.420 albertel 6252: if (grep(/^none$/,@{$sections})) {
1.412 raeburn 6253: $secmatch = 1;
6254: }
6255: } else {
6256: if (grep(/^\Q$usec\E$/,@{$sections})) {
6257: $secmatch = 1;
6258: }
6259: }
6260: if (!$secmatch) {
6261: next;
6262: }
1.288 raeburn 6263: }
1.419 raeburn 6264: if ($usec eq '') {
6265: $usec = 'none';
6266: }
1.275 raeburn 6267: if ($uname ne '' && $udom ne '') {
1.630 raeburn 6268: if ($hidepriv) {
6269: if ((&Apache::lonnet::privileged($uname,$udom)) &&
6270: (!$nothide{$uname.':'.$udom})) {
6271: next;
6272: }
6273: }
1.503 raeburn 6274: if ($end > 0 && $end < $now) {
1.439 raeburn 6275: $status = 'previous';
6276: } elsif ($start > $now) {
6277: $status = 'future';
6278: } else {
6279: $status = 'active';
6280: }
1.277 albertel 6281: foreach my $type (keys(%{$types})) {
1.275 raeburn 6282: if ($status eq $type) {
1.420 albertel 6283: if (!grep(/^\Q$type\E$/,@{$$users{$role}{$user}})) {
1.419 raeburn 6284: push(@{$$users{$role}{$user}},$type);
6285: }
1.288 raeburn 6286: $match = 1;
6287: }
6288: }
1.419 raeburn 6289: if (($match) && (ref($userdata) eq 'HASH')) {
6290: if (!exists($$userdata{$uname.':'.$udom})) {
6291: &get_user_info($udom,$uname,\%idx,$userdata);
6292: }
1.420 albertel 6293: if (!grep(/^\Q$usec\E$/,@{$seclists{$uname.':'.$udom}})) {
1.419 raeburn 6294: push(@{$seclists{$uname.':'.$udom}},$usec);
6295: }
1.609 raeburn 6296: if (ref($statushash) eq 'HASH') {
6297: $statushash->{$uname.':'.$udom}{$role}{$usec} = $displaystatus{$status};
6298: }
1.275 raeburn 6299: }
6300: }
6301: }
6302: }
1.290 albertel 6303: if (grep(/^ow$/,@{$roles})) {
1.279 raeburn 6304: if ((defined($cdom)) && (defined($cnum))) {
6305: my %csettings = &Apache::lonnet::get('environment',['internal.courseowner'],$cdom,$cnum);
6306: if ( defined($csettings{'internal.courseowner'}) ) {
6307: my $owner = $csettings{'internal.courseowner'};
1.609 raeburn 6308: next if ($owner eq '');
6309: my ($ownername,$ownerdom);
6310: if ($owner =~ /^([^:]+):([^:]+)$/) {
6311: $ownername = $1;
6312: $ownerdom = $2;
6313: } else {
6314: $ownername = $owner;
6315: $ownerdom = $cdom;
6316: $owner = $ownername.':'.$ownerdom;
1.439 raeburn 6317: }
6318: @{$$users{'ow'}{$owner}} = 'any';
1.290 albertel 6319: if (defined($userdata) &&
1.609 raeburn 6320: !exists($$userdata{$owner})) {
6321: &get_user_info($ownerdom,$ownername,\%idx,$userdata);
6322: if (!grep(/^none$/,@{$seclists{$owner}})) {
6323: push(@{$seclists{$owner}},'none');
6324: }
6325: if (ref($statushash) eq 'HASH') {
6326: $statushash->{$owner}{'ow'}{'none'} = 'Any';
1.419 raeburn 6327: }
1.290 albertel 6328: }
1.279 raeburn 6329: }
6330: }
6331: }
1.419 raeburn 6332: foreach my $user (keys(%seclists)) {
6333: @{$seclists{$user}} = (sort {$a <=> $b} @{$seclists{$user}});
6334: $$userdata{$user}[$idx{section}] = join(',',@{$seclists{$user}});
6335: }
1.275 raeburn 6336: }
6337: return;
6338: }
6339:
1.288 raeburn 6340: sub get_user_info {
6341: my ($udom,$uname,$idx,$userdata) = @_;
1.289 albertel 6342: $$userdata{$uname.':'.$udom}[$$idx{fullname}] =
6343: &plainname($uname,$udom,'lastname');
1.291 albertel 6344: $$userdata{$uname.':'.$udom}[$$idx{uname}] = $uname;
1.297 raeburn 6345: $$userdata{$uname.':'.$udom}[$$idx{udom}] = $udom;
1.609 raeburn 6346: my %idhash = &Apache::lonnet::idrget($udom,($uname));
6347: $$userdata{$uname.':'.$udom}[$$idx{id}] = $idhash{$uname};
1.288 raeburn 6348: return;
6349: }
1.275 raeburn 6350:
1.472 raeburn 6351: ###############################################
6352:
6353: =pod
6354:
6355: =item * &get_user_quota()
6356:
6357: Retrieves quota assigned for storage of portfolio files for a user
6358:
6359: Incoming parameters:
6360: 1. user's username
6361: 2. user's domain
6362:
6363: Returns:
1.536 raeburn 6364: 1. Disk quota (in Mb) assigned to student.
6365: 2. (Optional) Type of setting: custom or default
6366: (individually assigned or default for user's
6367: institutional status).
6368: 3. (Optional) - User's institutional status (e.g., faculty, staff
6369: or student - types as defined in localenroll::inst_usertypes
6370: for user's domain, which determines default quota for user.
6371: 4. (Optional) - Default quota which would apply to the user.
1.472 raeburn 6372:
6373: If a value has been stored in the user's environment,
1.536 raeburn 6374: it will return that, otherwise it returns the maximal default
6375: defined for the user's instituional status(es) in the domain.
1.472 raeburn 6376:
6377: =cut
6378:
6379: ###############################################
6380:
6381:
6382: sub get_user_quota {
6383: my ($uname,$udom) = @_;
1.536 raeburn 6384: my ($quota,$quotatype,$settingstatus,$defquota);
1.472 raeburn 6385: if (!defined($udom)) {
6386: $udom = $env{'user.domain'};
6387: }
6388: if (!defined($uname)) {
6389: $uname = $env{'user.name'};
6390: }
6391: if (($udom eq '' || $uname eq '') ||
6392: ($udom eq 'public') && ($uname eq 'public')) {
6393: $quota = 0;
1.536 raeburn 6394: $quotatype = 'default';
6395: $defquota = 0;
1.472 raeburn 6396: } else {
1.536 raeburn 6397: my $inststatus;
1.472 raeburn 6398: if ($udom eq $env{'user.domain'} && $uname eq $env{'user.name'}) {
6399: $quota = $env{'environment.portfolioquota'};
1.536 raeburn 6400: $inststatus = $env{'environment.inststatus'};
1.472 raeburn 6401: } else {
1.536 raeburn 6402: my %userenv =
6403: &Apache::lonnet::get('environment',['portfolioquota',
6404: 'inststatus'],$udom,$uname);
1.472 raeburn 6405: my ($tmp) = keys(%userenv);
6406: if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
6407: $quota = $userenv{'portfolioquota'};
1.536 raeburn 6408: $inststatus = $userenv{'inststatus'};
1.472 raeburn 6409: } else {
6410: undef(%userenv);
6411: }
6412: }
1.536 raeburn 6413: ($defquota,$settingstatus) = &default_quota($udom,$inststatus);
1.472 raeburn 6414: if ($quota eq '') {
1.536 raeburn 6415: $quota = $defquota;
6416: $quotatype = 'default';
6417: } else {
6418: $quotatype = 'custom';
1.472 raeburn 6419: }
6420: }
1.536 raeburn 6421: if (wantarray) {
6422: return ($quota,$quotatype,$settingstatus,$defquota);
6423: } else {
6424: return $quota;
6425: }
1.472 raeburn 6426: }
6427:
6428: ###############################################
6429:
6430: =pod
6431:
6432: =item * &default_quota()
6433:
1.536 raeburn 6434: Retrieves default quota assigned for storage of user portfolio files,
6435: given an (optional) user's institutional status.
1.472 raeburn 6436:
6437: Incoming parameters:
6438: 1. domain
1.536 raeburn 6439: 2. (Optional) institutional status(es). This is a : separated list of
6440: status types (e.g., faculty, staff, student etc.)
6441: which apply to the user for whom the default is being retrieved.
6442: If the institutional status string in undefined, the domain
6443: default quota will be returned.
1.472 raeburn 6444:
6445: Returns:
6446: 1. Default disk quota (in Mb) for user portfolios in the domain.
1.536 raeburn 6447: 2. (Optional) institutional type which determined the value of the
6448: default quota.
1.472 raeburn 6449:
6450: If a value has been stored in the domain's configuration db,
6451: it will return that, otherwise it returns 20 (for backwards
6452: compatibility with domains which have not set up a configuration
6453: db file; the original statically defined portfolio quota was 20 Mb).
6454:
1.536 raeburn 6455: If the user's status includes multiple types (e.g., staff and student),
6456: the largest default quota which applies to the user determines the
6457: default quota returned.
6458:
1.472 raeburn 6459: =cut
6460:
6461: ###############################################
6462:
6463:
6464: sub default_quota {
1.536 raeburn 6465: my ($udom,$inststatus) = @_;
6466: my ($defquota,$settingstatus);
6467: my %quotahash = &Apache::lonnet::get_dom('configuration',
1.622 raeburn 6468: ['quotas'],$udom);
6469: if (ref($quotahash{'quotas'}) eq 'HASH') {
1.536 raeburn 6470: if ($inststatus ne '') {
6471: my @statuses = split(/:/,$inststatus);
6472: foreach my $item (@statuses) {
1.622 raeburn 6473: if ($quotahash{'quotas'}{$item} ne '') {
1.536 raeburn 6474: if ($defquota eq '') {
1.622 raeburn 6475: $defquota = $quotahash{'quotas'}{$item};
1.536 raeburn 6476: $settingstatus = $item;
1.622 raeburn 6477: } elsif ($quotahash{'quotas'}{$item} > $defquota) {
6478: $defquota = $quotahash{'quotas'}{$item};
1.536 raeburn 6479: $settingstatus = $item;
6480: }
6481: }
6482: }
6483: }
6484: if ($defquota eq '') {
1.622 raeburn 6485: $defquota = $quotahash{'quotas'}{'default'};
1.536 raeburn 6486: $settingstatus = 'default';
6487: }
6488: } else {
6489: $settingstatus = 'default';
6490: $defquota = 20;
6491: }
6492: if (wantarray) {
6493: return ($defquota,$settingstatus);
1.472 raeburn 6494: } else {
1.536 raeburn 6495: return $defquota;
1.472 raeburn 6496: }
6497: }
6498:
1.384 raeburn 6499: sub get_secgrprole_info {
6500: my ($cdom,$cnum,$needroles,$type) = @_;
6501: my %sections_count = &get_sections($cdom,$cnum);
6502: my @sections = (sort {$a <=> $b} keys(%sections_count));
6503: my %curr_groups = &Apache::longroup::coursegroups($cdom,$cnum);
6504: my @groups = sort(keys(%curr_groups));
6505: my $allroles = [];
6506: my $rolehash;
6507: my $accesshash = {
6508: active => 'Currently has access',
6509: future => 'Will have future access',
6510: previous => 'Previously had access',
6511: };
6512: if ($needroles) {
6513: $rolehash = {'all' => 'all'};
1.385 albertel 6514: my %user_roles = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum);
6515: if (&Apache::lonnet::error(%user_roles)) {
6516: undef(%user_roles);
6517: }
6518: foreach my $item (keys(%user_roles)) {
1.384 raeburn 6519: my ($role)=split(/\:/,$item,2);
6520: if ($role eq 'cr') { next; }
6521: if ($role =~ /^cr/) {
6522: $$rolehash{$role} = (split('/',$role))[3];
6523: } else {
6524: $$rolehash{$role} = &Apache::lonnet::plaintext($role,$type);
6525: }
6526: }
6527: foreach my $key (sort(keys(%{$rolehash}))) {
6528: push(@{$allroles},$key);
6529: }
6530: push (@{$allroles},'st');
6531: $$rolehash{'st'} = &Apache::lonnet::plaintext('st',$type);
6532: }
6533: return (\@sections,\@groups,$allroles,$rolehash,$accesshash);
6534: }
6535:
1.555 raeburn 6536: sub user_picker {
1.627 raeburn 6537: my ($dom,$srch,$forcenewuser,$caller,$cancreate,$usertype) = @_;
1.555 raeburn 6538: my $currdom = $dom;
6539: my %curr_selected = (
6540: srchin => 'dom',
1.580 raeburn 6541: srchby => 'lastname',
1.555 raeburn 6542: );
6543: my $srchterm;
1.625 raeburn 6544: if ((ref($srch) eq 'HASH') && ($env{'form.origform'} ne 'crtusername')) {
1.555 raeburn 6545: if ($srch->{'srchby'} ne '') {
6546: $curr_selected{'srchby'} = $srch->{'srchby'};
6547: }
6548: if ($srch->{'srchin'} ne '') {
6549: $curr_selected{'srchin'} = $srch->{'srchin'};
6550: }
6551: if ($srch->{'srchtype'} ne '') {
6552: $curr_selected{'srchtype'} = $srch->{'srchtype'};
6553: }
6554: if ($srch->{'srchdomain'} ne '') {
6555: $currdom = $srch->{'srchdomain'};
6556: }
6557: $srchterm = $srch->{'srchterm'};
6558: }
6559: my %lt=&Apache::lonlocal::texthash(
1.573 raeburn 6560: 'usr' => 'Search criteria',
1.563 raeburn 6561: 'doma' => 'Domain/institution to search',
1.558 albertel 6562: 'uname' => 'username',
6563: 'lastname' => 'last name',
1.555 raeburn 6564: 'lastfirst' => 'last name, first name',
1.558 albertel 6565: 'crs' => 'in this course',
1.576 raeburn 6566: 'dom' => 'in selected LON-CAPA domain',
1.558 albertel 6567: 'alc' => 'all LON-CAPA',
1.573 raeburn 6568: 'instd' => 'in institutional directory for selected domain',
1.558 albertel 6569: 'exact' => 'is',
6570: 'contains' => 'contains',
1.569 raeburn 6571: 'begins' => 'begins with',
1.571 raeburn 6572: 'youm' => "You must include some text to search for.",
6573: 'thte' => "The text you are searching for must contain at least two characters when using a 'begins' type search.",
6574: 'thet' => "The text you are searching for must contain at least three characters when using a 'contains' type search.",
6575: 'yomc' => "You must choose a domain when using an institutional directory search.",
6576: 'ymcd' => "You must choose a domain when using a domain search.",
6577: 'whus' => "When using searching by last,first you must include a comma as separator between last name and first name.",
6578: 'whse' => "When searching by last,first you must include at least one character in the first name.",
6579: 'thfo' => "The following need to be corrected before the search can be run:",
1.555 raeburn 6580: );
1.563 raeburn 6581: my $domform = &select_dom_form($currdom,'srchdomain',1,1);
6582: my $srchinsel = ' <select name="srchin">';
1.555 raeburn 6583:
6584: my @srchins = ('crs','dom','alc','instd');
6585:
6586: foreach my $option (@srchins) {
6587: # FIXME 'alc' option unavailable until
6588: # loncreateuser::print_user_query_page()
6589: # has been completed.
6590: next if ($option eq 'alc');
6591: next if ($option eq 'crs' && !$env{'request.course.id'});
1.563 raeburn 6592: if ($curr_selected{'srchin'} eq $option) {
6593: $srchinsel .= '
6594: <option value="'.$option.'" selected="selected">'.$lt{$option}.'</option>';
6595: } else {
6596: $srchinsel .= '
6597: <option value="'.$option.'">'.$lt{$option}.'</option>';
6598: }
1.555 raeburn 6599: }
1.563 raeburn 6600: $srchinsel .= "\n </select>\n";
1.555 raeburn 6601:
6602: my $srchbysel = ' <select name="srchby">';
1.580 raeburn 6603: foreach my $option ('lastname','lastfirst','uname') {
1.555 raeburn 6604: if ($curr_selected{'srchby'} eq $option) {
6605: $srchbysel .= '
6606: <option value="'.$option.'" selected="selected">'.$lt{$option}.'</option>';
6607: } else {
6608: $srchbysel .= '
6609: <option value="'.$option.'">'.$lt{$option}.'</option>';
6610: }
6611: }
6612: $srchbysel .= "\n </select>\n";
6613:
6614: my $srchtypesel = ' <select name="srchtype">';
1.580 raeburn 6615: foreach my $option ('begins','contains','exact') {
1.555 raeburn 6616: if ($curr_selected{'srchtype'} eq $option) {
6617: $srchtypesel .= '
6618: <option value="'.$option.'" selected="selected">'.$lt{$option}.'</option>';
6619: } else {
6620: $srchtypesel .= '
6621: <option value="'.$option.'">'.$lt{$option}.'</option>';
6622: }
6623: }
6624: $srchtypesel .= "\n </select>\n";
6625:
1.558 albertel 6626: my ($newuserscript,$new_user_create);
1.556 raeburn 6627:
6628: if ($forcenewuser) {
1.576 raeburn 6629: if (ref($srch) eq 'HASH') {
6630: if ($srch->{'srchby'} eq 'uname' && $srch->{'srchtype'} eq 'exact' && $srch->{'srchin'} eq 'dom' && $srch->{'srchdomain'} eq $env{'request.role.domain'}) {
1.627 raeburn 6631: if ($cancreate) {
6632: $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>';
6633: } else {
6634: my $helplink = ' href="javascript:helpMenu('."'display'".')"';
6635: my %usertypetext = (
6636: official => 'institutional',
6637: unofficial => 'non-institutional',
6638: );
6639: $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 />';
6640: }
1.576 raeburn 6641: }
6642: }
6643:
1.556 raeburn 6644: $newuserscript = <<"ENDSCRIPT";
6645:
1.570 raeburn 6646: function setSearch(createnew,callingForm) {
1.556 raeburn 6647: if (createnew == 1) {
1.570 raeburn 6648: for (var i=0; i<callingForm.srchby.length; i++) {
6649: if (callingForm.srchby.options[i].value == 'uname') {
6650: callingForm.srchby.selectedIndex = i;
1.556 raeburn 6651: }
6652: }
1.570 raeburn 6653: for (var i=0; i<callingForm.srchin.length; i++) {
6654: if ( callingForm.srchin.options[i].value == 'dom') {
6655: callingForm.srchin.selectedIndex = i;
1.556 raeburn 6656: }
6657: }
1.570 raeburn 6658: for (var i=0; i<callingForm.srchtype.length; i++) {
6659: if (callingForm.srchtype.options[i].value == 'exact') {
6660: callingForm.srchtype.selectedIndex = i;
1.556 raeburn 6661: }
6662: }
1.570 raeburn 6663: for (var i=0; i<callingForm.srchdomain.length; i++) {
6664: if (callingForm.srchdomain.options[i].value == '$env{'request.role.domain'}') {
6665: callingForm.srchdomain.selectedIndex = i;
1.556 raeburn 6666: }
6667: }
6668: }
6669: }
6670: ENDSCRIPT
1.558 albertel 6671:
1.556 raeburn 6672: }
6673:
1.555 raeburn 6674: my $output = <<"END_BLOCK";
1.556 raeburn 6675: <script type="text/javascript">
1.570 raeburn 6676: function validateEntry(callingForm) {
1.558 albertel 6677:
1.556 raeburn 6678: var checkok = 1;
1.558 albertel 6679: var srchin;
1.570 raeburn 6680: for (var i=0; i<callingForm.srchin.length; i++) {
6681: if ( callingForm.srchin[i].checked ) {
6682: srchin = callingForm.srchin[i].value;
1.558 albertel 6683: }
6684: }
6685:
1.570 raeburn 6686: var srchtype = callingForm.srchtype.options[callingForm.srchtype.selectedIndex].value;
6687: var srchby = callingForm.srchby.options[callingForm.srchby.selectedIndex].value;
6688: var srchdomain = callingForm.srchdomain.options[callingForm.srchdomain.selectedIndex].value;
6689: var srchterm = callingForm.srchterm.value;
6690: var srchin = callingForm.srchin.options[callingForm.srchin.selectedIndex].value;
1.556 raeburn 6691: var msg = "";
6692:
6693: if (srchterm == "") {
6694: checkok = 0;
1.571 raeburn 6695: msg += "$lt{'youm'}\\n";
1.556 raeburn 6696: }
6697:
1.569 raeburn 6698: if (srchtype== 'begins') {
6699: if (srchterm.length < 2) {
6700: checkok = 0;
1.571 raeburn 6701: msg += "$lt{'thte'}\\n";
1.569 raeburn 6702: }
6703: }
6704:
1.556 raeburn 6705: if (srchtype== 'contains') {
6706: if (srchterm.length < 3) {
6707: checkok = 0;
1.571 raeburn 6708: msg += "$lt{'thet'}\\n";
1.556 raeburn 6709: }
6710: }
6711: if (srchin == 'instd') {
6712: if (srchdomain == '') {
6713: checkok = 0;
1.571 raeburn 6714: msg += "$lt{'yomc'}\\n";
1.556 raeburn 6715: }
6716: }
6717: if (srchin == 'dom') {
6718: if (srchdomain == '') {
6719: checkok = 0;
1.571 raeburn 6720: msg += "$lt{'ymcd'}\\n";
1.556 raeburn 6721: }
6722: }
6723: if (srchby == 'lastfirst') {
6724: if (srchterm.indexOf(",") == -1) {
6725: checkok = 0;
1.571 raeburn 6726: msg += "$lt{'whus'}\\n";
1.556 raeburn 6727: }
6728: if (srchterm.indexOf(",") == srchterm.length -1) {
6729: checkok = 0;
1.571 raeburn 6730: msg += "$lt{'whse'}\\n";
1.556 raeburn 6731: }
6732: }
6733: if (checkok == 0) {
1.571 raeburn 6734: alert("$lt{'thfo'}\\n"+msg);
1.556 raeburn 6735: return;
6736: }
6737: if (checkok == 1) {
1.570 raeburn 6738: callingForm.submit();
1.556 raeburn 6739: }
6740: }
6741:
6742: $newuserscript
6743:
6744: </script>
1.558 albertel 6745:
6746: $new_user_create
6747:
1.555 raeburn 6748: <table>
1.558 albertel 6749: <tr>
1.573 raeburn 6750: <td>$lt{'doma'}:</td>
6751: <td>$domform</td>
6752: </td>
6753: </tr>
6754: <tr>
6755: <td>$lt{'usr'}:</td>
1.563 raeburn 6756: <td>$srchbysel
6757: $srchtypesel
6758: <input type="text" size="15" name="srchterm" value="$srchterm" />
1.564 albertel 6759: $srchinsel
1.563 raeburn 6760: </td>
6761: </tr>
1.555 raeburn 6762: </table>
6763: <br />
6764: END_BLOCK
1.558 albertel 6765:
1.555 raeburn 6766: return $output;
6767: }
6768:
1.612 raeburn 6769: sub user_rule_check {
1.615 raeburn 6770: my ($usershash,$checks,$alerts,$rulematch,$inst_results,$curr_rules,$got_rules) = @_;
1.612 raeburn 6771: my $response;
6772: if (ref($usershash) eq 'HASH') {
6773: foreach my $user (keys(%{$usershash})) {
6774: my ($uname,$udom) = split(/:/,$user);
6775: next if ($udom eq '' || $uname eq '');
1.615 raeburn 6776: my ($id,$newuser);
1.612 raeburn 6777: if (ref($usershash->{$user}) eq 'HASH') {
1.615 raeburn 6778: $newuser = $usershash->{$user}->{'newuser'};
1.612 raeburn 6779: $id = $usershash->{$user}->{'id'};
6780: }
6781: my $inst_response;
6782: if (ref($checks) eq 'HASH') {
6783: if (defined($checks->{'username'})) {
1.615 raeburn 6784: ($inst_response,%{$inst_results->{$user}}) =
1.612 raeburn 6785: &Apache::lonnet::get_instuser($udom,$uname);
6786: } elsif (defined($checks->{'id'})) {
1.615 raeburn 6787: ($inst_response,%{$inst_results->{$user}}) =
1.612 raeburn 6788: &Apache::lonnet::get_instuser($udom,undef,$id);
6789: }
1.615 raeburn 6790: } else {
6791: ($inst_response,%{$inst_results->{$user}}) =
6792: &Apache::lonnet::get_instuser($udom,$uname);
6793: return;
1.612 raeburn 6794: }
1.615 raeburn 6795: if (!$got_rules->{$udom}) {
1.612 raeburn 6796: my %domconfig = &Apache::lonnet::get_dom('configuration',
6797: ['usercreation'],$udom);
6798: if (ref($domconfig{'usercreation'}) eq 'HASH') {
1.615 raeburn 6799: foreach my $item ('username','id') {
1.612 raeburn 6800: if (ref($domconfig{'usercreation'}{$item.'_rule'}) eq 'ARRAY') {
6801: $$curr_rules{$udom}{$item} =
6802: $domconfig{'usercreation'}{$item.'_rule'};
1.585 raeburn 6803: }
6804: }
6805: }
1.615 raeburn 6806: $got_rules->{$udom} = 1;
1.585 raeburn 6807: }
1.612 raeburn 6808: foreach my $item (keys(%{$checks})) {
6809: if (ref($$curr_rules{$udom}) eq 'HASH') {
6810: if (ref($$curr_rules{$udom}{$item}) eq 'ARRAY') {
6811: if (@{$$curr_rules{$udom}{$item}} > 0) {
6812: my %rule_check = &Apache::lonnet::inst_rulecheck($udom,$uname,$id,$item,$$curr_rules{$udom}{$item});
6813: foreach my $rule (@{$$curr_rules{$udom}{$item}}) {
6814: if ($rule_check{$rule}) {
6815: $$rulematch{$user}{$item} = $rule;
6816: if ($inst_response eq 'ok') {
1.615 raeburn 6817: if (ref($inst_results) eq 'HASH') {
6818: if (ref($inst_results->{$user}) eq 'HASH') {
6819: if (keys(%{$inst_results->{$user}}) == 0) {
6820: $$alerts{$item}{$udom}{$uname} = 1;
6821: }
1.612 raeburn 6822: }
6823: }
1.615 raeburn 6824: }
6825: last;
1.585 raeburn 6826: }
6827: }
6828: }
6829: }
6830: }
6831: }
6832: }
6833: }
1.612 raeburn 6834: return;
6835: }
6836:
6837: sub user_rule_formats {
6838: my ($domain,$domdesc,$curr_rules,$check) = @_;
6839: my %text = (
6840: 'username' => 'Usernames',
6841: 'id' => 'IDs',
6842: );
6843: my $output;
6844: my ($rules,$ruleorder) = &Apache::lonnet::inst_userrules($domain,$check);
6845: if ((ref($rules) eq 'HASH') && (ref($ruleorder) eq 'ARRAY')) {
6846: if (@{$ruleorder} > 0) {
6847: $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>';
6848: foreach my $rule (@{$ruleorder}) {
6849: if (ref($curr_rules) eq 'ARRAY') {
6850: if (grep(/^\Q$rule\E$/,@{$curr_rules})) {
6851: if (ref($rules->{$rule}) eq 'HASH') {
6852: $output .= '<li>'.$rules->{$rule}{'name'}.': '.
6853: $rules->{$rule}{'desc'}.'</li>';
6854: }
6855: }
6856: }
6857: }
6858: $output .= '</ul>';
6859: }
6860: }
6861: return $output;
6862: }
6863:
6864: sub instrule_disallow_msg {
1.615 raeburn 6865: my ($checkitem,$domdesc,$count,$mode) = @_;
1.612 raeburn 6866: my $response;
6867: my %text = (
6868: item => 'username',
6869: items => 'usernames',
6870: match => 'matches',
6871: do => 'does',
6872: action => 'a username',
6873: one => 'one',
6874: );
6875: if ($count > 1) {
6876: $text{'item'} = 'usernames';
6877: $text{'match'} ='match';
6878: $text{'do'} = 'do';
6879: $text{'action'} = 'usernames',
6880: $text{'one'} = 'ones';
6881: }
6882: if ($checkitem eq 'id') {
6883: $text{'items'} = 'IDs';
6884: $text{'item'} = 'ID';
6885: $text{'action'} = 'an ID';
1.615 raeburn 6886: if ($count > 1) {
6887: $text{'item'} = 'IDs';
6888: $text{'action'} = 'IDs';
6889: }
1.612 raeburn 6890: }
1.674 bisitz 6891: $response = &mt("The $text{'item'} you chose $text{'match'} the format of $text{'items'} defined for [_1], but the $text{'item'} $text{'do'} not exist in the institutional directory.",'<span class="LC_cusr_emph">'.$domdesc.'</span>').'<br />';
1.615 raeburn 6892: if ($mode eq 'upload') {
6893: if ($checkitem eq 'username') {
6894: $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'}.");
6895: } elsif ($checkitem eq 'id') {
1.674 bisitz 6896: $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 Student/Employee ID field.");
1.615 raeburn 6897: }
1.669 raeburn 6898: } elsif ($mode eq 'selfcreate') {
6899: if ($checkitem eq 'id') {
6900: $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.");
6901: }
1.615 raeburn 6902: } else {
6903: if ($checkitem eq 'username') {
6904: $response .= &mt("You must choose $text{'action'} with a different format -- $text{'one'} that will not conflict with 'official' institutional $text{'items'}.");
6905: } elsif ($checkitem eq 'id') {
6906: $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.");
6907: }
1.612 raeburn 6908: }
6909: return $response;
1.585 raeburn 6910: }
6911:
1.624 raeburn 6912: sub personal_data_fieldtitles {
6913: my %fieldtitles = &Apache::lonlocal::texthash (
6914: id => 'Student/Employee ID',
6915: permanentemail => 'E-mail address',
6916: lastname => 'Last Name',
6917: firstname => 'First Name',
6918: middlename => 'Middle Name',
6919: generation => 'Generation',
6920: gen => 'Generation',
6921: );
6922: return %fieldtitles;
6923: }
6924:
1.642 raeburn 6925: sub sorted_inst_types {
6926: my ($dom) = @_;
6927: my ($usertypes,$order) = &Apache::lonnet::retrieve_inst_usertypes($dom);
6928: my $othertitle = &mt('All users');
6929: if ($env{'request.course.id'}) {
1.668 raeburn 6930: $othertitle = &mt('Any users');
1.642 raeburn 6931: }
6932: my @types;
6933: if (ref($order) eq 'ARRAY') {
6934: @types = @{$order};
6935: }
6936: if (@types == 0) {
6937: if (ref($usertypes) eq 'HASH') {
6938: @types = sort(keys(%{$usertypes}));
6939: }
6940: }
6941: if (keys(%{$usertypes}) > 0) {
6942: $othertitle = &mt('Other users');
6943: }
6944: return ($othertitle,$usertypes,\@types);
6945: }
6946:
1.645 raeburn 6947: sub get_institutional_codes {
6948: my ($settings,$allcourses,$LC_code) = @_;
6949: # Get complete list of course sections to update
6950: my @currsections = ();
6951: my @currxlists = ();
6952: my $coursecode = $$settings{'internal.coursecode'};
6953:
6954: if ($$settings{'internal.sectionnums'} ne '') {
6955: @currsections = split(/,/,$$settings{'internal.sectionnums'});
6956: }
6957:
6958: if ($$settings{'internal.crosslistings'} ne '') {
6959: @currxlists = split(/,/,$$settings{'internal.crosslistings'});
6960: }
6961:
6962: if (@currxlists > 0) {
6963: foreach (@currxlists) {
6964: if (m/^([^:]+):(\w*)$/) {
6965: unless (grep/^$1$/,@{$allcourses}) {
6966: push @{$allcourses},$1;
6967: $$LC_code{$1} = $2;
6968: }
6969: }
6970: }
6971: }
6972:
6973: if (@currsections > 0) {
6974: foreach (@currsections) {
6975: if (m/^(\w+):(\w*)$/) {
6976: my $sec = $coursecode.$1;
6977: my $lc_sec = $2;
6978: unless (grep/^$sec$/,@{$allcourses}) {
6979: push @{$allcourses},$sec;
6980: $$LC_code{$sec} = $lc_sec;
6981: }
6982: }
6983: }
6984: }
6985: return;
6986: }
6987:
1.112 bowersj2 6988: =pod
6989:
1.549 albertel 6990: =back
6991:
6992: =head1 HTTP Helpers
6993:
6994: =over 4
6995:
1.648 raeburn 6996: =item * &get_unprocessed_cgi($query,$possible_names)
1.112 bowersj2 6997:
1.258 albertel 6998: Modify the %env hash to contain unprocessed CGI form parameters held in
1.112 bowersj2 6999: $query. The parameters listed in $possible_names (an array reference),
1.258 albertel 7000: will be set in $env{'form.name'} if they do not already exist.
1.112 bowersj2 7001:
7002: Typically called with $ENV{'QUERY_STRING'} as the first parameter.
7003: $possible_names is an ref to an array of form element names. As an example:
7004: get_unprocessed_cgi($ENV{'QUERY_STRING'},['uname','udom']);
1.258 albertel 7005: will result in $env{'form.uname'} and $env{'form.udom'} being set.
1.112 bowersj2 7006:
7007: =cut
1.1 albertel 7008:
1.6 albertel 7009: sub get_unprocessed_cgi {
1.25 albertel 7010: my ($query,$possible_names)= @_;
1.26 matthew 7011: # $Apache::lonxml::debug=1;
1.356 albertel 7012: foreach my $pair (split(/&/,$query)) {
7013: my ($name, $value) = split(/=/,$pair);
1.369 www 7014: $name = &unescape($name);
1.25 albertel 7015: if (!defined($possible_names) || (grep {$_ eq $name} @$possible_names)) {
7016: $value =~ tr/+/ /;
7017: $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
1.258 albertel 7018: unless (defined($env{'form.'.$name})) { &add_to_env('form.'.$name,$value) };
1.25 albertel 7019: }
1.16 harris41 7020: }
1.6 albertel 7021: }
7022:
1.112 bowersj2 7023: =pod
7024:
1.648 raeburn 7025: =item * &cacheheader()
1.112 bowersj2 7026:
7027: returns cache-controlling header code
7028:
7029: =cut
7030:
1.7 albertel 7031: sub cacheheader {
1.258 albertel 7032: unless ($env{'request.method'} eq 'GET') { return ''; }
1.216 albertel 7033: my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
7034: my $output .='<meta HTTP-EQUIV="Expires" CONTENT="'.$date.'" />
1.7 albertel 7035: <meta HTTP-EQUIV="Cache-control" CONTENT="no-cache" />
7036: <meta HTTP-EQUIV="Pragma" CONTENT="no-cache" />';
1.216 albertel 7037: return $output;
1.7 albertel 7038: }
7039:
1.112 bowersj2 7040: =pod
7041:
1.648 raeburn 7042: =item * &no_cache($r)
1.112 bowersj2 7043:
7044: specifies header code to not have cache
7045:
7046: =cut
7047:
1.9 albertel 7048: sub no_cache {
1.216 albertel 7049: my ($r) = @_;
7050: if ($ENV{'REQUEST_METHOD'} ne 'GET' &&
1.258 albertel 7051: $env{'request.method'} ne 'GET') { return ''; }
1.216 albertel 7052: my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime(time));
7053: $r->no_cache(1);
7054: $r->header_out("Expires" => $date);
7055: $r->header_out("Pragma" => "no-cache");
1.123 www 7056: }
7057:
7058: sub content_type {
1.181 albertel 7059: my ($r,$type,$charset) = @_;
1.299 foxr 7060: if ($r) {
7061: # Note that printout.pl calls this with undef for $r.
7062: &no_cache($r);
7063: }
1.258 albertel 7064: if ($env{'browser.mathml'} && $type eq 'text/html') { $type='text/xml'; }
1.181 albertel 7065: unless ($charset) {
7066: $charset=&Apache::lonlocal::current_encoding;
7067: }
7068: if ($charset) { $type.='; charset='.$charset; }
7069: if ($r) {
7070: $r->content_type($type);
7071: } else {
7072: print("Content-type: $type\n\n");
7073: }
1.9 albertel 7074: }
1.25 albertel 7075:
1.112 bowersj2 7076: =pod
7077:
1.648 raeburn 7078: =item * &add_to_env($name,$value)
1.112 bowersj2 7079:
1.258 albertel 7080: adds $name to the %env hash with value
1.112 bowersj2 7081: $value, if $name already exists, the entry is converted to an array
7082: reference and $value is added to the array.
7083:
7084: =cut
7085:
1.25 albertel 7086: sub add_to_env {
7087: my ($name,$value)=@_;
1.258 albertel 7088: if (defined($env{$name})) {
7089: if (ref($env{$name})) {
1.25 albertel 7090: #already have multiple values
1.258 albertel 7091: push(@{ $env{$name} },$value);
1.25 albertel 7092: } else {
7093: #first time seeing multiple values, convert hash entry to an arrayref
1.258 albertel 7094: my $first=$env{$name};
7095: undef($env{$name});
7096: push(@{ $env{$name} },$first,$value);
1.25 albertel 7097: }
7098: } else {
1.258 albertel 7099: $env{$name}=$value;
1.25 albertel 7100: }
1.31 albertel 7101: }
1.149 albertel 7102:
7103: =pod
7104:
1.648 raeburn 7105: =item * &get_env_multiple($name)
1.149 albertel 7106:
1.258 albertel 7107: gets $name from the %env hash, it seemlessly handles the cases where multiple
1.149 albertel 7108: values may be defined and end up as an array ref.
7109:
7110: returns an array of values
7111:
7112: =cut
7113:
7114: sub get_env_multiple {
7115: my ($name) = @_;
7116: my @values;
1.258 albertel 7117: if (defined($env{$name})) {
1.149 albertel 7118: # exists is it an array
1.258 albertel 7119: if (ref($env{$name})) {
7120: @values=@{ $env{$name} };
1.149 albertel 7121: } else {
1.258 albertel 7122: $values[0]=$env{$name};
1.149 albertel 7123: }
7124: }
7125: return(@values);
7126: }
7127:
1.660 raeburn 7128: sub ask_for_embedded_content {
7129: my ($actionurl,$state,$allfiles,$codebase,$args)=@_;
7130: my $upload_output = '
7131: <form name="upload_embedded" action="'.$actionurl.'"
7132: method="post" enctype="multipart/form-data">';
7133: $upload_output .= $state;
1.661 raeburn 7134: $upload_output .= '<b>Upload embedded files</b>:<br />'.&start_data_table();
1.660 raeburn 7135:
7136: my $num = 0;
7137: foreach my $embed_file (sort {lc($a) cmp lc($b)} keys(%{$allfiles})) {
7138: $upload_output .= &start_data_table_row().
7139: '<td>'.$embed_file.'</td><td>';
7140: if ($args->{'ignore_remote_references'}
7141: && $embed_file =~ m{^\w+://}) {
7142: $upload_output.='<span class="LC_warning">'.&mt("URL points to other server.").'</span>';
7143: } elsif ($args->{'error_on_invalid_names'}
7144: && $embed_file ne &Apache::lonnet::clean_filename($embed_file,{'keep_path' => 1,})) {
7145:
7146: $upload_output.='<span class="LC_warning">'.&mt("Invalid characters").'</span>';
7147:
7148: } else {
7149: $upload_output .='
1.661 raeburn 7150: <input name="embedded_item_'.$num.'" type="file" value="" />
1.660 raeburn 7151: <input name="embedded_orig_'.$num.'" type="hidden" value="'.&escape($embed_file).'" />';
7152: my $attrib = join(':',@{$$allfiles{$embed_file}});
7153: $upload_output .=
7154: "\n\t\t".
7155: '<input name="embedded_attrib_'.$num.'" type="hidden" value="'.
7156: $attrib.'" />';
7157: if (exists($$codebase{$embed_file})) {
7158: $upload_output .=
7159: "\n\t\t".
7160: '<input name="codebase_'.$num.'" type="hidden" value="'.
7161: &escape($$codebase{$embed_file}).'" />';
7162: }
7163: }
7164: $upload_output .= '</td>'.&Apache::loncommon::end_data_table_row();
7165: $num++;
7166: }
7167: $upload_output .= &Apache::loncommon::end_data_table().'<br />
7168: <input type ="hidden" name="number_embedded_items" value="'.$num.'" />
7169: <input type ="submit" value="'.&mt('Upload Listed Files').'" />
7170: '.&mt('(only files for which a location has been provided will be uploaded)').'
7171: </form>';
7172: return $upload_output;
7173: }
7174:
1.661 raeburn 7175: sub upload_embedded {
7176: my ($context,$dirpath,$uname,$udom,$dir_root,$url_root,$group,$disk_quota,
7177: $current_disk_usage) = @_;
7178: my $output;
7179: for (my $i=0; $i<$env{'form.number_embedded_items'}; $i++) {
7180: next if (!exists($env{'form.embedded_item_'.$i.'.filename'}));
7181: my $orig_uploaded_filename =
7182: $env{'form.embedded_item_'.$i.'.filename'};
7183:
7184: $env{'form.embedded_orig_'.$i} =
7185: &unescape($env{'form.embedded_orig_'.$i});
7186: my ($path,$fname) =
7187: ($env{'form.embedded_orig_'.$i} =~ m{(.*/)([^/]*)});
7188: # no path, whole string is fname
7189: if (!$fname) { $fname = $env{'form.embedded_orig_'.$i} };
7190:
7191: $path = $env{'form.currentpath'}.$path;
7192: $fname = &Apache::lonnet::clean_filename($fname);
7193: # See if there is anything left
7194: next if ($fname eq '');
7195:
7196: # Check if file already exists as a file or directory.
7197: my ($state,$msg);
7198: if ($context eq 'portfolio') {
7199: my $port_path = $dirpath;
7200: if ($group ne '') {
7201: $port_path = "groups/$group/$port_path";
7202: }
7203: ($state,$msg) = &check_for_upload($path,$fname,$group,'embedded_item_'.$i,
7204: $dir_root,$port_path,$disk_quota,
7205: $current_disk_usage,$uname,$udom);
7206: if ($state eq 'will_exceed_quota'
7207: || $state eq 'file_locked'
7208: || $state eq 'file_exists' ) {
7209: $output .= $msg;
7210: next;
7211: }
7212: } elsif (($context eq 'author') || ($context eq 'testbank')) {
7213: ($state,$msg) = &check_for_existing($path,$fname,'embedded_item_'.$i);
7214: if ($state eq 'exists') {
7215: $output .= $msg;
7216: next;
7217: }
7218: }
7219: # Check if extension is valid
7220: if (($fname =~ /\.(\w+)$/) &&
7221: (&Apache::loncommon::fileembstyle($1) eq 'hdn')) {
7222: $output .= &mt('Invalid file extension ([_1]) - reserved for LONCAPA use - rename the file with a different extension and re-upload. ',$1);
7223: next;
7224: } elsif (($fname =~ /\.(\w+)$/) &&
7225: (!defined(&Apache::loncommon::fileembstyle($1)))) {
7226: $output .= &mt('Unrecognized file extension ([_1]) - rename the file with a proper extension and re-upload.',$1);
7227: next;
7228: } elsif ($fname=~/\.(\d+)\.(\w+)$/) {
7229: $output .= &mt('File name not allowed - rename the file to remove the number immediately before the file extension([_1]) and re-upload.',$2);
7230: next;
7231: }
7232:
7233: $env{'form.embedded_item_'.$i.'.filename'}=$fname;
7234: if ($context eq 'portfolio') {
7235: my $result=
7236: &Apache::lonnet::userfileupload('embedded_item_'.$i,'',
7237: $dirpath.$path);
7238: if ($result !~ m|^/uploaded/|) {
7239: $output .= '<span class="LC_error">'
7240: .&mt('An error occurred ([_1]) while trying to upload [_2] for embedded element [_3].'
7241: ,$result,$orig_uploaded_filename,$env{'form.embedded_orig_'.$i})
7242: .'</span><br />';
7243: next;
7244: } else {
7245: $output .= '<p>'.&mt('Uploaded [_1]','<span class="LC_filename">'.
7246: $path.$fname.'</span>').'</p>';
7247: }
7248: } else {
7249: # Save the file
7250: my $target = $env{'form.embedded_item_'.$i};
7251: my $fullpath = $dir_root.$dirpath.'/'.$path;
7252: my $dest = $fullpath.$fname;
7253: my $url = $url_root.$dirpath.'/'.$path.$fname;
7254: my @parts=split(/\//,$fullpath);
7255: my $count;
7256: my $filepath = $dir_root;
7257: for ($count=4;$count<=$#parts;$count++) {
7258: $filepath .= "/$parts[$count]";
7259: if ((-e $filepath)!=1) {
7260: mkdir($filepath,0770);
7261: }
7262: }
7263: my $fh;
7264: if (!open($fh,'>'.$dest)) {
7265: &Apache::lonnet::logthis('Failed to create '.$dest);
7266: $output .= '<span class="LC_error">'.
7267: &mt('An error occurred while trying to upload [_1] for embedded element [_2].',$orig_uploaded_filename,$env{'form.embedded_orig_'.$i}).
7268: '</span><br />';
7269: } else {
7270: if (!print $fh $env{'form.embedded_item_'.$i}) {
7271: &Apache::lonnet::logthis('Failed to write to '.$dest);
7272: $output .= '<span class="LC_error">'.
7273: &mt('An error occurred while writing the file [_1] for embedded element [_2].',$orig_uploaded_filename,$env{'form.embedded_orig_'.$i}).
7274: '</span><br />';
7275: } else {
7276: if ($context eq 'testbank') {
7277: $output .= &mt('Embedded file uploaded successfully:').
7278: ' <a href="'.$url.'">'.
7279: $orig_uploaded_filename.'</a><br />';
7280: } else {
7281: $output .= '<font size="+2">'.
7282: &mt('View embedded file: [_1]','<a href="'.$url.'">'.
7283: $orig_uploaded_filename.'</a>').'</font><br />';
7284: }
7285: }
7286: close($fh);
7287: }
7288: }
7289: }
7290: return $output;
7291: }
7292:
7293: sub check_for_existing {
7294: my ($path,$fname,$element) = @_;
7295: my ($state,$msg);
7296: if (-d $path.'/'.$fname) {
7297: $state = 'exists';
7298: $msg = &mt('Unable to upload [_1]. A directory by that name was found in [_2].','<span class="LC_filename">'.$fname.'</span>',$path);
7299: } elsif (-e $path.'/'.$fname) {
7300: $state = 'exists';
7301: $msg = &mt('Unable to upload [_1]. A file by that name was found in [_2].','<span class="LC_filename">'.$fname.'</span>',$path);
7302: }
7303: if ($state eq 'exists') {
7304: $msg = '<span class="LC_error">'.$msg.'</span><br />';
7305: }
7306: return ($state,$msg);
7307: }
7308:
7309: sub check_for_upload {
7310: my ($path,$fname,$group,$element,$portfolio_root,$port_path,
7311: $disk_quota,$current_disk_usage,$uname,$udom) = @_;
7312: my $filesize = (length($env{'form.'.$element})) / 1000; #express in k (1024?)
7313: my $getpropath = 1;
7314: my @dir_list = &Apache::lonnet::dirlist($portfolio_root.$path,$udom,$uname,
7315: $getpropath);
7316: my $found_file = 0;
7317: my $locked_file = 0;
7318: foreach my $line (@dir_list) {
7319: my ($file_name)=split(/\&/,$line,2);
7320: if ($file_name eq $fname){
7321: $file_name = $path.$file_name;
7322: if ($group ne '') {
7323: $file_name = $group.$file_name;
7324: }
7325: $found_file = 1;
7326: if (&Apache::lonnet::is_locked($file_name,$udom,$uname) eq 'true') {
7327: $locked_file = 1;
7328: }
7329: }
7330: }
7331: if (($current_disk_usage + $filesize) > $disk_quota){
7332: my $msg = '<span class="LC_error">'.
7333: &mt('Unable to upload [_1]. (size = [_2] kilobytes). Disk quota will be exceeded.','<span class="LC_filename">'.$fname.'</span>',$filesize).'</span>'.
7334: '<br />'.&mt('Disk quota is [_1] kilobytes. Your current disk usage is [_2] kilobytes.',$disk_quota,$current_disk_usage);
7335: return ('will_exceed_quota',$msg);
7336: } elsif ($found_file) {
7337: if ($locked_file) {
7338: my $msg = '<span class="LC_error">';
7339: $msg .= &mt('Unable to upload [_1]. A locked file by that name was found in [_2].','<span class="LC_filename">'.$fname.'</span>','<span class="LC_filename">'.$port_path.$env{'form.currentpath'}.'</span>');
7340: $msg .= '</span><br />';
7341: $msg .= &mt('You will be able to rename or delete existing [_1] after a grade has been assigned.','<span class="LC_filename">'.$fname.'</span>');
7342: return ('file_locked',$msg);
7343: } else {
7344: my $msg = '<span class="LC_error">';
7345: $msg .= &mt('Unable to upload [_1]. A file by that name was found in [_2].','<span class="LC_filename">'.$fname.'</span>',$port_path.$env{'form.currentpath'});
7346: $msg .= '</span>';
7347: $msg .= '<br />';
7348: $msg .= &mt('To upload, rename or delete existing [_1] in [_2].','<span class="LC_filename">'.$fname.'</span>', $port_path.$env{'form.currentpath'});
7349: return ('file_exists',$msg);
7350: }
7351: }
7352: }
7353:
1.31 albertel 7354:
1.41 ng 7355: =pod
1.45 matthew 7356:
1.464 albertel 7357: =back
1.41 ng 7358:
1.112 bowersj2 7359: =head1 CSV Upload/Handling functions
1.38 albertel 7360:
1.41 ng 7361: =over 4
7362:
1.648 raeburn 7363: =item * &upfile_store($r)
1.41 ng 7364:
7365: Store uploaded file, $r should be the HTTP Request object,
1.258 albertel 7366: needs $env{'form.upfile'}
1.41 ng 7367: returns $datatoken to be put into hidden field
7368:
7369: =cut
1.31 albertel 7370:
7371: sub upfile_store {
7372: my $r=shift;
1.258 albertel 7373: $env{'form.upfile'}=~s/\r/\n/gs;
7374: $env{'form.upfile'}=~s/\f/\n/gs;
7375: $env{'form.upfile'}=~s/\n+/\n/gs;
7376: $env{'form.upfile'}=~s/\n+$//gs;
1.31 albertel 7377:
1.258 albertel 7378: my $datatoken=$env{'user.name'}.'_'.$env{'user.domain'}.
7379: '_enroll_'.$env{'request.course.id'}.'_'.time.'_'.$$;
1.31 albertel 7380: {
1.158 raeburn 7381: my $datafile = $r->dir_config('lonDaemons').
7382: '/tmp/'.$datatoken.'.tmp';
7383: if ( open(my $fh,">$datafile") ) {
1.258 albertel 7384: print $fh $env{'form.upfile'};
1.158 raeburn 7385: close($fh);
7386: }
1.31 albertel 7387: }
7388: return $datatoken;
7389: }
7390:
1.56 matthew 7391: =pod
7392:
1.648 raeburn 7393: =item * &load_tmp_file($r)
1.41 ng 7394:
7395: Load uploaded file from tmp, $r should be the HTTP Request object,
1.258 albertel 7396: needs $env{'form.datatoken'},
7397: sets $env{'form.upfile'} to the contents of the file
1.41 ng 7398:
7399: =cut
1.31 albertel 7400:
7401: sub load_tmp_file {
7402: my $r=shift;
7403: my @studentdata=();
7404: {
1.158 raeburn 7405: my $studentfile = $r->dir_config('lonDaemons').
1.258 albertel 7406: '/tmp/'.$env{'form.datatoken'}.'.tmp';
1.158 raeburn 7407: if ( open(my $fh,"<$studentfile") ) {
7408: @studentdata=<$fh>;
7409: close($fh);
7410: }
1.31 albertel 7411: }
1.258 albertel 7412: $env{'form.upfile'}=join('',@studentdata);
1.31 albertel 7413: }
7414:
1.56 matthew 7415: =pod
7416:
1.648 raeburn 7417: =item * &upfile_record_sep()
1.41 ng 7418:
7419: Separate uploaded file into records
7420: returns array of records,
1.258 albertel 7421: needs $env{'form.upfile'} and $env{'form.upfiletype'}
1.41 ng 7422:
7423: =cut
1.31 albertel 7424:
7425: sub upfile_record_sep {
1.258 albertel 7426: if ($env{'form.upfiletype'} eq 'xml') {
1.31 albertel 7427: } else {
1.248 albertel 7428: my @records;
1.258 albertel 7429: foreach my $line (split(/\n/,$env{'form.upfile'})) {
1.248 albertel 7430: if ($line=~/^\s*$/) { next; }
7431: push(@records,$line);
7432: }
7433: return @records;
1.31 albertel 7434: }
7435: }
7436:
1.56 matthew 7437: =pod
7438:
1.648 raeburn 7439: =item * &record_sep($record)
1.41 ng 7440:
1.258 albertel 7441: Separate a record into fields $record should be an item from the upfile_record_sep(), needs $env{'form.upfiletype'}
1.41 ng 7442:
7443: =cut
7444:
1.263 www 7445: sub takeleft {
7446: my $index=shift;
7447: return substr('0000'.$index,-4,4);
7448: }
7449:
1.31 albertel 7450: sub record_sep {
7451: my $record=shift;
7452: my %components=();
1.258 albertel 7453: if ($env{'form.upfiletype'} eq 'xml') {
7454: } elsif ($env{'form.upfiletype'} eq 'space') {
1.31 albertel 7455: my $i=0;
1.356 albertel 7456: foreach my $field (split(/\s+/,$record)) {
1.31 albertel 7457: $field=~s/^(\"|\')//;
7458: $field=~s/(\"|\')$//;
1.263 www 7459: $components{&takeleft($i)}=$field;
1.31 albertel 7460: $i++;
7461: }
1.258 albertel 7462: } elsif ($env{'form.upfiletype'} eq 'tab') {
1.31 albertel 7463: my $i=0;
1.356 albertel 7464: foreach my $field (split(/\t/,$record)) {
1.31 albertel 7465: $field=~s/^(\"|\')//;
7466: $field=~s/(\"|\')$//;
1.263 www 7467: $components{&takeleft($i)}=$field;
1.31 albertel 7468: $i++;
7469: }
7470: } else {
1.561 www 7471: my $separator=',';
1.480 banghart 7472: if ($env{'form.upfiletype'} eq 'semisv') {
1.561 www 7473: $separator=';';
1.480 banghart 7474: }
1.31 albertel 7475: my $i=0;
1.561 www 7476: # the character we are looking for to indicate the end of a quote or a record
7477: my $looking_for=$separator;
7478: # do not add the characters to the fields
7479: my $ignore=0;
7480: # we just encountered a separator (or the beginning of the record)
7481: my $just_found_separator=1;
7482: # store the field we are working on here
7483: my $field='';
7484: # work our way through all characters in record
7485: foreach my $character ($record=~/(.)/g) {
7486: if ($character eq $looking_for) {
7487: if ($character ne $separator) {
7488: # Found the end of a quote, again looking for separator
7489: $looking_for=$separator;
7490: $ignore=1;
7491: } else {
7492: # Found a separator, store away what we got
7493: $components{&takeleft($i)}=$field;
7494: $i++;
7495: $just_found_separator=1;
7496: $ignore=0;
7497: $field='';
7498: }
7499: next;
7500: }
7501: # single or double quotation marks after a separator indicate beginning of a quote
7502: # we are now looking for the end of the quote and need to ignore separators
7503: if ((($character eq '"') || ($character eq "'")) && ($just_found_separator)) {
7504: $looking_for=$character;
7505: next;
7506: }
7507: # ignore would be true after we reached the end of a quote
7508: if ($ignore) { next; }
7509: if (($just_found_separator) && ($character=~/\s/)) { next; }
7510: $field.=$character;
7511: $just_found_separator=0;
1.31 albertel 7512: }
1.561 www 7513: # catch the very last entry, since we never encountered the separator
7514: $components{&takeleft($i)}=$field;
1.31 albertel 7515: }
7516: return %components;
7517: }
7518:
1.144 matthew 7519: ######################################################
7520: ######################################################
7521:
1.56 matthew 7522: =pod
7523:
1.648 raeburn 7524: =item * &upfile_select_html()
1.41 ng 7525:
1.144 matthew 7526: Return HTML code to select a file from the users machine and specify
7527: the file type.
1.41 ng 7528:
7529: =cut
7530:
1.144 matthew 7531: ######################################################
7532: ######################################################
1.31 albertel 7533: sub upfile_select_html {
1.144 matthew 7534: my %Types = (
7535: csv => &mt('CSV (comma separated values, spreadsheet)'),
1.480 banghart 7536: semisv => &mt('Semicolon separated values'),
1.144 matthew 7537: space => &mt('Space separated'),
7538: tab => &mt('Tabulator separated'),
7539: # xml => &mt('HTML/XML'),
7540: );
7541: my $Str = '<input type="file" name="upfile" size="50" />'.
7542: '<br />Type: <select name="upfiletype">';
7543: foreach my $type (sort(keys(%Types))) {
7544: $Str .= '<option value="'.$type.'" >'.$Types{$type}."</option>\n";
7545: }
7546: $Str .= "</select>\n";
7547: return $Str;
1.31 albertel 7548: }
7549:
1.301 albertel 7550: sub get_samples {
7551: my ($records,$toget) = @_;
7552: my @samples=({});
7553: my $got=0;
7554: foreach my $rec (@$records) {
7555: my %temp = &record_sep($rec);
7556: if (! grep(/\S/, values(%temp))) { next; }
7557: if (%temp) {
7558: $samples[$got]=\%temp;
7559: $got++;
7560: if ($got == $toget) { last; }
7561: }
7562: }
7563: return \@samples;
7564: }
7565:
1.144 matthew 7566: ######################################################
7567: ######################################################
7568:
1.56 matthew 7569: =pod
7570:
1.648 raeburn 7571: =item * &csv_print_samples($r,$records)
1.41 ng 7572:
7573: Prints a table of sample values from each column uploaded $r is an
7574: Apache Request ref, $records is an arrayref from
7575: &Apache::loncommon::upfile_record_sep
7576:
7577: =cut
7578:
1.144 matthew 7579: ######################################################
7580: ######################################################
1.31 albertel 7581: sub csv_print_samples {
7582: my ($r,$records) = @_;
1.662 bisitz 7583: my $samples = &get_samples($records,5);
1.301 albertel 7584:
1.594 raeburn 7585: $r->print(&mt('Samples').'<br />'.&start_data_table().
7586: &start_data_table_header_row());
1.356 albertel 7587: foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
7588: $r->print('<th>'.&mt('Column [_1]',($sample+1)).'</th>'); }
1.594 raeburn 7589: $r->print(&end_data_table_header_row());
1.301 albertel 7590: foreach my $hash (@$samples) {
1.594 raeburn 7591: $r->print(&start_data_table_row());
1.356 albertel 7592: foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
1.31 albertel 7593: $r->print('<td>');
1.356 albertel 7594: if (defined($$hash{$sample})) { $r->print($$hash{$sample}); }
1.31 albertel 7595: $r->print('</td>');
7596: }
1.594 raeburn 7597: $r->print(&end_data_table_row());
1.31 albertel 7598: }
1.594 raeburn 7599: $r->print(&end_data_table().'<br />'."\n");
1.31 albertel 7600: }
7601:
1.144 matthew 7602: ######################################################
7603: ######################################################
7604:
1.56 matthew 7605: =pod
7606:
1.648 raeburn 7607: =item * &csv_print_select_table($r,$records,$d)
1.41 ng 7608:
7609: Prints a table to create associations between values and table columns.
1.144 matthew 7610:
1.41 ng 7611: $r is an Apache Request ref,
7612: $records is an arrayref from &Apache::loncommon::upfile_record_sep,
1.174 matthew 7613: $d is an array of 2 element arrays (internal name, displayed name,defaultcol)
1.41 ng 7614:
7615: =cut
7616:
1.144 matthew 7617: ######################################################
7618: ######################################################
1.31 albertel 7619: sub csv_print_select_table {
7620: my ($r,$records,$d) = @_;
1.301 albertel 7621: my $i=0;
7622: my $samples = &get_samples($records,1);
1.144 matthew 7623: $r->print(&mt('Associate columns with student attributes.')."\n".
1.594 raeburn 7624: &start_data_table().&start_data_table_header_row().
1.144 matthew 7625: '<th>'.&mt('Attribute').'</th>'.
1.594 raeburn 7626: '<th>'.&mt('Column').'</th>'.
7627: &end_data_table_header_row()."\n");
1.356 albertel 7628: foreach my $array_ref (@$d) {
7629: my ($value,$display,$defaultcol)=@{ $array_ref };
1.594 raeburn 7630: $r->print(&start_data_table_row().'<tr><td>'.$display.'</td>');
1.31 albertel 7631:
7632: $r->print('<td><select name=f'.$i.
1.32 matthew 7633: ' onchange="javascript:flip(this.form,'.$i.');">');
1.31 albertel 7634: $r->print('<option value="none"></option>');
1.356 albertel 7635: foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
7636: $r->print('<option value="'.$sample.'"'.
7637: ($sample eq $defaultcol ? ' selected="selected" ' : '').
1.662 bisitz 7638: '>'.&mt('Column [_1]',($sample+1)).'</option>');
1.31 albertel 7639: }
1.594 raeburn 7640: $r->print('</select></td>'.&end_data_table_row()."\n");
1.31 albertel 7641: $i++;
7642: }
1.594 raeburn 7643: $r->print(&end_data_table());
1.31 albertel 7644: $i--;
7645: return $i;
7646: }
1.56 matthew 7647:
1.144 matthew 7648: ######################################################
7649: ######################################################
7650:
1.56 matthew 7651: =pod
1.31 albertel 7652:
1.648 raeburn 7653: =item * &csv_samples_select_table($r,$records,$d)
1.41 ng 7654:
7655: Prints a table of sample values from the upload and can make associate samples to internal names.
7656:
7657: $r is an Apache Request ref,
7658: $records is an arrayref from &Apache::loncommon::upfile_record_sep,
7659: $d is an array of 2 element arrays (internal name, displayed name)
7660:
7661: =cut
7662:
1.144 matthew 7663: ######################################################
7664: ######################################################
1.31 albertel 7665: sub csv_samples_select_table {
7666: my ($r,$records,$d) = @_;
7667: my $i=0;
1.144 matthew 7668: #
1.662 bisitz 7669: my $max_samples = 5;
7670: my $samples = &get_samples($records,$max_samples);
1.594 raeburn 7671: $r->print(&start_data_table().
7672: &start_data_table_header_row().'<th>'.
7673: &mt('Field').'</th><th>'.&mt('Samples').'</th>'.
7674: &end_data_table_header_row());
1.301 albertel 7675:
7676: foreach my $key (sort(keys(%{ $samples->[0] }))) {
1.594 raeburn 7677: $r->print(&start_data_table_row().'<td><select name="f'.$i.'"'.
1.32 matthew 7678: ' onchange="javascript:flip(this.form,'.$i.');">');
1.301 albertel 7679: foreach my $option (@$d) {
7680: my ($value,$display,$defaultcol)=@{ $option };
1.174 matthew 7681: $r->print('<option value="'.$value.'"'.
1.253 albertel 7682: ($i eq $defaultcol ? ' selected="selected" ':'').'>'.
1.174 matthew 7683: $display.'</option>');
1.31 albertel 7684: }
7685: $r->print('</select></td><td>');
1.662 bisitz 7686: foreach my $line (0..($max_samples-1)) {
1.301 albertel 7687: if (defined($samples->[$line]{$key})) {
7688: $r->print($samples->[$line]{$key}."<br />\n");
7689: }
7690: }
1.594 raeburn 7691: $r->print('</td>'.&end_data_table_row());
1.31 albertel 7692: $i++;
7693: }
1.594 raeburn 7694: $r->print(&end_data_table());
1.31 albertel 7695: $i--;
7696: return($i);
1.115 matthew 7697: }
7698:
1.144 matthew 7699: ######################################################
7700: ######################################################
7701:
1.115 matthew 7702: =pod
7703:
1.648 raeburn 7704: =item * &clean_excel_name($name)
1.115 matthew 7705:
7706: Returns a replacement for $name which does not contain any illegal characters.
7707:
7708: =cut
7709:
1.144 matthew 7710: ######################################################
7711: ######################################################
1.115 matthew 7712: sub clean_excel_name {
7713: my ($name) = @_;
7714: $name =~ s/[:\*\?\/\\]//g;
7715: if (length($name) > 31) {
7716: $name = substr($name,0,31);
7717: }
7718: return $name;
1.25 albertel 7719: }
1.84 albertel 7720:
1.85 albertel 7721: =pod
7722:
1.648 raeburn 7723: =item * &check_if_partid_hidden($id,$symb,$udom,$uname)
1.85 albertel 7724:
7725: Returns either 1 or undef
7726:
7727: 1 if the part is to be hidden, undef if it is to be shown
7728:
7729: Arguments are:
7730:
7731: $id the id of the part to be checked
7732: $symb, optional the symb of the resource to check
7733: $udom, optional the domain of the user to check for
7734: $uname, optional the username of the user to check for
7735:
7736: =cut
1.84 albertel 7737:
7738: sub check_if_partid_hidden {
7739: my ($id,$symb,$udom,$uname) = @_;
1.133 albertel 7740: my $hiddenparts=&Apache::lonnet::EXT('resource.0.hiddenparts',
1.84 albertel 7741: $symb,$udom,$uname);
1.141 albertel 7742: my $truth=1;
7743: #if the string starts with !, then the list is the list to show not hide
7744: if ($hiddenparts=~s/^\s*!//) { $truth=undef; }
1.84 albertel 7745: my @hiddenlist=split(/,/,$hiddenparts);
7746: foreach my $checkid (@hiddenlist) {
1.141 albertel 7747: if ($checkid =~ /^\s*\Q$id\E\s*$/) { return $truth; }
1.84 albertel 7748: }
1.141 albertel 7749: return !$truth;
1.84 albertel 7750: }
1.127 matthew 7751:
1.138 matthew 7752:
7753: ############################################################
7754: ############################################################
7755:
7756: =pod
7757:
1.157 matthew 7758: =back
7759:
1.138 matthew 7760: =head1 cgi-bin script and graphing routines
7761:
1.157 matthew 7762: =over 4
7763:
1.648 raeburn 7764: =item * &get_cgi_id()
1.138 matthew 7765:
7766: Inputs: none
7767:
7768: Returns an id which can be used to pass environment variables
7769: to various cgi-bin scripts. These environment variables will
7770: be removed from the users environment after a given time by
7771: the routine &Apache::lonnet::transfer_profile_to_env.
7772:
7773: =cut
7774:
7775: ############################################################
7776: ############################################################
1.152 albertel 7777: my $uniq=0;
1.136 matthew 7778: sub get_cgi_id {
1.154 albertel 7779: $uniq=($uniq+1)%100000;
1.280 albertel 7780: return (time.'_'.$$.'_'.$uniq);
1.136 matthew 7781: }
7782:
1.127 matthew 7783: ############################################################
7784: ############################################################
7785:
7786: =pod
7787:
1.648 raeburn 7788: =item * &DrawBarGraph()
1.127 matthew 7789:
1.138 matthew 7790: Facilitates the plotting of data in a (stacked) bar graph.
7791: Puts plot definition data into the users environment in order for
7792: graph.png to plot it. Returns an <img> tag for the plot.
7793: The bars on the plot are labeled '1','2',...,'n'.
7794:
7795: Inputs:
7796:
7797: =over 4
7798:
7799: =item $Title: string, the title of the plot
7800:
7801: =item $xlabel: string, text describing the X-axis of the plot
7802:
7803: =item $ylabel: string, text describing the Y-axis of the plot
7804:
7805: =item $Max: scalar, the maximum Y value to use in the plot
7806: If $Max is < any data point, the graph will not be rendered.
7807:
1.140 matthew 7808: =item $colors: array ref holding the colors to be used for the data sets when
1.138 matthew 7809: they are plotted. If undefined, default values will be used.
7810:
1.178 matthew 7811: =item $labels: array ref holding the labels to use on the x-axis for the bars.
7812:
1.138 matthew 7813: =item @Values: An array of array references. Each array reference holds data
7814: to be plotted in a stacked bar chart.
7815:
1.239 matthew 7816: =item If the final element of @Values is a hash reference the key/value
7817: pairs will be added to the graph definition.
7818:
1.138 matthew 7819: =back
7820:
7821: Returns:
7822:
7823: An <img> tag which references graph.png and the appropriate identifying
7824: information for the plot.
7825:
1.127 matthew 7826: =cut
7827:
7828: ############################################################
7829: ############################################################
1.134 matthew 7830: sub DrawBarGraph {
1.178 matthew 7831: my ($Title,$xlabel,$ylabel,$Max,$colors,$labels,@Values)=@_;
1.134 matthew 7832: #
7833: if (! defined($colors)) {
7834: $colors = ['#33ff00',
7835: '#0033cc', '#990000', '#aaaa66', '#663399', '#ff9933',
7836: '#66ccff', '#ff9999', '#cccc33', '#660000', '#33cc66',
7837: ];
7838: }
1.228 matthew 7839: my $extra_settings = {};
7840: if (ref($Values[-1]) eq 'HASH') {
7841: $extra_settings = pop(@Values);
7842: }
1.127 matthew 7843: #
1.136 matthew 7844: my $identifier = &get_cgi_id();
7845: my $id = 'cgi.'.$identifier;
1.129 matthew 7846: if (! @Values || ref($Values[0]) ne 'ARRAY') {
1.127 matthew 7847: return '';
7848: }
1.225 matthew 7849: #
7850: my @Labels;
7851: if (defined($labels)) {
7852: @Labels = @$labels;
7853: } else {
7854: for (my $i=0;$i<@{$Values[0]};$i++) {
7855: push (@Labels,$i+1);
7856: }
7857: }
7858: #
1.129 matthew 7859: my $NumBars = scalar(@{$Values[0]});
1.225 matthew 7860: if ($NumBars < scalar(@Labels)) { $NumBars = scalar(@Labels); }
1.129 matthew 7861: my %ValuesHash;
7862: my $NumSets=1;
7863: foreach my $array (@Values) {
7864: next if (! ref($array));
1.136 matthew 7865: $ValuesHash{$id.'.data.'.$NumSets++} =
1.132 matthew 7866: join(',',@$array);
1.129 matthew 7867: }
1.127 matthew 7868: #
1.136 matthew 7869: my ($height,$width,$xskip,$bar_width) = (200,120,1,15);
1.225 matthew 7870: if ($NumBars < 3) {
7871: $width = 120+$NumBars*32;
1.220 matthew 7872: $xskip = 1;
1.225 matthew 7873: $bar_width = 30;
7874: } elsif ($NumBars < 5) {
7875: $width = 120+$NumBars*20;
7876: $xskip = 1;
7877: $bar_width = 20;
1.220 matthew 7878: } elsif ($NumBars < 10) {
1.136 matthew 7879: $width = 120+$NumBars*15;
7880: $xskip = 1;
7881: $bar_width = 15;
7882: } elsif ($NumBars <= 25) {
7883: $width = 120+$NumBars*11;
7884: $xskip = 5;
7885: $bar_width = 8;
7886: } elsif ($NumBars <= 50) {
7887: $width = 120+$NumBars*8;
7888: $xskip = 5;
7889: $bar_width = 4;
7890: } else {
7891: $width = 120+$NumBars*8;
7892: $xskip = 5;
7893: $bar_width = 4;
7894: }
7895: #
1.137 matthew 7896: $Max = 1 if ($Max < 1);
7897: if ( int($Max) < $Max ) {
7898: $Max++;
7899: $Max = int($Max);
7900: }
1.127 matthew 7901: $Title = '' if (! defined($Title));
7902: $xlabel = '' if (! defined($xlabel));
7903: $ylabel = '' if (! defined($ylabel));
1.369 www 7904: $ValuesHash{$id.'.title'} = &escape($Title);
7905: $ValuesHash{$id.'.xlabel'} = &escape($xlabel);
7906: $ValuesHash{$id.'.ylabel'} = &escape($ylabel);
1.137 matthew 7907: $ValuesHash{$id.'.y_max_value'} = $Max;
1.136 matthew 7908: $ValuesHash{$id.'.NumBars'} = $NumBars;
7909: $ValuesHash{$id.'.NumSets'} = $NumSets;
7910: $ValuesHash{$id.'.PlotType'} = 'bar';
7911: $ValuesHash{$id.'.Colors'} = join(',',@{$colors});
7912: $ValuesHash{$id.'.height'} = $height;
7913: $ValuesHash{$id.'.width'} = $width;
7914: $ValuesHash{$id.'.xskip'} = $xskip;
7915: $ValuesHash{$id.'.bar_width'} = $bar_width;
7916: $ValuesHash{$id.'.labels'} = join(',',@Labels);
1.127 matthew 7917: #
1.228 matthew 7918: # Deal with other parameters
7919: while (my ($key,$value) = each(%$extra_settings)) {
7920: $ValuesHash{$id.'.'.$key} = $value;
7921: }
7922: #
1.646 raeburn 7923: &Apache::lonnet::appenv(\%ValuesHash);
1.137 matthew 7924: return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';
7925: }
7926:
7927: ############################################################
7928: ############################################################
7929:
7930: =pod
7931:
1.648 raeburn 7932: =item * &DrawXYGraph()
1.137 matthew 7933:
1.138 matthew 7934: Facilitates the plotting of data in an XY graph.
7935: Puts plot definition data into the users environment in order for
7936: graph.png to plot it. Returns an <img> tag for the plot.
7937:
7938: Inputs:
7939:
7940: =over 4
7941:
7942: =item $Title: string, the title of the plot
7943:
7944: =item $xlabel: string, text describing the X-axis of the plot
7945:
7946: =item $ylabel: string, text describing the Y-axis of the plot
7947:
7948: =item $Max: scalar, the maximum Y value to use in the plot
7949: If $Max is < any data point, the graph will not be rendered.
7950:
7951: =item $colors: Array ref containing the hex color codes for the data to be
7952: plotted in. If undefined, default values will be used.
7953:
7954: =item $Xlabels: Array ref containing the labels to be used for the X-axis.
7955:
7956: =item $Ydata: Array ref containing Array refs.
1.185 www 7957: Each of the contained arrays will be plotted as a separate curve.
1.138 matthew 7958:
7959: =item %Values: hash indicating or overriding any default values which are
7960: passed to graph.png.
7961: Possible values are: width, xskip, x_ticks, x_tick_offset, among others.
7962:
7963: =back
7964:
7965: Returns:
7966:
7967: An <img> tag which references graph.png and the appropriate identifying
7968: information for the plot.
7969:
1.137 matthew 7970: =cut
7971:
7972: ############################################################
7973: ############################################################
7974: sub DrawXYGraph {
7975: my ($Title,$xlabel,$ylabel,$Max,$colors,$Xlabels,$Ydata,%Values)=@_;
7976: #
7977: # Create the identifier for the graph
7978: my $identifier = &get_cgi_id();
7979: my $id = 'cgi.'.$identifier;
7980: #
7981: $Title = '' if (! defined($Title));
7982: $xlabel = '' if (! defined($xlabel));
7983: $ylabel = '' if (! defined($ylabel));
7984: my %ValuesHash =
7985: (
1.369 www 7986: $id.'.title' => &escape($Title),
7987: $id.'.xlabel' => &escape($xlabel),
7988: $id.'.ylabel' => &escape($ylabel),
1.137 matthew 7989: $id.'.y_max_value'=> $Max,
7990: $id.'.labels' => join(',',@$Xlabels),
7991: $id.'.PlotType' => 'XY',
7992: );
7993: #
7994: if (defined($colors) && ref($colors) eq 'ARRAY') {
7995: $ValuesHash{$id.'.Colors'} = join(',',@{$colors});
7996: }
7997: #
7998: if (! ref($Ydata) || ref($Ydata) ne 'ARRAY') {
7999: return '';
8000: }
8001: my $NumSets=1;
1.138 matthew 8002: foreach my $array (@{$Ydata}){
1.137 matthew 8003: next if (! ref($array));
8004: $ValuesHash{$id.'.data.'.$NumSets++} = join(',',@$array);
8005: }
1.138 matthew 8006: $ValuesHash{$id.'.NumSets'} = $NumSets-1;
1.137 matthew 8007: #
8008: # Deal with other parameters
8009: while (my ($key,$value) = each(%Values)) {
8010: $ValuesHash{$id.'.'.$key} = $value;
1.127 matthew 8011: }
8012: #
1.646 raeburn 8013: &Apache::lonnet::appenv(\%ValuesHash);
1.136 matthew 8014: return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';
8015: }
8016:
8017: ############################################################
8018: ############################################################
8019:
8020: =pod
8021:
1.648 raeburn 8022: =item * &DrawXYYGraph()
1.138 matthew 8023:
8024: Facilitates the plotting of data in an XY graph with two Y axes.
8025: Puts plot definition data into the users environment in order for
8026: graph.png to plot it. Returns an <img> tag for the plot.
8027:
8028: Inputs:
8029:
8030: =over 4
8031:
8032: =item $Title: string, the title of the plot
8033:
8034: =item $xlabel: string, text describing the X-axis of the plot
8035:
8036: =item $ylabel: string, text describing the Y-axis of the plot
8037:
8038: =item $colors: Array ref containing the hex color codes for the data to be
8039: plotted in. If undefined, default values will be used.
8040:
8041: =item $Xlabels: Array ref containing the labels to be used for the X-axis.
8042:
8043: =item $Ydata1: The first data set
8044:
8045: =item $Min1: The minimum value of the left Y-axis
8046:
8047: =item $Max1: The maximum value of the left Y-axis
8048:
8049: =item $Ydata2: The second data set
8050:
8051: =item $Min2: The minimum value of the right Y-axis
8052:
8053: =item $Max2: The maximum value of the left Y-axis
8054:
8055: =item %Values: hash indicating or overriding any default values which are
8056: passed to graph.png.
8057: Possible values are: width, xskip, x_ticks, x_tick_offset, among others.
8058:
8059: =back
8060:
8061: Returns:
8062:
8063: An <img> tag which references graph.png and the appropriate identifying
8064: information for the plot.
1.136 matthew 8065:
8066: =cut
8067:
8068: ############################################################
8069: ############################################################
1.137 matthew 8070: sub DrawXYYGraph {
8071: my ($Title,$xlabel,$ylabel,$colors,$Xlabels,$Ydata1,$Min1,$Max1,
8072: $Ydata2,$Min2,$Max2,%Values)=@_;
1.136 matthew 8073: #
8074: # Create the identifier for the graph
8075: my $identifier = &get_cgi_id();
8076: my $id = 'cgi.'.$identifier;
8077: #
8078: $Title = '' if (! defined($Title));
8079: $xlabel = '' if (! defined($xlabel));
8080: $ylabel = '' if (! defined($ylabel));
8081: my %ValuesHash =
8082: (
1.369 www 8083: $id.'.title' => &escape($Title),
8084: $id.'.xlabel' => &escape($xlabel),
8085: $id.'.ylabel' => &escape($ylabel),
1.136 matthew 8086: $id.'.labels' => join(',',@$Xlabels),
8087: $id.'.PlotType' => 'XY',
8088: $id.'.NumSets' => 2,
1.137 matthew 8089: $id.'.two_axes' => 1,
8090: $id.'.y1_max_value' => $Max1,
8091: $id.'.y1_min_value' => $Min1,
8092: $id.'.y2_max_value' => $Max2,
8093: $id.'.y2_min_value' => $Min2,
1.136 matthew 8094: );
8095: #
1.137 matthew 8096: if (defined($colors) && ref($colors) eq 'ARRAY') {
8097: $ValuesHash{$id.'.Colors'} = join(',',@{$colors});
8098: }
8099: #
8100: if (! ref($Ydata1) || ref($Ydata1) ne 'ARRAY' ||
8101: ! ref($Ydata2) || ref($Ydata2) ne 'ARRAY'){
1.136 matthew 8102: return '';
8103: }
8104: my $NumSets=1;
1.137 matthew 8105: foreach my $array ($Ydata1,$Ydata2){
1.136 matthew 8106: next if (! ref($array));
8107: $ValuesHash{$id.'.data.'.$NumSets++} = join(',',@$array);
1.137 matthew 8108: }
8109: #
8110: # Deal with other parameters
8111: while (my ($key,$value) = each(%Values)) {
8112: $ValuesHash{$id.'.'.$key} = $value;
1.136 matthew 8113: }
8114: #
1.646 raeburn 8115: &Apache::lonnet::appenv(\%ValuesHash);
1.130 albertel 8116: return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';
1.139 matthew 8117: }
8118:
8119: ############################################################
8120: ############################################################
8121:
8122: =pod
8123:
1.157 matthew 8124: =back
8125:
1.139 matthew 8126: =head1 Statistics helper routines?
8127:
8128: Bad place for them but what the hell.
8129:
1.157 matthew 8130: =over 4
8131:
1.648 raeburn 8132: =item * &chartlink()
1.139 matthew 8133:
8134: Returns a link to the chart for a specific student.
8135:
8136: Inputs:
8137:
8138: =over 4
8139:
8140: =item $linktext: The text of the link
8141:
8142: =item $sname: The students username
8143:
8144: =item $sdomain: The students domain
8145:
8146: =back
8147:
1.157 matthew 8148: =back
8149:
1.139 matthew 8150: =cut
8151:
8152: ############################################################
8153: ############################################################
8154: sub chartlink {
8155: my ($linktext, $sname, $sdomain) = @_;
8156: my $link = '<a href="/adm/statistics?reportSelected=student_assessment'.
1.369 www 8157: '&SelectedStudent='.&escape($sname.':'.$sdomain).
1.219 albertel 8158: '&chartoutputmode='.HTML::Entities::encode('html, with all links').
1.139 matthew 8159: '">'.$linktext.'</a>';
1.153 matthew 8160: }
8161:
8162: #######################################################
8163: #######################################################
8164:
8165: =pod
8166:
8167: =head1 Course Environment Routines
1.157 matthew 8168:
8169: =over 4
1.153 matthew 8170:
1.648 raeburn 8171: =item * &restore_course_settings()
1.153 matthew 8172:
1.648 raeburn 8173: =item * &store_course_settings()
1.153 matthew 8174:
8175: Restores/Store indicated form parameters from the course environment.
8176: Will not overwrite existing values of the form parameters.
8177:
8178: Inputs:
8179: a scalar describing the data (e.g. 'chart', 'problem_analysis')
8180:
8181: a hash ref describing the data to be stored. For example:
8182:
8183: %Save_Parameters = ('Status' => 'scalar',
8184: 'chartoutputmode' => 'scalar',
8185: 'chartoutputdata' => 'scalar',
8186: 'Section' => 'array',
1.373 raeburn 8187: 'Group' => 'array',
1.153 matthew 8188: 'StudentData' => 'array',
8189: 'Maps' => 'array');
8190:
8191: Returns: both routines return nothing
8192:
1.631 raeburn 8193: =back
8194:
1.153 matthew 8195: =cut
8196:
8197: #######################################################
8198: #######################################################
8199: sub store_course_settings {
1.496 albertel 8200: return &store_settings($env{'request.course.id'},@_);
8201: }
8202:
8203: sub store_settings {
1.153 matthew 8204: # save to the environment
8205: # appenv the same items, just to be safe
1.300 albertel 8206: my $udom = $env{'user.domain'};
8207: my $uname = $env{'user.name'};
1.496 albertel 8208: my ($context,$prefix,$Settings) = @_;
1.153 matthew 8209: my %SaveHash;
8210: my %AppHash;
8211: while (my ($setting,$type) = each(%$Settings)) {
1.496 albertel 8212: my $basename = join('.','internal',$context,$prefix,$setting);
1.300 albertel 8213: my $envname = 'environment.'.$basename;
1.258 albertel 8214: if (exists($env{'form.'.$setting})) {
1.153 matthew 8215: # Save this value away
8216: if ($type eq 'scalar' &&
1.258 albertel 8217: (! exists($env{$envname}) ||
8218: $env{$envname} ne $env{'form.'.$setting})) {
8219: $SaveHash{$basename} = $env{'form.'.$setting};
8220: $AppHash{$envname} = $env{'form.'.$setting};
1.153 matthew 8221: } elsif ($type eq 'array') {
8222: my $stored_form;
1.258 albertel 8223: if (ref($env{'form.'.$setting})) {
1.153 matthew 8224: $stored_form = join(',',
8225: map {
1.369 www 8226: &escape($_);
1.258 albertel 8227: } sort(@{$env{'form.'.$setting}}));
1.153 matthew 8228: } else {
8229: $stored_form =
1.369 www 8230: &escape($env{'form.'.$setting});
1.153 matthew 8231: }
8232: # Determine if the array contents are the same.
1.258 albertel 8233: if ($stored_form ne $env{$envname}) {
1.153 matthew 8234: $SaveHash{$basename} = $stored_form;
8235: $AppHash{$envname} = $stored_form;
8236: }
8237: }
8238: }
8239: }
8240: my $put_result = &Apache::lonnet::put('environment',\%SaveHash,
1.300 albertel 8241: $udom,$uname);
1.153 matthew 8242: if ($put_result !~ /^(ok|delayed)/) {
8243: &Apache::lonnet::logthis('unable to save form parameters, '.
8244: 'got error:'.$put_result);
8245: }
8246: # Make sure these settings stick around in this session, too
1.646 raeburn 8247: &Apache::lonnet::appenv(\%AppHash);
1.153 matthew 8248: return;
8249: }
8250:
8251: sub restore_course_settings {
1.499 albertel 8252: return &restore_settings($env{'request.course.id'},@_);
1.496 albertel 8253: }
8254:
8255: sub restore_settings {
8256: my ($context,$prefix,$Settings) = @_;
1.153 matthew 8257: while (my ($setting,$type) = each(%$Settings)) {
1.258 albertel 8258: next if (exists($env{'form.'.$setting}));
1.496 albertel 8259: my $envname = 'environment.internal.'.$context.'.'.$prefix.
1.153 matthew 8260: '.'.$setting;
1.258 albertel 8261: if (exists($env{$envname})) {
1.153 matthew 8262: if ($type eq 'scalar') {
1.258 albertel 8263: $env{'form.'.$setting} = $env{$envname};
1.153 matthew 8264: } elsif ($type eq 'array') {
1.258 albertel 8265: $env{'form.'.$setting} = [
1.153 matthew 8266: map {
1.369 www 8267: &unescape($_);
1.258 albertel 8268: } split(',',$env{$envname})
1.153 matthew 8269: ];
8270: }
8271: }
8272: }
1.127 matthew 8273: }
8274:
1.618 raeburn 8275: #######################################################
8276: #######################################################
8277:
8278: =pod
8279:
8280: =head1 Domain E-mail Routines
8281:
8282: =over 4
8283:
1.648 raeburn 8284: =item * &build_recipient_list()
1.618 raeburn 8285:
8286: Build recipient lists for three types of e-mail:
8287: (a) Error Reports, (b) Package Updates, (c) Help requests, generated by
1.619 raeburn 8288: lonerrorhandler.pm, CHECKRPMS and lonsupportreq.pm respectively.
1.618 raeburn 8289:
8290: Inputs:
1.619 raeburn 8291: defmail (scalar - email address of default recipient),
1.618 raeburn 8292: mailing type (scalar - errormail, packagesmail, or helpdeskmail),
1.619 raeburn 8293: defdom (domain for which to retrieve configuration settings),
8294: origmail (scalar - email address of recipient from loncapa.conf,
8295: i.e., predates configuration by DC via domainprefs.pm
1.618 raeburn 8296:
1.655 raeburn 8297: Returns: comma separated list of addresses to which to send e-mail.
8298:
8299: =back
1.618 raeburn 8300:
8301: =cut
8302:
8303: ############################################################
8304: ############################################################
8305: sub build_recipient_list {
1.619 raeburn 8306: my ($defmail,$mailing,$defdom,$origmail) = @_;
1.618 raeburn 8307: my @recipients;
8308: my $otheremails;
8309: my %domconfig =
8310: &Apache::lonnet::get_dom('configuration',['contacts'],$defdom);
8311: if (ref($domconfig{'contacts'}) eq 'HASH') {
8312: if (ref($domconfig{'contacts'}{$mailing}) eq 'HASH') {
8313: my @contacts = ('adminemail','supportemail');
8314: foreach my $item (@contacts) {
8315: if ($domconfig{'contacts'}{$mailing}{$item}) {
1.619 raeburn 8316: my $addr = $domconfig{'contacts'}{$item};
8317: if (!grep(/^\Q$addr\E$/,@recipients)) {
8318: push(@recipients,$addr);
8319: }
1.618 raeburn 8320: }
8321: $otheremails = $domconfig{'contacts'}{$mailing}{'others'};
8322: }
8323: }
1.619 raeburn 8324: } elsif ($origmail ne '') {
8325: push(@recipients,$origmail);
1.618 raeburn 8326: }
8327: if ($defmail ne '') {
8328: push(@recipients,$defmail);
8329: }
8330: if ($otheremails) {
1.619 raeburn 8331: my @others;
8332: if ($otheremails =~ /,/) {
8333: @others = split(/,/,$otheremails);
1.618 raeburn 8334: } else {
1.619 raeburn 8335: push(@others,$otheremails);
8336: }
8337: foreach my $addr (@others) {
8338: if (!grep(/^\Q$addr\E$/,@recipients)) {
8339: push(@recipients,$addr);
8340: }
1.618 raeburn 8341: }
8342: }
1.619 raeburn 8343: my $recipientlist = join(',',@recipients);
1.618 raeburn 8344: return $recipientlist;
8345: }
8346:
1.127 matthew 8347: ############################################################
8348: ############################################################
1.154 albertel 8349:
1.655 raeburn 8350: =pod
8351:
8352: =head1 Course Catalog Routines
8353:
8354: =over 4
8355:
8356: =item * &gather_categories()
8357:
8358: Converts category definitions - keys of categories hash stored in
8359: coursecategories in configuration.db on the primary library server in a
8360: domain - to an array. Also generates javascript and idx hash used to
8361: generate Domain Coordinator interface for editing Course Categories.
8362:
8363: Inputs:
1.663 raeburn 8364:
1.655 raeburn 8365: categories (reference to hash of category definitions).
1.663 raeburn 8366:
1.655 raeburn 8367: cats (reference to array of arrays/hashes which encapsulates hierarchy of
8368: categories and subcategories).
1.663 raeburn 8369:
1.655 raeburn 8370: idx (reference to hash of counters used in Domain Coordinator interface for
8371: editing Course Categories).
1.663 raeburn 8372:
1.655 raeburn 8373: jsarray (reference to array of categories used to create Javascript arrays for
8374: Domain Coordinator interface for editing Course Categories).
8375:
8376: Returns: nothing
8377:
8378: Side effects: populates cats, idx and jsarray.
8379:
8380: =cut
8381:
8382: sub gather_categories {
8383: my ($categories,$cats,$idx,$jsarray) = @_;
8384: my %counters;
8385: my $num = 0;
8386: foreach my $item (keys(%{$categories})) {
8387: my ($cat,$container,$depth) = map { &unescape($_); } split(/:/,$item);
8388: if ($container eq '' && $depth == 0) {
8389: $cats->[$depth][$categories->{$item}] = $cat;
8390: } else {
8391: $cats->[$depth]{$container}[$categories->{$item}] = $cat;
8392: }
8393: my ($escitem,$tail) = split(/:/,$item,2);
8394: if ($counters{$tail} eq '') {
8395: $counters{$tail} = $num;
8396: $num ++;
8397: }
8398: if (ref($idx) eq 'HASH') {
8399: $idx->{$item} = $counters{$tail};
8400: }
8401: if (ref($jsarray) eq 'ARRAY') {
8402: push(@{$jsarray->[$counters{$tail}]},$item);
8403: }
8404: }
8405: return;
8406: }
8407:
8408: =pod
8409:
8410: =item * &extract_categories()
8411:
8412: Used to generate breadcrumb trails for course categories.
8413:
8414: Inputs:
1.663 raeburn 8415:
1.655 raeburn 8416: categories (reference to hash of category definitions).
1.663 raeburn 8417:
1.655 raeburn 8418: cats (reference to array of arrays/hashes which encapsulates hierarchy of
8419: categories and subcategories).
1.663 raeburn 8420:
1.655 raeburn 8421: trails (reference to array of breacrumb trails for each category).
1.663 raeburn 8422:
1.655 raeburn 8423: allitems (reference to hash - key is category key
8424: (format: escaped(name):escaped(parent category):depth in hierarchy).
1.663 raeburn 8425:
1.655 raeburn 8426: idx (reference to hash of counters used in Domain Coordinator interface for
8427: editing Course Categories).
1.663 raeburn 8428:
1.655 raeburn 8429: jsarray (reference to array of categories used to create Javascript arrays for
8430: Domain Coordinator interface for editing Course Categories).
8431:
1.665 raeburn 8432: subcats (reference to hash of arrays containing all subcategories within each
8433: category, -recursive)
8434:
1.655 raeburn 8435: Returns: nothing
8436:
8437: Side effects: populates trails and allitems hash references.
8438:
8439: =cut
8440:
8441: sub extract_categories {
1.665 raeburn 8442: my ($categories,$cats,$trails,$allitems,$idx,$jsarray,$subcats) = @_;
1.655 raeburn 8443: if (ref($categories) eq 'HASH') {
8444: &gather_categories($categories,$cats,$idx,$jsarray);
8445: if (ref($cats->[0]) eq 'ARRAY') {
8446: for (my $i=0; $i<@{$cats->[0]}; $i++) {
8447: my $name = $cats->[0][$i];
8448: my $item = &escape($name).'::0';
8449: my $trailstr;
8450: if ($name eq 'instcode') {
8451: $trailstr = &mt('Official courses (with institutional codes)');
8452: } else {
8453: $trailstr = $name;
8454: }
8455: if ($allitems->{$item} eq '') {
8456: push(@{$trails},$trailstr);
8457: $allitems->{$item} = scalar(@{$trails})-1;
8458: }
8459: my @parents = ($name);
8460: if (ref($cats->[1]{$name}) eq 'ARRAY') {
8461: for (my $j=0; $j<@{$cats->[1]{$name}}; $j++) {
8462: my $category = $cats->[1]{$name}[$j];
1.665 raeburn 8463: if (ref($subcats) eq 'HASH') {
8464: push(@{$subcats->{$item}},&escape($category).':'.&escape($name).':1');
8465: }
8466: &recurse_categories($cats,2,$category,$trails,$allitems,\@parents,$subcats);
8467: }
8468: } else {
8469: if (ref($subcats) eq 'HASH') {
8470: $subcats->{$item} = [];
1.655 raeburn 8471: }
8472: }
8473: }
8474: }
8475: }
8476: return;
8477: }
8478:
8479: =pod
8480:
8481: =item *&recurse_categories()
8482:
8483: Recursively used to generate breadcrumb trails for course categories.
8484:
8485: Inputs:
1.663 raeburn 8486:
1.655 raeburn 8487: cats (reference to array of arrays/hashes which encapsulates hierarchy of
8488: categories and subcategories).
1.663 raeburn 8489:
1.655 raeburn 8490: depth (current depth in hierarchy of categories and sub-categories - 0 indexed).
1.663 raeburn 8491:
8492: category (current course category, for which breadcrumb trail is being generated).
8493:
8494: trails (reference to array of breadcrumb trails for each category).
8495:
1.655 raeburn 8496: allitems (reference to hash - key is category key
8497: (format: escaped(name):escaped(parent category):depth in hierarchy).
1.663 raeburn 8498:
1.655 raeburn 8499: parents (array containing containers directories for current category,
8500: back to top level).
8501:
8502: Returns: nothing
8503:
8504: Side effects: populates trails and allitems hash references
8505:
8506: =cut
8507:
8508: sub recurse_categories {
1.665 raeburn 8509: my ($cats,$depth,$category,$trails,$allitems,$parents,$subcats) = @_;
1.655 raeburn 8510: my $shallower = $depth - 1;
8511: if (ref($cats->[$depth]{$category}) eq 'ARRAY') {
8512: for (my $k=0; $k<@{$cats->[$depth]{$category}}; $k++) {
8513: my $name = $cats->[$depth]{$category}[$k];
8514: my $item = &escape($category).':'.&escape($parents->[-1]).':'.$shallower;
8515: my $trailstr = join(' -> ',(@{$parents},$category));
8516: if ($allitems->{$item} eq '') {
8517: push(@{$trails},$trailstr);
8518: $allitems->{$item} = scalar(@{$trails})-1;
8519: }
8520: my $deeper = $depth+1;
8521: push(@{$parents},$category);
1.665 raeburn 8522: if (ref($subcats) eq 'HASH') {
8523: my $subcat = &escape($name).':'.$category.':'.$depth;
8524: for (my $j=@{$parents}; $j>=0; $j--) {
8525: my $higher;
8526: if ($j > 0) {
8527: $higher = &escape($parents->[$j]).':'.
8528: &escape($parents->[$j-1]).':'.$j;
8529: } else {
8530: $higher = &escape($parents->[$j]).'::'.$j;
8531: }
8532: push(@{$subcats->{$higher}},$subcat);
8533: }
8534: }
8535: &recurse_categories($cats,$deeper,$name,$trails,$allitems,$parents,
8536: $subcats);
1.655 raeburn 8537: pop(@{$parents});
8538: }
8539: } else {
8540: my $item = &escape($category).':'.&escape($parents->[-1]).':'.$shallower;
8541: my $trailstr = join(' -> ',(@{$parents},$category));
8542: if ($allitems->{$item} eq '') {
8543: push(@{$trails},$trailstr);
8544: $allitems->{$item} = scalar(@{$trails})-1;
8545: }
8546: }
8547: return;
8548: }
8549:
1.663 raeburn 8550: =pod
8551:
8552: =item *&assign_categories_table()
8553:
8554: Create a datatable for display of hierarchical categories in a domain,
8555: with checkboxes to allow a course to be categorized.
8556:
8557: Inputs:
8558:
8559: cathash - reference to hash of categories defined for the domain (from
8560: configuration.db)
8561:
8562: currcat - scalar with an & separated list of categories assigned to a course.
8563:
8564: Returns: $output (markup to be displayed)
8565:
8566: =cut
8567:
8568: sub assign_categories_table {
8569: my ($cathash,$currcat) = @_;
8570: my $output;
8571: if (ref($cathash) eq 'HASH') {
8572: my (@cats,@trails,%allitems,%idx,@jsarray,@path,$maxdepth);
8573: &extract_categories($cathash,\@cats,\@trails,\%allitems,\%idx,\@jsarray);
8574: $maxdepth = scalar(@cats);
8575: if (@cats > 0) {
8576: my $itemcount = 0;
8577: if (ref($cats[0]) eq 'ARRAY') {
8578: $output = &Apache::loncommon::start_data_table();
8579: my @currcategories;
8580: if ($currcat ne '') {
8581: @currcategories = split('&',$currcat);
8582: }
8583: for (my $i=0; $i<@{$cats[0]}; $i++) {
8584: my $parent = $cats[0][$i];
8585: my $css_class = $itemcount%2?' class="LC_odd_row"':'';
8586: next if ($parent eq 'instcode');
8587: my $item = &escape($parent).'::0';
8588: my $checked = '';
8589: if (@currcategories > 0) {
8590: if (grep(/^\Q$item\E$/,@currcategories)) {
8591: $checked = ' checked="checked" ';
8592: }
8593: }
1.675 raeburn 8594: $output .= '<tr '.$css_class.'><td><span class="LC_nobreak">'.
8595: '<input type="checkbox" name="usecategory" value="'.
8596: $item.'"'.$checked.' />'.$parent.'</span>'.
8597: '<input type="hidden" name="catname" value="'.$parent.'" /></td>';
1.663 raeburn 8598: my $depth = 1;
8599: push(@path,$parent);
8600: $output .= &assign_category_rows($itemcount,\@cats,$depth,$parent,\@path,\@currcategories);
8601: pop(@path);
8602: $output .= '</tr><tr><td colspan="'.$maxdepth.'" class="LC_row_separator"></td></tr>';
8603: $itemcount ++;
8604: }
8605: $output .= &Apache::loncommon::end_data_table();
8606: }
8607: }
8608: }
8609: return $output;
8610: }
8611:
8612: =pod
8613:
8614: =item *&assign_category_rows()
8615:
8616: Create a datatable row for display of nested categories in a domain,
8617: with checkboxes to allow a course to be categorized,called recursively.
8618:
8619: Inputs:
8620:
8621: itemcount - track row number for alternating colors
8622:
8623: cats - reference to array of arrays/hashes which encapsulates hierarchy of
8624: categories and subcategories.
8625:
8626: depth - current depth in hierarchy of categories and sub-categories - 0 indexed.
8627:
8628: parent - parent of current category item
8629:
8630: path - Array containing all categories back up through the hierarchy from the
8631: current category to the top level.
8632:
8633: currcategories - reference to array of current categories assigned to the course
8634:
8635: Returns: $output (markup to be displayed).
8636:
8637: =cut
8638:
8639: sub assign_category_rows {
8640: my ($itemcount,$cats,$depth,$parent,$path,$currcategories) = @_;
8641: my ($text,$name,$item,$chgstr);
8642: if (ref($cats) eq 'ARRAY') {
8643: my $maxdepth = scalar(@{$cats});
8644: if (ref($cats->[$depth]) eq 'HASH') {
8645: if (ref($cats->[$depth]{$parent}) eq 'ARRAY') {
8646: my $numchildren = @{$cats->[$depth]{$parent}};
8647: my $css_class = $itemcount%2?' class="LC_odd_row"':'';
8648: $text .= '<td><table class="LC_datatable">';
8649: for (my $j=0; $j<$numchildren; $j++) {
8650: $name = $cats->[$depth]{$parent}[$j];
8651: $item = &escape($name).':'.&escape($parent).':'.$depth;
8652: my $deeper = $depth+1;
8653: my $checked = '';
8654: if (ref($currcategories) eq 'ARRAY') {
8655: if (@{$currcategories} > 0) {
8656: if (grep(/^\Q$item\E$/,@{$currcategories})) {
8657: $checked = ' checked="checked" ';
8658: }
8659: }
8660: }
1.664 raeburn 8661: $text .= '<tr><td><span class="LC_nobreak"><label>'.
8662: '<input type="checkbox" name="usecategory" value="'.
1.675 raeburn 8663: $item.'"'.$checked.' />'.$name.'</label></span>'.
8664: '<input type="hidden" name="catname" value="'.$name.'" />'.
8665: '</td><td>';
1.663 raeburn 8666: if (ref($path) eq 'ARRAY') {
8667: push(@{$path},$name);
8668: $text .= &assign_category_rows($itemcount,$cats,$deeper,$name,$path,$currcategories);
8669: pop(@{$path});
8670: }
8671: $text .= '</td></tr>';
8672: }
8673: $text .= '</table></td>';
8674: }
8675: }
8676: }
8677: return $text;
8678: }
8679:
1.655 raeburn 8680: ############################################################
8681: ############################################################
8682:
8683:
1.443 albertel 8684: sub commit_customrole {
1.664 raeburn 8685: my ($udom,$uname,$url,$three,$four,$five,$start,$end,$context) = @_;
1.630 raeburn 8686: my $output = &mt('Assigning custom role').' "'.$five.'" by '.$four.':'.$three.' in '.$url.
1.443 albertel 8687: ($start?', '.&mt('starting').' '.localtime($start):'').
8688: ($end?', ending '.localtime($end):'').': <b>'.
8689: &Apache::lonnet::assigncustomrole(
1.664 raeburn 8690: $udom,$uname,$url,$three,$four,$five,$end,$start,undef,undef,$context).
1.443 albertel 8691: '</b><br />';
8692: return $output;
8693: }
8694:
8695: sub commit_standardrole {
1.541 raeburn 8696: my ($udom,$uname,$url,$three,$start,$end,$one,$two,$sec,$context) = @_;
8697: my ($output,$logmsg,$linefeed);
8698: if ($context eq 'auto') {
8699: $linefeed = "\n";
8700: } else {
8701: $linefeed = "<br />\n";
8702: }
1.443 albertel 8703: if ($three eq 'st') {
1.541 raeburn 8704: my $result = &commit_studentrole(\$logmsg,$udom,$uname,$url,$three,$start,$end,
8705: $one,$two,$sec,$context);
8706: if (($result =~ /^error/) || ($result eq 'not_in_class') ||
1.626 raeburn 8707: ($result eq 'unknown_course') || ($result eq 'refused')) {
8708: $output = $logmsg.' '.&mt('Error: ').$result."\n";
1.443 albertel 8709: } else {
1.541 raeburn 8710: $output = $logmsg.$linefeed.&mt('Assigning').' '.$three.' in '.$url.
1.443 albertel 8711: ($start?', '.&mt('starting').' '.localtime($start):'').
1.541 raeburn 8712: ($end?', '.&mt('ending').' '.localtime($end):'').': ';
8713: if ($context eq 'auto') {
8714: $output .= $result.$linefeed.&mt('Add to classlist').': ok';
8715: } else {
8716: $output .= '<b>'.$result.'</b>'.$linefeed.
8717: &mt('Add to classlist').': <b>ok</b>';
8718: }
8719: $output .= $linefeed;
1.443 albertel 8720: }
8721: } else {
8722: $output = &mt('Assigning').' '.$three.' in '.$url.
8723: ($start?', '.&mt('starting').' '.localtime($start):'').
1.541 raeburn 8724: ($end?', '.&mt('ending').' '.localtime($end):'').': ';
1.652 raeburn 8725: my $result = &Apache::lonnet::assignrole($udom,$uname,$url,$three,$end,$start,'','',$context);
1.541 raeburn 8726: if ($context eq 'auto') {
8727: $output .= $result.$linefeed;
8728: } else {
8729: $output .= '<b>'.$result.'</b>'.$linefeed;
8730: }
1.443 albertel 8731: }
8732: return $output;
8733: }
8734:
8735: sub commit_studentrole {
1.541 raeburn 8736: my ($logmsg,$udom,$uname,$url,$three,$start,$end,$one,$two,$sec,$context) = @_;
1.626 raeburn 8737: my ($result,$linefeed,$oldsecurl,$newsecurl);
1.541 raeburn 8738: if ($context eq 'auto') {
8739: $linefeed = "\n";
8740: } else {
8741: $linefeed = '<br />'."\n";
8742: }
1.443 albertel 8743: if (defined($one) && defined($two)) {
8744: my $cid=$one.'_'.$two;
8745: my $oldsec=&Apache::lonnet::getsection($udom,$uname,$cid);
8746: my $secchange = 0;
8747: my $expire_role_result;
8748: my $modify_section_result;
1.628 raeburn 8749: if ($oldsec ne '-1') {
8750: if ($oldsec ne $sec) {
1.443 albertel 8751: $secchange = 1;
1.628 raeburn 8752: my $now = time;
1.443 albertel 8753: my $uurl='/'.$cid;
8754: $uurl=~s/\_/\//g;
8755: if ($oldsec) {
8756: $uurl.='/'.$oldsec;
8757: }
1.626 raeburn 8758: $oldsecurl = $uurl;
1.628 raeburn 8759: $expire_role_result =
1.652 raeburn 8760: &Apache::lonnet::assignrole($udom,$uname,$uurl,'st',$now,'','',$context);
1.628 raeburn 8761: if ($env{'request.course.sec'} ne '') {
8762: if ($expire_role_result eq 'refused') {
8763: my @roles = ('st');
8764: my @statuses = ('previous');
8765: my @roledoms = ($one);
8766: my $withsec = 1;
8767: my %roleshash =
8768: &Apache::lonnet::get_my_roles($uname,$udom,'userroles',
8769: \@statuses,\@roles,\@roledoms,$withsec);
8770: if (defined ($roleshash{$two.':'.$one.':st:'.$oldsec})) {
8771: my ($oldstart,$oldend) =
8772: split(':',$roleshash{$two.':'.$one.':st:'.$oldsec});
8773: if ($oldend > 0 && $oldend <= $now) {
8774: $expire_role_result = 'ok';
8775: }
8776: }
8777: }
8778: }
1.443 albertel 8779: $result = $expire_role_result;
8780: }
8781: }
8782: if (($expire_role_result eq 'ok') || ($secchange == 0)) {
1.652 raeburn 8783: $modify_section_result = &Apache::lonnet::modify_student_enrollment($udom,$uname,undef,undef,undef,undef,undef,$sec,$end,$start,'','',$cid,'',$context);
1.443 albertel 8784: if ($modify_section_result =~ /^ok/) {
8785: if ($secchange == 1) {
1.628 raeburn 8786: if ($sec eq '') {
8787: $$logmsg .= &mt('Section for [_1] switched from (possibly expired) old section: [_2] to student role without a section.',$uname,$oldsec).$linefeed;
8788: } else {
8789: $$logmsg .= &mt('Section for [_1] switched from (possibly expired) old section: [_2] to new section: [_3].',$uname,$oldsec,$sec).$linefeed;
8790: }
1.443 albertel 8791: } elsif ($oldsec eq '-1') {
1.628 raeburn 8792: if ($sec eq '') {
8793: $$logmsg .= &mt('New student role without a section for [_1] in course [_2].',$uname,$cid).$linefeed;
8794: } else {
8795: $$logmsg .= &mt('New student role for [_1] in section [_2] in course [_3].',$uname,$sec,$cid).$linefeed;
8796: }
1.443 albertel 8797: } else {
1.628 raeburn 8798: if ($sec eq '') {
8799: $$logmsg .= &mt('Student [_1] assigned to course [_2] without a section.',$uname,$cid).$linefeed;
8800: } else {
8801: $$logmsg .= &mt('Student [_1] assigned to section [_2] in course [_3].',$uname,$sec,$cid).$linefeed;
8802: }
1.443 albertel 8803: }
8804: } else {
1.628 raeburn 8805: if ($secchange) {
8806: $$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;
8807: } else {
8808: $$logmsg .= &mt('Error when attempting to modify role for [_1] for section: "[_2]" in course [_3] -error:',$uname,$sec,$cid).' '.$modify_section_result.$linefeed;
8809: }
1.443 albertel 8810: }
8811: $result = $modify_section_result;
8812: } elsif ($secchange == 1) {
1.628 raeburn 8813: if ($oldsec eq '') {
8814: $$logmsg .= &mt('Error when attempting to expire existing role without a section for [_1] in course [_3] -error: ',$uname,$cid).' '.$expire_role_result.$linefeed;
8815: } else {
8816: $$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;
8817: }
1.626 raeburn 8818: if ($expire_role_result eq 'refused') {
8819: my $newsecurl = '/'.$cid;
8820: $newsecurl =~ s/\_/\//g;
8821: if ($sec ne '') {
8822: $newsecurl.='/'.$sec;
8823: }
8824: if (&Apache::lonnet::allowed('cst',$newsecurl) && !(&Apache::lonnet::allowed('cst',$oldsecurl))) {
8825: if ($sec eq '') {
8826: $$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;
8827: } else {
8828: $$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;
8829: }
8830: }
8831: }
1.443 albertel 8832: }
8833: } else {
1.626 raeburn 8834: $$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 8835: $result = "error: incomplete course id\n";
8836: }
8837: return $result;
8838: }
8839:
8840: ############################################################
8841: ############################################################
8842:
1.566 albertel 8843: sub check_clone {
1.578 raeburn 8844: my ($args,$linefeed) = @_;
1.566 albertel 8845: my $cloneid='/'.$args->{'clonedomain'}.'/'.$args->{'clonecourse'};
8846: my ($clonecrsudom,$clonecrsunum)= &LONCAPA::split_courseid($cloneid);
8847: my $clonehome=&Apache::lonnet::homeserver($clonecrsunum,$clonecrsudom);
8848: my $clonemsg;
8849: my $can_clone = 0;
8850:
8851: if ($clonehome eq 'no_host') {
1.578 raeburn 8852: $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 8853: } else {
8854: my %clonedesc = &Apache::lonnet::coursedescription($cloneid,{'one_time' => 1});
1.568 albertel 8855: if ($env{'request.role.domain'} eq $args->{'clonedomain'}) {
1.566 albertel 8856: $can_clone = 1;
8857: } else {
8858: my %clonehash = &Apache::lonnet::get('environment',['cloners'],
8859: $args->{'clonedomain'},$args->{'clonecourse'});
8860: my @cloners = split(/,/,$clonehash{'cloners'});
1.578 raeburn 8861: if (grep(/^\*$/,@cloners)) {
8862: $can_clone = 1;
8863: } elsif (grep(/^\*\:\Q$args->{'ccdomain'}\E$/,@cloners)) {
8864: $can_clone = 1;
8865: } else {
8866: my %roleshash =
8867: &Apache::lonnet::get_my_roles($args->{'ccuname'},
8868: $args->{'ccdomain'},
8869: 'userroles',['active'],['cc'],
8870: [$args->{'clonedomain'}]);
8871: if (($roleshash{$args->{'clonecourse'}.':'.$args->{'clonedomain'}.':cc'}) || (grep(/^\Q$args->{'ccuname'}\E:\Q$args->{'ccdomain'}\E$/,@cloners))) {
8872: $can_clone = 1;
8873: } else {
8874: $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'});
8875: }
1.566 albertel 8876: }
1.578 raeburn 8877: }
1.566 albertel 8878: }
8879: return ($can_clone, $clonemsg, $cloneid, $clonehome);
8880: }
8881:
1.444 albertel 8882: sub construct_course {
1.541 raeburn 8883: my ($args,$logmsg,$courseid,$crsudom,$crsunum,$udom,$uname,$context) = @_;
1.444 albertel 8884: my $outcome;
1.541 raeburn 8885: my $linefeed = '<br />'."\n";
8886: if ($context eq 'auto') {
8887: $linefeed = "\n";
8888: }
1.566 albertel 8889:
8890: #
8891: # Are we cloning?
8892: #
8893: my ($can_clone, $clonemsg, $cloneid, $clonehome);
8894: if (($args->{'clonecourse'}) && ($args->{'clonedomain'})) {
1.578 raeburn 8895: ($can_clone, $clonemsg, $cloneid, $clonehome) = &check_clone($args,$linefeed);
1.566 albertel 8896: if ($context ne 'auto') {
1.578 raeburn 8897: if ($clonemsg ne '') {
8898: $clonemsg = '<span class="LC_error">'.$clonemsg.'</span>';
8899: }
1.566 albertel 8900: }
8901: $outcome .= $clonemsg.$linefeed;
8902:
8903: if (!$can_clone) {
8904: return (0,$outcome);
8905: }
8906: }
8907:
1.444 albertel 8908: #
8909: # Open course
8910: #
8911: my $crstype = lc($args->{'crstype'});
8912: my %cenv=();
8913: $$courseid=&Apache::lonnet::createcourse($args->{'course_domain'},
8914: $args->{'cdescr'},
8915: $args->{'curl'},
8916: $args->{'course_home'},
8917: $args->{'nonstandard'},
8918: $args->{'crscode'},
8919: $args->{'ccuname'}.':'.
8920: $args->{'ccdomain'},
8921: $args->{'crstype'});
8922:
8923: # Note: The testing routines depend on this being output; see
8924: # Utils::Course. This needs to at least be output as a comment
8925: # if anyone ever decides to not show this, and Utils::Course::new
8926: # will need to be suitably modified.
1.541 raeburn 8927: $outcome .= &mt('New LON-CAPA [_1] ID: [_2]',$crstype,$$courseid).$linefeed;
1.444 albertel 8928: #
8929: # Check if created correctly
8930: #
1.479 albertel 8931: ($$crsudom,$$crsunum)= &LONCAPA::split_courseid($$courseid);
1.444 albertel 8932: my $crsuhome=&Apache::lonnet::homeserver($$crsunum,$$crsudom);
1.541 raeburn 8933: $outcome .= &mt('Created on').': '.$crsuhome.$linefeed;
1.566 albertel 8934:
1.444 albertel 8935: #
1.566 albertel 8936: # Do the cloning
8937: #
8938: if ($can_clone && $cloneid) {
8939: $clonemsg = &mt('Cloning [_1] from [_2]',$crstype,$clonehome);
8940: if ($context ne 'auto') {
8941: $clonemsg = '<span class="LC_success">'.$clonemsg.'</span>';
8942: }
8943: $outcome .= $clonemsg.$linefeed;
8944: my %oldcenv=&Apache::lonnet::dump('environment',$$crsudom,$$crsunum);
1.444 albertel 8945: # Copy all files
1.637 www 8946: &Apache::lonclonecourse::copycoursefiles($cloneid,$$courseid,$args->{'datemode'},$args->{'dateshift'});
1.444 albertel 8947: # Restore URL
1.566 albertel 8948: $cenv{'url'}=$oldcenv{'url'};
1.444 albertel 8949: # Restore title
1.566 albertel 8950: $cenv{'description'}=$oldcenv{'description'};
1.444 albertel 8951: # Mark as cloned
1.566 albertel 8952: $cenv{'clonedfrom'}=$cloneid;
1.638 www 8953: # Need to clone grading mode
8954: my %newenv=&Apache::lonnet::get('environment',['grading'],$$crsudom,$$crsunum);
8955: $cenv{'grading'}=$newenv{'grading'};
8956: # Do not clone these environment entries
8957: &Apache::lonnet::del('environment',
8958: ['default_enrollment_start_date',
8959: 'default_enrollment_end_date',
8960: 'question.email',
8961: 'policy.email',
8962: 'comment.email',
8963: 'pch.users.denied',
8964: 'plc.users.denied'],
8965: $$crsudom,$$crsunum);
1.444 albertel 8966: }
1.566 albertel 8967:
1.444 albertel 8968: #
8969: # Set environment (will override cloned, if existing)
8970: #
8971: my @sections = ();
8972: my @xlists = ();
8973: if ($args->{'crstype'}) {
8974: $cenv{'type'}=$args->{'crstype'};
8975: }
8976: if ($args->{'crsid'}) {
8977: $cenv{'courseid'}=$args->{'crsid'};
8978: }
8979: if ($args->{'crscode'}) {
8980: $cenv{'internal.coursecode'}=$args->{'crscode'};
8981: }
8982: if ($args->{'crsquota'} ne '') {
8983: $cenv{'internal.coursequota'}=$args->{'crsquota'};
8984: } else {
8985: $cenv{'internal.coursequota'}=$args->{'crsquota'} = 20;
8986: }
8987: if ($args->{'ccuname'}) {
8988: $cenv{'internal.courseowner'} = $args->{'ccuname'}.
8989: ':'.$args->{'ccdomain'};
8990: } else {
8991: $cenv{'internal.courseowner'} = $args->{'curruser'};
8992: }
8993: my @badclasses = (); # Used to accumulate sections/crosslistings that did not pass classlist access check for course owner.
8994: if ($args->{'crssections'}) {
8995: $cenv{'internal.sectionnums'} = '';
8996: if ($args->{'crssections'} =~ m/,/) {
8997: @sections = split/,/,$args->{'crssections'};
8998: } else {
8999: $sections[0] = $args->{'crssections'};
9000: }
9001: if (@sections > 0) {
9002: foreach my $item (@sections) {
9003: my ($sec,$gp) = split/:/,$item;
9004: my $class = $args->{'crscode'}.$sec;
9005: my $addcheck = &Apache::lonnet::auto_new_course($$crsunum,$$crsudom,$class,$cenv{'internal.courseowner'});
9006: $cenv{'internal.sectionnums'} .= $item.',';
9007: unless ($addcheck eq 'ok') {
9008: push @badclasses, $class;
9009: }
9010: }
9011: $cenv{'internal.sectionnums'} =~ s/,$//;
9012: }
9013: }
9014: # do not hide course coordinator from staff listing,
9015: # even if privileged
9016: $cenv{'nothideprivileged'}=$args->{'ccuname'}.':'.$args->{'ccdomain'};
9017: # add crosslistings
9018: if ($args->{'crsxlist'}) {
9019: $cenv{'internal.crosslistings'}='';
9020: if ($args->{'crsxlist'} =~ m/,/) {
9021: @xlists = split/,/,$args->{'crsxlist'};
9022: } else {
9023: $xlists[0] = $args->{'crsxlist'};
9024: }
9025: if (@xlists > 0) {
9026: foreach my $item (@xlists) {
9027: my ($xl,$gp) = split/:/,$item;
9028: my $addcheck = &Apache::lonnet::auto_new_course($$crsunum,$$crsudom,$xl,$cenv{'internal.courseowner'});
9029: $cenv{'internal.crosslistings'} .= $item.',';
9030: unless ($addcheck eq 'ok') {
9031: push @badclasses, $xl;
9032: }
9033: }
9034: $cenv{'internal.crosslistings'} =~ s/,$//;
9035: }
9036: }
9037: if ($args->{'autoadds'}) {
9038: $cenv{'internal.autoadds'}=$args->{'autoadds'};
9039: }
9040: if ($args->{'autodrops'}) {
9041: $cenv{'internal.autodrops'}=$args->{'autodrops'};
9042: }
9043: # check for notification of enrollment changes
9044: my @notified = ();
9045: if ($args->{'notify_owner'}) {
9046: if ($args->{'ccuname'} ne '') {
9047: push(@notified,$args->{'ccuname'}.':'.$args->{'ccdomain'});
9048: }
9049: }
9050: if ($args->{'notify_dc'}) {
9051: if ($uname ne '') {
1.630 raeburn 9052: push(@notified,$uname.':'.$udom);
1.444 albertel 9053: }
9054: }
9055: if (@notified > 0) {
9056: my $notifylist;
9057: if (@notified > 1) {
9058: $notifylist = join(',',@notified);
9059: } else {
9060: $notifylist = $notified[0];
9061: }
9062: $cenv{'internal.notifylist'} = $notifylist;
9063: }
9064: if (@badclasses > 0) {
9065: my %lt=&Apache::lonlocal::texthash(
9066: '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',
9067: 'dnhr' => 'does not have rights to access enrollment in these classes',
9068: 'adby' => 'as determined by the policies of your institution on access to official classlists'
9069: );
1.541 raeburn 9070: my $badclass_msg = $cenv{'internal.courseowner'}.') - '.$lt{'dnhr'}.
9071: ' ('.$lt{'adby'}.')';
9072: if ($context eq 'auto') {
9073: $outcome .= $badclass_msg.$linefeed;
1.566 albertel 9074: $outcome .= '<div class="LC_warning">'.$badclass_msg.$linefeed.'<ul>'."\n";
1.541 raeburn 9075: foreach my $item (@badclasses) {
9076: if ($context eq 'auto') {
9077: $outcome .= " - $item\n";
9078: } else {
9079: $outcome .= "<li>$item</li>\n";
9080: }
9081: }
9082: if ($context eq 'auto') {
9083: $outcome .= $linefeed;
9084: } else {
1.566 albertel 9085: $outcome .= "</ul><br /><br /></div>\n";
1.541 raeburn 9086: }
9087: }
1.444 albertel 9088: }
9089: if ($args->{'no_end_date'}) {
9090: $args->{'endaccess'} = 0;
9091: }
9092: $cenv{'internal.autostart'}=$args->{'enrollstart'};
9093: $cenv{'internal.autoend'}=$args->{'enrollend'};
9094: $cenv{'default_enrollment_start_date'}=$args->{'startaccess'};
9095: $cenv{'default_enrollment_end_date'}=$args->{'endaccess'};
9096: if ($args->{'showphotos'}) {
9097: $cenv{'internal.showphotos'}=$args->{'showphotos'};
9098: }
9099: $cenv{'internal.authtype'} = $args->{'authtype'};
9100: $cenv{'internal.autharg'} = $args->{'autharg'};
9101: if ( ($cenv{'internal.authtype'} =~ /^krb/) && ($cenv{'internal.autoadds'} == 1)) {
9102: if (! defined($cenv{'internal.autharg'}) || $cenv{'internal.autharg'} eq '') {
1.541 raeburn 9103: 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');
9104: if ($context eq 'auto') {
9105: $outcome .= $krb_msg;
9106: } else {
1.566 albertel 9107: $outcome .= '<span class="LC_error">'.$krb_msg.'</span>';
1.541 raeburn 9108: }
9109: $outcome .= $linefeed;
1.444 albertel 9110: }
9111: }
9112: if (($args->{'ccdomain'}) && ($args->{'ccuname'})) {
9113: if ($args->{'setpolicy'}) {
9114: $cenv{'policy.email'}=$args->{'ccuname'}.':'.$args->{'ccdomain'};
9115: }
9116: if ($args->{'setcontent'}) {
9117: $cenv{'question.email'}=$args->{'ccuname'}.':'.$args->{'ccdomain'};
9118: }
9119: }
9120: if ($args->{'reshome'}) {
9121: $cenv{'reshome'}=$args->{'reshome'}.'/';
9122: $cenv{'reshome'}=~s/\/+$/\//;
9123: }
9124: #
9125: # course has keyed access
9126: #
9127: if ($args->{'setkeys'}) {
9128: $cenv{'keyaccess'}='yes';
9129: }
9130: # if specified, key authority is not course, but user
9131: # only active if keyaccess is yes
9132: if ($args->{'keyauth'}) {
1.487 albertel 9133: my ($user,$domain) = split(':',$args->{'keyauth'});
9134: $user = &LONCAPA::clean_username($user);
9135: $domain = &LONCAPA::clean_username($domain);
1.488 foxr 9136: if ($user ne '' && $domain ne '') {
1.487 albertel 9137: $cenv{'keyauth'}=$user.':'.$domain;
1.444 albertel 9138: }
9139: }
9140:
9141: if ($args->{'disresdis'}) {
9142: $cenv{'pch.roles.denied'}='st';
9143: }
9144: if ($args->{'disablechat'}) {
9145: $cenv{'plc.roles.denied'}='st';
9146: }
9147:
9148: # Record we've not yet viewed the Course Initialization Helper for this
9149: # course
9150: $cenv{'course.helper.not.run'} = 1;
9151: #
9152: # Use new Randomseed
9153: #
9154: $cenv{'rndseed'}=&Apache::lonnet::latest_rnd_algorithm_id();;
9155: $cenv{'receiptalg'}=&Apache::lonnet::latest_receipt_algorithm_id();;
9156: #
9157: # The encryption code and receipt prefix for this course
9158: #
9159: $cenv{'internal.encseed'}=$Apache::lonnet::perlvar{'lonReceipt'}.$$.time.int(rand(9999));
9160: $cenv{'internal.encpref'}=100+int(9*rand(99));
9161: #
9162: # By default, use standard grading
9163: if (!defined($cenv{'grading'})) { $cenv{'grading'} = 'standard'; }
9164:
1.541 raeburn 9165: $outcome .= $linefeed.&mt('Setting environment').': '.
9166: &Apache::lonnet::put('environment',\%cenv,$$crsudom,$$crsunum).$linefeed;
1.444 albertel 9167: #
9168: # Open all assignments
9169: #
9170: if ($args->{'openall'}) {
9171: my $storeunder=$$crsudom.'_'.$$crsunum.'.0.opendate';
9172: my %storecontent = ($storeunder => time,
9173: $storeunder.'.type' => 'date_start');
9174:
9175: $outcome .= &mt('Opening all assignments').': '.&Apache::lonnet::cput
1.541 raeburn 9176: ('resourcedata',\%storecontent,$$crsudom,$$crsunum).$linefeed;
1.444 albertel 9177: }
9178: #
9179: # Set first page
9180: #
9181: unless (($args->{'nonstandard'}) || ($args->{'firstres'} eq 'blank')
9182: || ($cloneid)) {
1.445 albertel 9183: use LONCAPA::map;
1.444 albertel 9184: $outcome .= &mt('Setting first resource').': ';
1.445 albertel 9185:
9186: my $map = '/uploaded/'.$$crsudom.'/'.$$crsunum.'/default.sequence';
9187: my ($errtext,$fatal)=&LONCAPA::map::mapread($map);
9188:
1.444 albertel 9189: $outcome .= ($fatal?$errtext:'read ok').' - ';
9190: my $title; my $url;
9191: if ($args->{'firstres'} eq 'syl') {
9192: $title='Syllabus';
9193: $url='/public/'.$$crsudom.'/'.$$crsunum.'/syllabus';
9194: } else {
9195: $title='Navigate Contents';
9196: $url='/adm/navmaps';
9197: }
1.445 albertel 9198:
9199: $LONCAPA::map::resources[1]=$title.':'.$url.':false:start:res';
9200: (my $outtext,$errtext) = &LONCAPA::map::storemap($map,1);
9201:
9202: if ($errtext) { $fatal=2; }
1.541 raeburn 9203: $outcome .= ($fatal?$errtext:'write ok').$linefeed;
1.444 albertel 9204: }
1.566 albertel 9205:
9206: return (1,$outcome);
1.444 albertel 9207: }
9208:
9209: ############################################################
9210: ############################################################
9211:
1.378 raeburn 9212: sub course_type {
9213: my ($cid) = @_;
9214: if (!defined($cid)) {
9215: $cid = $env{'request.course.id'};
9216: }
1.404 albertel 9217: if (defined($env{'course.'.$cid.'.type'})) {
9218: return $env{'course.'.$cid.'.type'};
1.378 raeburn 9219: } else {
9220: return 'Course';
1.377 raeburn 9221: }
9222: }
1.156 albertel 9223:
1.406 raeburn 9224: sub group_term {
9225: my $crstype = &course_type();
9226: my %names = (
9227: 'Course' => 'group',
9228: 'Group' => 'team',
9229: );
9230: return $names{$crstype};
9231: }
9232:
1.156 albertel 9233: sub icon {
9234: my ($file)=@_;
1.505 albertel 9235: my $curfext = lc((split(/\./,$file))[-1]);
1.168 albertel 9236: my $iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/unknown.gif';
1.156 albertel 9237: my $embstyle = &Apache::loncommon::fileembstyle($curfext);
1.168 albertel 9238: if (!(!defined($embstyle) || $embstyle eq 'unk' || $embstyle eq 'hdn')) {
9239: if (-e $Apache::lonnet::perlvar{'lonDocRoot'}.'/'.
9240: $Apache::lonnet::perlvar{'lonIconsURL'}.'/'.
9241: $curfext.".gif") {
9242: $iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/'.
9243: $curfext.".gif";
9244: }
9245: }
1.249 albertel 9246: return &lonhttpdurl($iconname);
1.154 albertel 9247: }
1.84 albertel 9248:
1.575 albertel 9249: sub lonhttpd_port {
1.215 albertel 9250: my $lonhttpd_port=$Apache::lonnet::perlvar{'lonhttpdPort'};
9251: if (!defined($lonhttpd_port)) { $lonhttpd_port='8080'; }
1.574 albertel 9252: # IE doesn't like a secure page getting images from a non-secure
9253: # port (when logging we haven't parsed the browser type so default
9254: # back to secure
9255: if ((!exists($env{'browser.type'}) || $env{'browser.type'} eq 'explorer')
9256: && $ENV{'SERVER_PORT'} == 443) {
1.575 albertel 9257: return 443;
9258: }
9259: return $lonhttpd_port;
9260:
9261: }
9262:
9263: sub lonhttpdurl {
9264: my ($url)=@_;
9265:
9266: my $lonhttpd_port = &lonhttpd_port();
9267: if ($lonhttpd_port == 443) {
1.574 albertel 9268: return 'https://'.$ENV{'SERVER_NAME'}.$url;
9269: }
1.215 albertel 9270: return 'http://'.$ENV{'SERVER_NAME'}.':'.$lonhttpd_port.$url;
9271: }
9272:
1.213 albertel 9273: sub connection_aborted {
9274: my ($r)=@_;
9275: $r->print(" ");$r->rflush();
9276: my $c = $r->connection;
9277: return $c->aborted();
9278: }
9279:
1.221 foxr 9280: # Escapes strings that may have embedded 's that will be put into
1.222 foxr 9281: # strings as 'strings'.
9282: sub escape_single {
1.221 foxr 9283: my ($input) = @_;
1.223 albertel 9284: $input =~ s/\\/\\\\/g; # Escape the \'s..(must be first)>
1.221 foxr 9285: $input =~ s/\'/\\\'/g; # Esacpe the 's....
9286: return $input;
9287: }
1.223 albertel 9288:
1.222 foxr 9289: # Same as escape_single, but escape's "'s This
9290: # can be used for "strings"
9291: sub escape_double {
9292: my ($input) = @_;
9293: $input =~ s/\\/\\\\/g; # Escape the /'s..(must be first)>
9294: $input =~ s/\"/\\\"/g; # Esacpe the "s....
9295: return $input;
9296: }
1.223 albertel 9297:
1.222 foxr 9298: # Escapes the last element of a full URL.
9299: sub escape_url {
9300: my ($url) = @_;
1.238 raeburn 9301: my @urlslices = split(/\//, $url,-1);
1.369 www 9302: my $lastitem = &escape(pop(@urlslices));
1.223 albertel 9303: return join('/',@urlslices).'/'.$lastitem;
1.222 foxr 9304: }
1.462 albertel 9305:
9306: # -------------------------------------------------------- Initliaze user login
9307: sub init_user_environment {
1.463 albertel 9308: my ($r, $username, $domain, $authhost, $form, $args) = @_;
1.462 albertel 9309: my $lonids=$Apache::lonnet::perlvar{'lonIDsDir'};
9310:
9311: my $public=($username eq 'public' && $domain eq 'public');
9312:
9313: # See if old ID present, if so, remove
9314:
9315: my ($filename,$cookie,$userroles);
9316: my $now=time;
9317:
9318: if ($public) {
9319: my $max_public=100;
9320: my $oldest;
9321: my $oldest_time=0;
9322: for(my $next=1;$next<=$max_public;$next++) {
9323: if (-e $lonids."/publicuser_$next.id") {
9324: my $mtime=(stat($lonids."/publicuser_$next.id"))[9];
9325: if ($mtime<$oldest_time || !$oldest_time) {
9326: $oldest_time=$mtime;
9327: $oldest=$next;
9328: }
9329: } else {
9330: $cookie="publicuser_$next";
9331: last;
9332: }
9333: }
9334: if (!$cookie) { $cookie="publicuser_$oldest"; }
9335: } else {
1.463 albertel 9336: # if this isn't a robot, kill any existing non-robot sessions
9337: if (!$args->{'robot'}) {
9338: opendir(DIR,$lonids);
9339: while ($filename=readdir(DIR)) {
9340: if ($filename=~/^$username\_\d+\_$domain\_$authhost\.id$/) {
9341: unlink($lonids.'/'.$filename);
9342: }
1.462 albertel 9343: }
1.463 albertel 9344: closedir(DIR);
1.462 albertel 9345: }
9346: # Give them a new cookie
1.463 albertel 9347: my $id = ($args->{'robot'} ? 'robot'.$args->{'robot'}
1.684 www 9348: : $now.$$.int(rand(10000)));
1.463 albertel 9349: $cookie="$username\_$id\_$domain\_$authhost";
1.462 albertel 9350:
9351: # Initialize roles
9352:
9353: $userroles=&Apache::lonnet::rolesinit($domain,$username,$authhost);
9354: }
9355: # ------------------------------------ Check browser type and MathML capability
9356:
9357: my ($httpbrowser,$clientbrowser,$clientversion,$clientmathml,
9358: $clientunicode,$clientos) = &decode_user_agent($r);
9359:
9360: # -------------------------------------- Any accessibility options to remember?
9361: if (($form->{'interface'}) && ($form->{'remember'} eq 'true')) {
9362: foreach my $option ('imagesuppress','appletsuppress',
9363: 'embedsuppress','fontenhance','blackwhite') {
9364: if ($form->{$option} eq 'true') {
9365: &Apache::lonnet::put('environment',{$option => 'on'},
9366: $domain,$username);
9367: } else {
9368: &Apache::lonnet::del('environment',[$option],
9369: $domain,$username);
9370: }
9371: }
9372: }
9373: # ------------------------------------------------------------- Get environment
9374:
9375: my %userenv = &Apache::lonnet::dump('environment',$domain,$username);
9376: my ($tmp) = keys(%userenv);
9377: if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
9378: # default remote control to off
9379: if ($userenv{'remote'} ne 'on') { $userenv{'remote'} = 'off'; }
9380: } else {
9381: undef(%userenv);
9382: }
9383: if (($userenv{'interface'}) && (!$form->{'interface'})) {
9384: $form->{'interface'}=$userenv{'interface'};
9385: }
9386: $env{'environment.remote'}=$userenv{'remote'};
9387: if ($userenv{'texengine'} eq 'ttm') { $clientmathml=1; }
9388:
9389: # --------------- Do not trust query string to be put directly into environment
9390: foreach my $option ('imagesuppress','appletsuppress',
9391: 'embedsuppress','fontenhance','blackwhite',
9392: 'interface','localpath','localres') {
9393: $form->{$option}=~s/[\n\r\=]//gs;
9394: }
9395: # --------------------------------------------------------- Write first profile
9396:
9397: {
9398: my %initial_env =
9399: ("user.name" => $username,
9400: "user.domain" => $domain,
9401: "user.home" => $authhost,
9402: "browser.type" => $clientbrowser,
9403: "browser.version" => $clientversion,
9404: "browser.mathml" => $clientmathml,
9405: "browser.unicode" => $clientunicode,
9406: "browser.os" => $clientos,
9407: "server.domain" => $Apache::lonnet::perlvar{'lonDefDomain'},
9408: "request.course.fn" => '',
9409: "request.course.uri" => '',
9410: "request.course.sec" => '',
9411: "request.role" => 'cm',
9412: "request.role.adv" => $env{'user.adv'},
9413: "request.host" => $ENV{'REMOTE_ADDR'},);
9414:
9415: if ($form->{'localpath'}) {
9416: $initial_env{"browser.localpath"} = $form->{'localpath'};
9417: $initial_env{"browser.localres"} = $form->{'localres'};
9418: }
9419:
9420: if ($public) {
9421: $initial_env{"environment.remote"} = "off";
9422: }
9423: if ($form->{'interface'}) {
9424: $form->{'interface'}=~s/\W//gs;
9425: $initial_env{"browser.interface"} = $form->{'interface'};
9426: $env{'browser.interface'}=$form->{'interface'};
9427: foreach my $option ('imagesuppress','appletsuppress',
9428: 'embedsuppress','fontenhance','blackwhite') {
9429: if (($form->{$option} eq 'true') ||
9430: ($userenv{$option} eq 'on')) {
9431: $initial_env{"browser.$option"} = "on";
9432: }
9433: }
9434: }
9435:
9436: $env{'user.environment'} = "$lonids/$cookie.id";
9437:
9438: if (tie(my %disk_env,'GDBM_File',"$lonids/$cookie.id",
9439: &GDBM_WRCREAT(),0640)) {
9440: &_add_to_env(\%disk_env,\%initial_env);
9441: &_add_to_env(\%disk_env,\%userenv,'environment.');
9442: &_add_to_env(\%disk_env,$userroles);
1.463 albertel 9443: if (ref($args->{'extra_env'})) {
9444: &_add_to_env(\%disk_env,$args->{'extra_env'});
9445: }
1.462 albertel 9446: untie(%disk_env);
9447: } else {
9448: &Apache::lonnet::logthis("<font color=\"blue\">WARNING: ".
9449: 'Could not create environment storage in lonauth: '.$!.'</font>');
9450: return 'error: '.$!;
9451: }
9452: }
9453: $env{'request.role'}='cm';
9454: $env{'request.role.adv'}=$env{'user.adv'};
9455: $env{'browser.type'}=$clientbrowser;
9456:
9457: return $cookie;
9458:
9459: }
9460:
9461: sub _add_to_env {
9462: my ($idf,$env_data,$prefix) = @_;
1.676 raeburn 9463: if (ref($env_data) eq 'HASH') {
9464: while (my ($key,$value) = each(%$env_data)) {
9465: $idf->{$prefix.$key} = $value;
9466: $env{$prefix.$key} = $value;
9467: }
1.462 albertel 9468: }
9469: }
9470:
1.685 ! tempelho 9471: # --- Get the symbolic name of a problem and the url
! 9472: sub get_symb {
! 9473: my ($request,$silent) = @_;
! 9474: (my $url=$env{'form.url'}) =~ s-^http://($ENV{'SERVER_NAME'}|$ENV{'HTTP_HOST'})--;
! 9475: my $symb=($env{'form.symb'} ne '' ? $env{'form.symb'} : (&Apache::lonnet::symbread($url)));
! 9476: if ($symb eq '') {
! 9477: if (!$silent) {
! 9478: $request->print("Unable to handle ambiguous references:$url:.");
! 9479: return ();
! 9480: }
! 9481: }
! 9482: &Apache::lonenc::check_decrypt(\$symb);
! 9483: return ($symb);
! 9484: }
! 9485:
! 9486: # --------------------------------------------------------------Get annotation
! 9487:
! 9488: sub get_annotation {
! 9489: my ($symb,$enc) = @_;
! 9490:
! 9491: my $key = $symb;
! 9492: if (!$enc) {
! 9493: $key =
! 9494: &Apache::lonnet::clutter((&Apache::lonnet::decode_symb($symb))[2]);
! 9495: }
! 9496: my %annotation=&Apache::lonnet::get('nohist_annotations',[$key]);
! 9497: return $annotation{$key};
! 9498: }
! 9499:
! 9500: sub clean_symb {
! 9501: my ($symb) = @_;
! 9502:
! 9503: &Apache::lonenc::check_decrypt(\$symb);
! 9504: my $enc = $env{'request.enc'};
! 9505: delete($env{'request.enc'});
! 9506:
! 9507: return ($symb,$enc);
! 9508: }
1.462 albertel 9509:
1.41 ng 9510: =pod
9511:
9512: =back
9513:
1.112 bowersj2 9514: =cut
1.41 ng 9515:
1.112 bowersj2 9516: 1;
9517: __END__;
1.41 ng 9518:
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