Annotation of loncom/interface/loncommon.pm, revision 1.686
1.10 albertel 1: # The LearningOnline Network with CAPA
1.1 albertel 2: # a pile of common routines
1.10 albertel 3: #
1.686 ! raeburn 4: # $Id: loncommon.pm,v 1.685 2008/09/11 21:05:19 tempelho 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: }
1.686 ! raeburn 2991: return &get_genlanguages(@languages);
! 2992: }
! 2993:
! 2994: sub get_genlanguages {
! 2995: my (@languages) = @_;
1.118 www 2996: # turn "en-ca" into "en-ca,en"
2997: my @genlanguages;
1.356 albertel 2998: foreach my $lang (@languages) {
1.686 ! raeburn 2999: unless ($lang=~/\w/) { next; }
! 3000: push(@genlanguages,$lang);
! 3001: if ($lang=~/(\-|\_)/) {
! 3002: push(@genlanguages,(split(/(\-|\_)/,$lang))[0]);
! 3003: }
1.118 www 3004: }
1.583 albertel 3005: #uniqueify the languages list
3006: my %count;
3007: @genlanguages = map { $count{$_}++ == 0 ? $_ : () } @genlanguages;
1.118 www 3008: return @genlanguages;
1.117 www 3009: }
3010:
1.582 albertel 3011: sub languages {
3012: my ($possible_langs) = @_;
3013: my @preferred_langs = &preferred_languages();
3014: if (!ref($possible_langs)) {
3015: if( wantarray ) {
3016: return @preferred_langs;
3017: } else {
3018: return $preferred_langs[0];
3019: }
3020: }
3021: my %possibilities = map { $_ => 1 } (@$possible_langs);
3022: my @preferred_possibilities;
3023: foreach my $preferred_lang (@preferred_langs) {
3024: if (exists($possibilities{$preferred_lang})) {
3025: push(@preferred_possibilities, $preferred_lang);
3026: }
3027: }
3028: if( wantarray ) {
3029: return @preferred_possibilities;
3030: }
3031: return $preferred_possibilities[0];
3032: }
3033:
1.112 bowersj2 3034: ###############################################################
3035: ## Student Answer Attempts ##
3036: ###############################################################
3037:
3038: =pod
3039:
3040: =head1 Alternate Problem Views
3041:
3042: =over 4
3043:
1.648 raeburn 3044: =item * &get_previous_attempt($symb, $username, $domain, $course,
1.112 bowersj2 3045: $getattempt, $regexp, $gradesub)
3046:
3047: Return string with previous attempt on problem. Arguments:
3048:
3049: =over 4
3050:
3051: =item * $symb: Problem, including path
3052:
3053: =item * $username: username of the desired student
3054:
3055: =item * $domain: domain of the desired student
1.14 harris41 3056:
1.112 bowersj2 3057: =item * $course: Course ID
1.14 harris41 3058:
1.112 bowersj2 3059: =item * $getattempt: Leave blank for all attempts, otherwise put
3060: something
1.14 harris41 3061:
1.112 bowersj2 3062: =item * $regexp: if string matches this regexp, the string will be
3063: sent to $gradesub
1.14 harris41 3064:
1.112 bowersj2 3065: =item * $gradesub: routine that processes the string if it matches $regexp
1.14 harris41 3066:
1.112 bowersj2 3067: =back
1.14 harris41 3068:
1.112 bowersj2 3069: The output string is a table containing all desired attempts, if any.
1.16 harris41 3070:
1.112 bowersj2 3071: =cut
1.1 albertel 3072:
3073: sub get_previous_attempt {
1.43 ng 3074: my ($symb,$username,$domain,$course,$getattempt,$regexp,$gradesub)=@_;
1.1 albertel 3075: my $prevattempts='';
1.43 ng 3076: no strict 'refs';
1.1 albertel 3077: if ($symb) {
1.3 albertel 3078: my (%returnhash)=
3079: &Apache::lonnet::restore($symb,$course,$domain,$username);
1.1 albertel 3080: if ($returnhash{'version'}) {
3081: my %lasthash=();
3082: my $version;
3083: for ($version=1;$version<=$returnhash{'version'};$version++) {
1.356 albertel 3084: foreach my $key (sort(split(/\:/,$returnhash{$version.':keys'}))) {
3085: $lasthash{$key}=$returnhash{$version.':'.$key};
1.19 harris41 3086: }
1.1 albertel 3087: }
1.596 albertel 3088: $prevattempts=&start_data_table().&start_data_table_header_row();
3089: $prevattempts.='<th>'.&mt('History').'</th>';
1.356 albertel 3090: foreach my $key (sort(keys(%lasthash))) {
3091: my ($ign,@parts) = split(/\./,$key);
1.41 ng 3092: if ($#parts > 0) {
1.31 albertel 3093: my $data=$parts[-1];
3094: pop(@parts);
1.596 albertel 3095: $prevattempts.='<th>'.&mt('Part ').join('.',@parts).'<br />'.$data.' </th>';
1.31 albertel 3096: } else {
1.41 ng 3097: if ($#parts == 0) {
3098: $prevattempts.='<th>'.$parts[0].'</th>';
3099: } else {
3100: $prevattempts.='<th>'.$ign.'</th>';
3101: }
1.31 albertel 3102: }
1.16 harris41 3103: }
1.596 albertel 3104: $prevattempts.=&end_data_table_header_row();
1.40 ng 3105: if ($getattempt eq '') {
3106: for ($version=1;$version<=$returnhash{'version'};$version++) {
1.596 albertel 3107: $prevattempts.=&start_data_table_row().
3108: '<td>'.&mt('Transaction [_1]',$version).'</td>';
1.356 albertel 3109: foreach my $key (sort(keys(%lasthash))) {
1.581 albertel 3110: my $value = &format_previous_attempt_value($key,
3111: $returnhash{$version.':'.$key});
3112: $prevattempts.='<td>'.$value.' </td>';
1.40 ng 3113: }
1.596 albertel 3114: $prevattempts.=&end_data_table_row();
1.40 ng 3115: }
1.1 albertel 3116: }
1.596 albertel 3117: $prevattempts.=&start_data_table_row().'<td>'.&mt('Current').'</td>';
1.356 albertel 3118: foreach my $key (sort(keys(%lasthash))) {
1.581 albertel 3119: my $value = &format_previous_attempt_value($key,$lasthash{$key});
1.356 albertel 3120: if ($key =~/$regexp$/ && (defined &$gradesub)) {$value = &$gradesub($value)}
1.40 ng 3121: $prevattempts.='<td>'.$value.' </td>';
1.16 harris41 3122: }
1.596 albertel 3123: $prevattempts.= &end_data_table_row().&end_data_table();
1.1 albertel 3124: } else {
1.596 albertel 3125: $prevattempts=
3126: &start_data_table().&start_data_table_row().
3127: '<td>'.&mt('Nothing submitted - no attempts.').'</td>'.
3128: &end_data_table_row().&end_data_table();
1.1 albertel 3129: }
3130: } else {
1.596 albertel 3131: $prevattempts=
3132: &start_data_table().&start_data_table_row().
3133: '<td>'.&mt('No data.').'</td>'.
3134: &end_data_table_row().&end_data_table();
1.1 albertel 3135: }
1.10 albertel 3136: }
3137:
1.581 albertel 3138: sub format_previous_attempt_value {
3139: my ($key,$value) = @_;
3140: if ($key =~ /timestamp/) {
3141: $value = &Apache::lonlocal::locallocaltime($value);
3142: } elsif (ref($value) eq 'ARRAY') {
3143: $value = '('.join(', ', @{ $value }).')';
3144: } else {
3145: $value = &unescape($value);
3146: }
3147: return $value;
3148: }
3149:
3150:
1.107 albertel 3151: sub relative_to_absolute {
3152: my ($url,$output)=@_;
3153: my $parser=HTML::TokeParser->new(\$output);
3154: my $token;
3155: my $thisdir=$url;
3156: my @rlinks=();
3157: while ($token=$parser->get_token) {
3158: if ($token->[0] eq 'S') {
3159: if ($token->[1] eq 'a') {
3160: if ($token->[2]->{'href'}) {
3161: $rlinks[$#rlinks+1]=$token->[2]->{'href'};
3162: }
3163: } elsif ($token->[1] eq 'img' || $token->[1] eq 'embed' ) {
3164: $rlinks[$#rlinks+1]=$token->[2]->{'src'};
3165: } elsif ($token->[1] eq 'base') {
3166: $thisdir=$token->[2]->{'href'};
3167: }
3168: }
3169: }
3170: $thisdir=~s-/[^/]*$--;
1.356 albertel 3171: foreach my $link (@rlinks) {
3172: unless (($link=~/^http:\/\//i) ||
3173: ($link=~/^\//) ||
3174: ($link=~/^javascript:/i) ||
3175: ($link=~/^mailto:/i) ||
3176: ($link=~/^\#/)) {
3177: my $newlocation=&Apache::lonnet::hreflocation($thisdir,$link);
3178: $output=~s/(\"|\'|\=\s*)\Q$link\E(\"|\'|\s|\>)/$1$newlocation$2/;
1.107 albertel 3179: }
3180: }
3181: # -------------------------------------------------- Deal with Applet codebases
3182: $output=~s/(\<applet[^\>]+)(codebase\=[^\S\>]+)*([^\>]*)\>/$1.($2?$2:' codebase="'.$thisdir.'"').$3.'>'/gei;
3183: return $output;
3184: }
3185:
1.112 bowersj2 3186: =pod
3187:
1.648 raeburn 3188: =item * &get_student_view()
1.112 bowersj2 3189:
3190: show a snapshot of what student was looking at
3191:
3192: =cut
3193:
1.10 albertel 3194: sub get_student_view {
1.186 albertel 3195: my ($symb,$username,$domain,$courseid,$target,$moreenv) = @_;
1.114 www 3196: my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb);
1.186 albertel 3197: my (%form);
1.10 albertel 3198: my @elements=('symb','courseid','domain','username');
3199: foreach my $element (@elements) {
1.186 albertel 3200: $form{'grade_'.$element}=eval '$'.$element #'
1.10 albertel 3201: }
1.186 albertel 3202: if (defined($moreenv)) {
3203: %form=(%form,%{$moreenv});
3204: }
1.236 albertel 3205: if (defined($target)) { $form{'grade_target'} = $target; }
1.107 albertel 3206: $feedurl=&Apache::lonnet::clutter($feedurl);
1.650 www 3207: my ($userview,$response)=&Apache::lonnet::ssi_body($feedurl,%form);
1.11 albertel 3208: $userview=~s/\<body[^\>]*\>//gi;
3209: $userview=~s/\<\/body\>//gi;
3210: $userview=~s/\<html\>//gi;
3211: $userview=~s/\<\/html\>//gi;
3212: $userview=~s/\<head\>//gi;
3213: $userview=~s/\<\/head\>//gi;
3214: $userview=~s/action\s*\=/would_be_action\=/gi;
1.107 albertel 3215: $userview=&relative_to_absolute($feedurl,$userview);
1.650 www 3216: if (wantarray) {
3217: return ($userview,$response);
3218: } else {
3219: return $userview;
3220: }
3221: }
3222:
3223: sub get_student_view_with_retries {
3224: my ($symb,$retries,$username,$domain,$courseid,$target,$moreenv) = @_;
3225:
3226: my $ok = 0; # True if we got a good response.
3227: my $content;
3228: my $response;
3229:
3230: # Try to get the student_view done. within the retries count:
3231:
3232: do {
3233: ($content, $response) = &get_student_view($symb,$username,$domain,$courseid,$target,$moreenv);
3234: $ok = $response->is_success;
3235: if (!$ok) {
3236: &Apache::lonnet::logthis("Failed get_student_view_with_retries on $symb: ".$response->is_success.', '.$response->code.', '.$response->message);
3237: }
3238: $retries--;
3239: } while (!$ok && ($retries > 0));
3240:
3241: if (!$ok) {
3242: $content = ''; # On error return an empty content.
3243: }
1.651 www 3244: if (wantarray) {
3245: return ($content, $response);
3246: } else {
3247: return $content;
3248: }
1.11 albertel 3249: }
3250:
1.112 bowersj2 3251: =pod
3252:
1.648 raeburn 3253: =item * &get_student_answers()
1.112 bowersj2 3254:
3255: show a snapshot of how student was answering problem
3256:
3257: =cut
3258:
1.11 albertel 3259: sub get_student_answers {
1.100 sakharuk 3260: my ($symb,$username,$domain,$courseid,%form) = @_;
1.114 www 3261: my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb);
1.186 albertel 3262: my (%moreenv);
1.11 albertel 3263: my @elements=('symb','courseid','domain','username');
3264: foreach my $element (@elements) {
1.186 albertel 3265: $moreenv{'grade_'.$element}=eval '$'.$element #'
1.10 albertel 3266: }
1.186 albertel 3267: $moreenv{'grade_target'}='answer';
3268: %moreenv=(%form,%moreenv);
1.497 raeburn 3269: $feedurl = &Apache::lonnet::clutter($feedurl);
3270: my $userview=&Apache::lonnet::ssi($feedurl,%moreenv);
1.10 albertel 3271: return $userview;
1.1 albertel 3272: }
1.116 albertel 3273:
3274: =pod
3275:
3276: =item * &submlink()
3277:
1.242 albertel 3278: Inputs: $text $uname $udom $symb $target
1.116 albertel 3279:
3280: Returns: A link to grades.pm such as to see the SUBM view of a student
3281:
3282: =cut
3283:
3284: ###############################################
3285: sub submlink {
1.242 albertel 3286: my ($text,$uname,$udom,$symb,$target)=@_;
1.116 albertel 3287: if (!($uname && $udom)) {
3288: (my $cursymb, my $courseid,$udom,$uname)=
1.463 albertel 3289: &Apache::lonnet::whichuser($symb);
1.116 albertel 3290: if (!$symb) { $symb=$cursymb; }
3291: }
1.254 matthew 3292: if (!$symb) { $symb=&Apache::lonnet::symbread(); }
1.369 www 3293: $symb=&escape($symb);
1.242 albertel 3294: if ($target) { $target="target=\"$target\""; }
3295: return '<a href="/adm/grades?&command=submission&'.
3296: 'symb='.$symb.'&student='.$uname.
3297: '&userdom='.$udom.'" '.$target.'>'.$text.'</a>';
3298: }
3299: ##############################################
3300:
3301: =pod
3302:
3303: =item * &pgrdlink()
3304:
3305: Inputs: $text $uname $udom $symb $target
3306:
3307: Returns: A link to grades.pm such as to see the PGRD view of a student
3308:
3309: =cut
3310:
3311: ###############################################
3312: sub pgrdlink {
3313: my $link=&submlink(@_);
3314: $link=~s/(&command=submission)/$1&showgrading=yes/;
3315: return $link;
3316: }
3317: ##############################################
3318:
3319: =pod
3320:
3321: =item * &pprmlink()
3322:
3323: Inputs: $text $uname $udom $symb $target
3324:
3325: Returns: A link to parmset.pm such as to see the PPRM view of a
1.283 albertel 3326: student and a specific resource
1.242 albertel 3327:
3328: =cut
3329:
3330: ###############################################
3331: sub pprmlink {
3332: my ($text,$uname,$udom,$symb,$target)=@_;
3333: if (!($uname && $udom)) {
3334: (my $cursymb, my $courseid,$udom,$uname)=
1.463 albertel 3335: &Apache::lonnet::whichuser($symb);
1.242 albertel 3336: if (!$symb) { $symb=$cursymb; }
3337: }
1.254 matthew 3338: if (!$symb) { $symb=&Apache::lonnet::symbread(); }
1.369 www 3339: $symb=&escape($symb);
1.242 albertel 3340: if ($target) { $target="target=\"$target\""; }
1.595 albertel 3341: return '<a href="/adm/parmset?command=set&'.
3342: 'symb='.$symb.'&uname='.$uname.
3343: '&udom='.$udom.'" '.$target.'>'.$text.'</a>';
1.116 albertel 3344: }
3345: ##############################################
1.37 matthew 3346:
1.112 bowersj2 3347: =pod
3348:
3349: =back
3350:
3351: =cut
3352:
1.37 matthew 3353: ###############################################
1.51 www 3354:
3355:
3356: sub timehash {
3357: my @ltime=localtime(shift);
3358: return ( 'seconds' => $ltime[0],
3359: 'minutes' => $ltime[1],
3360: 'hours' => $ltime[2],
3361: 'day' => $ltime[3],
3362: 'month' => $ltime[4]+1,
3363: 'year' => $ltime[5]+1900,
3364: 'weekday' => $ltime[6],
3365: 'dayyear' => $ltime[7]+1,
3366: 'dlsav' => $ltime[8] );
3367: }
3368:
1.370 www 3369: sub utc_string {
3370: my ($date)=@_;
1.371 www 3371: return strftime("%Y%m%dT%H%M%SZ",gmtime($date));
1.370 www 3372: }
3373:
1.51 www 3374: sub maketime {
3375: my %th=@_;
3376: return POSIX::mktime(
3377: ($th{'seconds'},$th{'minutes'},$th{'hours'},
1.210 www 3378: $th{'day'},$th{'month'}-1,$th{'year'}-1900,0,0,-1));
1.70 www 3379: }
3380:
3381: #########################################
1.51 www 3382:
3383: sub findallcourses {
1.482 raeburn 3384: my ($roles,$uname,$udom) = @_;
1.355 albertel 3385: my %roles;
3386: if (ref($roles)) { %roles = map { $_ => 1 } @{$roles}; }
1.348 albertel 3387: my %courses;
1.51 www 3388: my $now=time;
1.482 raeburn 3389: if (!defined($uname)) {
3390: $uname = $env{'user.name'};
3391: }
3392: if (!defined($udom)) {
3393: $udom = $env{'user.domain'};
3394: }
3395: if (($uname ne $env{'user.name'}) || ($udom ne $env{'user.domain'})) {
3396: my %roleshash = &Apache::lonnet::dump('roles',$udom,$uname);
3397: if (!%roles) {
3398: %roles = (
3399: cc => 1,
3400: in => 1,
3401: ep => 1,
3402: ta => 1,
3403: cr => 1,
3404: st => 1,
3405: );
3406: }
3407: foreach my $entry (keys(%roleshash)) {
3408: my ($trole,$tend,$tstart) = split(/_/,$roleshash{$entry});
3409: if ($trole =~ /^cr/) {
3410: next if (!exists($roles{$trole}) && !exists($roles{'cr'}));
3411: } else {
3412: next if (!exists($roles{$trole}));
3413: }
3414: if ($tend) {
3415: next if ($tend < $now);
3416: }
3417: if ($tstart) {
3418: next if ($tstart > $now);
3419: }
3420: my ($cdom,$cnum,$sec,$cnumpart,$secpart,$role,$realsec);
3421: (undef,$cdom,$cnumpart,$secpart) = split(/\//,$entry);
3422: if ($secpart eq '') {
3423: ($cnum,$role) = split(/_/,$cnumpart);
3424: $sec = 'none';
3425: $realsec = '';
3426: } else {
3427: $cnum = $cnumpart;
3428: ($sec,$role) = split(/_/,$secpart);
3429: $realsec = $sec;
1.490 raeburn 3430: }
1.482 raeburn 3431: $courses{$cdom.'_'.$cnum}{$sec} = $trole.'/'.$cdom.'/'.$cnum.'/'.$realsec;
3432: }
3433: } else {
3434: foreach my $key (keys(%env)) {
1.483 albertel 3435: if ( $key=~m{^user\.role\.(\w+)\./($match_domain)/($match_courseid)/?(\w*)$} ||
3436: $key=~m{^user\.role\.(cr/$match_domain/$match_username/\w+)\./($match_domain)/($match_courseid)/?(\w*)$}) {
1.482 raeburn 3437: my ($role,$cdom,$cnum,$sec) = ($1,$2,$3,$4);
3438: next if ($role eq 'ca' || $role eq 'aa');
3439: next if (%roles && !exists($roles{$role}));
3440: my ($starttime,$endtime)=split(/\./,$env{$key});
3441: my $active=1;
3442: if ($starttime) {
3443: if ($now<$starttime) { $active=0; }
3444: }
3445: if ($endtime) {
3446: if ($now>$endtime) { $active=0; }
3447: }
3448: if ($active) {
3449: if ($sec eq '') {
3450: $sec = 'none';
3451: }
3452: $courses{$cdom.'_'.$cnum}{$sec} =
3453: $role.'/'.$cdom.'/'.$cnum.'/'.$sec;
1.474 raeburn 3454: }
3455: }
1.51 www 3456: }
3457: }
1.474 raeburn 3458: return %courses;
1.51 www 3459: }
1.37 matthew 3460:
1.54 www 3461: ###############################################
1.474 raeburn 3462:
3463: sub blockcheck {
1.482 raeburn 3464: my ($setters,$activity,$uname,$udom) = @_;
1.490 raeburn 3465:
3466: if (!defined($udom)) {
3467: $udom = $env{'user.domain'};
3468: }
3469: if (!defined($uname)) {
3470: $uname = $env{'user.name'};
3471: }
3472:
3473: # If uname and udom are for a course, check for blocks in the course.
3474:
3475: if (&Apache::lonnet::is_course($udom,$uname)) {
3476: my %records = &Apache::lonnet::dump('comm_block',$udom,$uname);
1.502 raeburn 3477: my ($startblock,$endblock)=&get_blocks($setters,$activity,$udom,$uname);
1.490 raeburn 3478: return ($startblock,$endblock);
3479: }
1.474 raeburn 3480:
1.502 raeburn 3481: my $startblock = 0;
3482: my $endblock = 0;
1.482 raeburn 3483: my %live_courses = &findallcourses(undef,$uname,$udom);
1.474 raeburn 3484:
1.490 raeburn 3485: # If uname is for a user, and activity is course-specific, i.e.,
3486: # boards, chat or groups, check for blocking in current course only.
1.474 raeburn 3487:
1.490 raeburn 3488: if (($activity eq 'boards' || $activity eq 'chat' ||
3489: $activity eq 'groups') && ($env{'request.course.id'})) {
3490: foreach my $key (keys(%live_courses)) {
3491: if ($key ne $env{'request.course.id'}) {
3492: delete($live_courses{$key});
3493: }
3494: }
3495: }
3496:
3497: my $otheruser = 0;
3498: my %own_courses;
3499: if ((($uname ne $env{'user.name'})) || ($udom ne $env{'user.domain'})) {
3500: # Resource belongs to user other than current user.
3501: $otheruser = 1;
3502: # Gather courses for current user
3503: %own_courses =
3504: &findallcourses(undef,$env{'user.name'},$env{'user.domain'});
3505: }
3506:
3507: # Gather active course roles - course coordinator, instructor,
3508: # exam proctor, ta, student, or custom role.
1.474 raeburn 3509:
3510: foreach my $course (keys(%live_courses)) {
1.482 raeburn 3511: my ($cdom,$cnum);
3512: if ((defined($env{'course.'.$course.'.domain'})) && (defined($env{'course.'.$course.'.num'}))) {
3513: $cdom = $env{'course.'.$course.'.domain'};
3514: $cnum = $env{'course.'.$course.'.num'};
3515: } else {
1.490 raeburn 3516: ($cdom,$cnum) = split(/_/,$course);
1.482 raeburn 3517: }
3518: my $no_ownblock = 0;
3519: my $no_userblock = 0;
1.533 raeburn 3520: if ($otheruser && $activity ne 'com') {
1.490 raeburn 3521: # Check if current user has 'evb' priv for this
3522: if (defined($own_courses{$course})) {
3523: foreach my $sec (keys(%{$own_courses{$course}})) {
3524: my $checkrole = 'cm./'.$cdom.'/'.$cnum;
3525: if ($sec ne 'none') {
3526: $checkrole .= '/'.$sec;
3527: }
3528: if (&Apache::lonnet::allowed('evb',undef,undef,$checkrole)) {
3529: $no_ownblock = 1;
3530: last;
3531: }
3532: }
3533: }
3534: # if they have 'evb' priv and are currently not playing student
3535: next if (($no_ownblock) &&
3536: ($env{'request.role'} !~ m{^st\./$cdom/$cnum}));
3537: }
1.474 raeburn 3538: foreach my $sec (keys(%{$live_courses{$course}})) {
1.482 raeburn 3539: my $checkrole = 'cm./'.$cdom.'/'.$cnum;
1.474 raeburn 3540: if ($sec ne 'none') {
1.482 raeburn 3541: $checkrole .= '/'.$sec;
1.474 raeburn 3542: }
1.490 raeburn 3543: if ($otheruser) {
3544: # Resource belongs to user other than current user.
3545: # Assemble privs for that user, and check for 'evb' priv.
1.482 raeburn 3546: my ($trole,$tdom,$tnum,$tsec);
3547: my $entry = $live_courses{$course}{$sec};
3548: if ($entry =~ /^cr/) {
3549: ($trole,$tdom,$tnum,$tsec) =
3550: ($entry =~ m|^(cr/$match_domain/$match_username/\w+)\./($match_domain)/($match_username)/?(\w*)$|);
3551: } else {
3552: ($trole,$tdom,$tnum,$tsec) = split(/\//,$entry);
3553: }
3554: my ($spec,$area,$trest,%allroles,%userroles);
3555: $area = '/'.$tdom.'/'.$tnum;
3556: $trest = $tnum;
3557: if ($tsec ne '') {
3558: $area .= '/'.$tsec;
3559: $trest .= '/'.$tsec;
3560: }
3561: $spec = $trole.'.'.$area;
3562: if ($trole =~ /^cr/) {
3563: &Apache::lonnet::custom_roleprivs(\%allroles,$trole,
3564: $tdom,$spec,$trest,$area);
3565: } else {
3566: &Apache::lonnet::standard_roleprivs(\%allroles,$trole,
3567: $tdom,$spec,$trest,$area);
3568: }
3569: my ($author,$adv) = &Apache::lonnet::set_userprivs(\%userroles,\%allroles);
1.486 raeburn 3570: if ($userroles{'user.priv.'.$checkrole} =~ /evb\&([^\:]*)/) {
3571: if ($1) {
3572: $no_userblock = 1;
3573: last;
3574: }
3575: }
1.490 raeburn 3576: } else {
3577: # Resource belongs to current user
3578: # Check for 'evb' priv via lonnet::allowed().
1.482 raeburn 3579: if (&Apache::lonnet::allowed('evb',undef,undef,$checkrole)) {
3580: $no_ownblock = 1;
3581: last;
3582: }
1.474 raeburn 3583: }
3584: }
3585: # if they have the evb priv and are currently not playing student
1.482 raeburn 3586: next if (($no_ownblock) &&
1.491 albertel 3587: ($env{'request.role'} !~ m{^st\./\Q$cdom\E/\Q$cnum\E}));
1.482 raeburn 3588: next if ($no_userblock);
1.474 raeburn 3589:
1.490 raeburn 3590: # Retrieve blocking times and identity of blocker for course
3591: # of specified user, unless user has 'evb' privilege.
1.502 raeburn 3592:
3593: my ($start,$end)=&get_blocks($setters,$activity,$cdom,$cnum);
3594: if (($start != 0) &&
3595: (($startblock == 0) || ($startblock > $start))) {
3596: $startblock = $start;
3597: }
3598: if (($end != 0) &&
3599: (($endblock == 0) || ($endblock < $end))) {
3600: $endblock = $end;
3601: }
1.490 raeburn 3602: }
3603: return ($startblock,$endblock);
3604: }
3605:
3606: sub get_blocks {
3607: my ($setters,$activity,$cdom,$cnum) = @_;
3608: my $startblock = 0;
3609: my $endblock = 0;
3610: my $course = $cdom.'_'.$cnum;
3611: $setters->{$course} = {};
3612: $setters->{$course}{'staff'} = [];
3613: $setters->{$course}{'times'} = [];
3614: my %records = &Apache::lonnet::dump('comm_block',$cdom,$cnum);
3615: foreach my $record (keys(%records)) {
3616: my ($start,$end) = ($record =~ m/^(\d+)____(\d+)$/);
3617: if ($start <= time && $end >= time) {
3618: my ($staff_name,$staff_dom,$title,$blocks) =
3619: &parse_block_record($records{$record});
3620: if ($blocks->{$activity} eq 'on') {
3621: push(@{$$setters{$course}{'staff'}},[$staff_name,$staff_dom]);
3622: push(@{$$setters{$course}{'times'}}, [$start,$end]);
1.491 albertel 3623: if ( ($startblock == 0) || ($startblock > $start) ) {
3624: $startblock = $start;
1.490 raeburn 3625: }
1.491 albertel 3626: if ( ($endblock == 0) || ($endblock < $end) ) {
3627: $endblock = $end;
1.474 raeburn 3628: }
3629: }
3630: }
3631: }
3632: return ($startblock,$endblock);
3633: }
3634:
3635: sub parse_block_record {
3636: my ($record) = @_;
3637: my ($setuname,$setudom,$title,$blocks);
3638: if (ref($record) eq 'HASH') {
3639: ($setuname,$setudom) = split(/:/,$record->{'setter'});
3640: $title = &unescape($record->{'event'});
3641: $blocks = $record->{'blocks'};
3642: } else {
3643: my @data = split(/:/,$record,3);
3644: if (scalar(@data) eq 2) {
3645: $title = $data[1];
3646: ($setuname,$setudom) = split(/@/,$data[0]);
3647: } else {
3648: ($setuname,$setudom,$title) = @data;
3649: }
3650: $blocks = { 'com' => 'on' };
3651: }
3652: return ($setuname,$setudom,$title,$blocks);
3653: }
3654:
3655: sub build_block_table {
3656: my ($startblock,$endblock,$setters) = @_;
3657: my %lt = &Apache::lonlocal::texthash(
3658: 'cacb' => 'Currently active communication blocks',
3659: 'cour' => 'Course',
3660: 'dura' => 'Duration',
3661: 'blse' => 'Block set by'
3662: );
3663: my $output;
1.476 raeburn 3664: $output = '<br />'.$lt{'cacb'}.':<br />';
1.474 raeburn 3665: $output .= &start_data_table();
3666: $output .= '
3667: <tr>
3668: <th>'.$lt{'cour'}.'</th>
3669: <th>'.$lt{'dura'}.'</th>
3670: <th>'.$lt{'blse'}.'</th>
3671: </tr>
3672: ';
3673: foreach my $course (keys(%{$setters})) {
3674: my %courseinfo=&Apache::lonnet::coursedescription($course);
3675: for (my $i=0; $i<@{$$setters{$course}{staff}}; $i++) {
3676: my ($uname,$udom) = @{$$setters{$course}{staff}[$i]};
1.490 raeburn 3677: my $fullname = &plainname($uname,$udom);
3678: if (defined($env{'user.name'}) && defined($env{'user.domain'})
3679: && $env{'user.name'} ne 'public'
3680: && $env{'user.domain'} ne 'public') {
3681: $fullname = &aboutmewrapper($fullname,$uname,$udom);
3682: }
1.474 raeburn 3683: my ($openblock,$closeblock) = @{$$setters{$course}{times}[$i]};
3684: $openblock = &Apache::lonlocal::locallocaltime($openblock);
3685: $closeblock= &Apache::lonlocal::locallocaltime($closeblock);
3686: $output .= &Apache::loncommon::start_data_table_row().
3687: '<td>'.$courseinfo{'description'}.'</td>'.
3688: '<td>'.$openblock.' to '.$closeblock.'</td>'.
1.490 raeburn 3689: '<td>'.$fullname.'</td>'.
1.474 raeburn 3690: &Apache::loncommon::end_data_table_row();
3691: }
3692: }
3693: $output .= &end_data_table();
3694: }
3695:
1.490 raeburn 3696: sub blocking_status {
3697: my ($activity,$uname,$udom) = @_;
3698: my %setters;
3699: my ($blocked,$output,$ownitem,$is_course);
3700: my ($startblock,$endblock)=&blockcheck(\%setters,$activity,$uname,$udom);
3701: if ($startblock && $endblock) {
3702: $blocked = 1;
3703: if (wantarray) {
3704: my $category;
3705: if ($activity eq 'boards') {
3706: $category = 'Discussion posts in this course';
3707: } elsif ($activity eq 'blogs') {
3708: $category = 'Blogs';
3709: } elsif ($activity eq 'port') {
3710: if (defined($uname) && defined($udom)) {
3711: if ($uname eq $env{'user.name'} &&
3712: $udom eq $env{'user.domain'}) {
3713: $ownitem = 1;
3714: }
3715: }
3716: $is_course = &Apache::lonnet::is_course($udom,$uname);
3717: if ($ownitem) {
3718: $category = 'Your portfolio files';
3719: } elsif ($is_course) {
3720: my $coursedesc;
3721: foreach my $course (keys(%setters)) {
3722: my %courseinfo =
3723: &Apache::lonnet::coursedescription($course);
3724: $coursedesc = $courseinfo{'description'};
3725: }
3726: $category = "Group files in the course '$coursedesc'";
3727: } else {
3728: $category = 'Portfolio files belonging to ';
3729: if ($env{'user.name'} eq 'public' &&
3730: $env{'user.domain'} eq 'public') {
3731: $category .= &plainname($uname,$udom);
3732: } else {
3733: $category .= &aboutmewrapper(&plainname($uname,$udom),$uname,$udom);
3734: }
3735: }
3736: } elsif ($activity eq 'groups') {
3737: $category = 'Groups in this course';
3738: }
3739: my $showstart = &Apache::lonlocal::locallocaltime($startblock);
3740: my $showend = &Apache::lonlocal::locallocaltime($endblock);
3741: $output = '<br />'.&mt('[_1] will be inaccessible between [_2] and [_3] because communication is being blocked.',$category,$showstart,$showend).'<br />';
3742: if (!($activity eq 'port' && !($ownitem) && !($is_course))) {
3743: $output .= &build_block_table($startblock,$endblock,\%setters);
3744: }
3745: }
3746: }
3747: if (wantarray) {
3748: return ($blocked,$output);
3749: } else {
3750: return $blocked;
3751: }
3752: }
3753:
1.60 matthew 3754: ###############################################
3755:
1.682 raeburn 3756: sub check_ip_acc {
3757: my ($acc)=@_;
3758: &Apache::lonxml::debug("acc is $acc");
3759: if (!defined($acc) || $acc =~ /^\s*$/ || $acc =~/^\s*no\s*$/i) {
3760: return 1;
3761: }
3762: my $allowed=0;
3763: my $ip=$env{'request.host'} || $ENV{'REMOTE_ADDR'};
3764:
3765: my $name;
3766: foreach my $pattern (split(',',$acc)) {
3767: $pattern =~ s/^\s*//;
3768: $pattern =~ s/\s*$//;
3769: if ($pattern =~ /\*$/) {
3770: #35.8.*
3771: $pattern=~s/\*//;
3772: if ($ip =~ /^\Q$pattern\E/) { $allowed=1; }
3773: } elsif ($pattern =~ /(\d+\.\d+\.\d+)\.\[(\d+)-(\d+)\]$/) {
3774: #35.8.3.[34-56]
3775: my $low=$2;
3776: my $high=$3;
3777: $pattern=$1;
3778: if ($ip =~ /^\Q$pattern\E/) {
3779: my $last=(split(/\./,$ip))[3];
3780: if ($last <=$high && $last >=$low) { $allowed=1; }
3781: }
3782: } elsif ($pattern =~ /^\*/) {
3783: #*.msu.edu
3784: $pattern=~s/\*//;
3785: if (!defined($name)) {
3786: use Socket;
3787: my $netaddr=inet_aton($ip);
3788: ($name)=gethostbyaddr($netaddr,AF_INET);
3789: }
3790: if ($name =~ /\Q$pattern\E$/i) { $allowed=1; }
3791: } elsif ($pattern =~ /\d+\.\d+\.\d+\.\d+/) {
3792: #127.0.0.1
3793: if ($ip =~ /^\Q$pattern\E/) { $allowed=1; }
3794: } else {
3795: #some.name.com
3796: if (!defined($name)) {
3797: use Socket;
3798: my $netaddr=inet_aton($ip);
3799: ($name)=gethostbyaddr($netaddr,AF_INET);
3800: }
3801: if ($name =~ /\Q$pattern\E$/i) { $allowed=1; }
3802: }
3803: if ($allowed) { last; }
3804: }
3805: return $allowed;
3806: }
3807:
3808: ###############################################
3809:
1.60 matthew 3810: =pod
3811:
1.112 bowersj2 3812: =head1 Domain Template Functions
3813:
3814: =over 4
3815:
3816: =item * &determinedomain()
1.60 matthew 3817:
3818: Inputs: $domain (usually will be undef)
3819:
1.63 www 3820: Returns: Determines which domain should be used for designs
1.60 matthew 3821:
3822: =cut
1.54 www 3823:
1.60 matthew 3824: ###############################################
1.63 www 3825: sub determinedomain {
3826: my $domain=shift;
1.531 albertel 3827: if (! $domain) {
1.60 matthew 3828: # Determine domain if we have not been given one
3829: $domain = $Apache::lonnet::perlvar{'lonDefDomain'};
1.258 albertel 3830: if ($env{'user.domain'}) { $domain=$env{'user.domain'}; }
3831: if ($env{'request.role.domain'}) {
3832: $domain=$env{'request.role.domain'};
1.60 matthew 3833: }
3834: }
1.63 www 3835: return $domain;
3836: }
3837: ###############################################
1.517 raeburn 3838:
1.518 albertel 3839: sub devalidate_domconfig_cache {
3840: my ($udom)=@_;
3841: &Apache::lonnet::devalidate_cache_new('domainconfig',$udom);
3842: }
3843:
3844: # ---------------------- Get domain configuration for a domain
3845: sub get_domainconf {
3846: my ($udom) = @_;
3847: my $cachetime=1800;
3848: my ($result,$cached)=&Apache::lonnet::is_cached_new('domainconfig',$udom);
3849: if (defined($cached)) { return %{$result}; }
3850:
3851: my %domconfig = &Apache::lonnet::get_dom('configuration',
3852: ['login','rolecolors'],$udom);
1.632 raeburn 3853: my (%designhash,%legacy);
1.518 albertel 3854: if (keys(%domconfig) > 0) {
3855: if (ref($domconfig{'login'}) eq 'HASH') {
1.632 raeburn 3856: if (keys(%{$domconfig{'login'}})) {
3857: foreach my $key (keys(%{$domconfig{'login'}})) {
3858: $designhash{$udom.'.login.'.$key}=$domconfig{'login'}{$key};
3859: }
3860: } else {
3861: $legacy{'login'} = 1;
1.518 albertel 3862: }
1.632 raeburn 3863: } else {
3864: $legacy{'login'} = 1;
1.518 albertel 3865: }
3866: if (ref($domconfig{'rolecolors'}) eq 'HASH') {
1.632 raeburn 3867: if (keys(%{$domconfig{'rolecolors'}})) {
3868: foreach my $role (keys(%{$domconfig{'rolecolors'}})) {
3869: if (ref($domconfig{'rolecolors'}{$role}) eq 'HASH') {
3870: foreach my $item (keys(%{$domconfig{'rolecolors'}{$role}})) {
3871: $designhash{$udom.'.'.$role.'.'.$item}=$domconfig{'rolecolors'}{$role}{$item};
3872: }
1.518 albertel 3873: }
3874: }
1.632 raeburn 3875: } else {
3876: $legacy{'rolecolors'} = 1;
1.518 albertel 3877: }
1.632 raeburn 3878: } else {
3879: $legacy{'rolecolors'} = 1;
1.518 albertel 3880: }
1.632 raeburn 3881: if (keys(%legacy) > 0) {
3882: my %legacyhash = &get_legacy_domconf($udom);
3883: foreach my $item (keys(%legacyhash)) {
3884: if ($item =~ /^\Q$udom\E\.login/) {
3885: if ($legacy{'login'}) {
3886: $designhash{$item} = $legacyhash{$item};
3887: }
3888: } else {
3889: if ($legacy{'rolecolors'}) {
3890: $designhash{$item} = $legacyhash{$item};
3891: }
1.518 albertel 3892: }
3893: }
3894: }
1.632 raeburn 3895: } else {
3896: %designhash = &get_legacy_domconf($udom);
1.518 albertel 3897: }
3898: &Apache::lonnet::do_cache_new('domainconfig',$udom,\%designhash,
3899: $cachetime);
3900: return %designhash;
3901: }
3902:
1.632 raeburn 3903: sub get_legacy_domconf {
3904: my ($udom) = @_;
3905: my %legacyhash;
3906: my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors';
3907: my $designfile = $designdir.'/'.$udom.'.tab';
3908: if (-e $designfile) {
3909: if ( open (my $fh,"<$designfile") ) {
3910: while (my $line = <$fh>) {
3911: next if ($line =~ /^\#/);
3912: chomp($line);
3913: my ($key,$val)=(split(/\=/,$line));
3914: if ($val) { $legacyhash{$udom.'.'.$key}=$val; }
3915: }
3916: close($fh);
3917: }
3918: }
3919: if (-e '/home/httpd/html/adm/lonDomLogos/'.$udom.'.gif') {
3920: $legacyhash{$udom.'.login.domlogo'} = "/adm/lonDomLogos/$udom.gif";
3921: }
3922: return %legacyhash;
3923: }
3924:
1.63 www 3925: =pod
3926:
1.112 bowersj2 3927: =item * &domainlogo()
1.63 www 3928:
3929: Inputs: $domain (usually will be undef)
3930:
3931: Returns: A link to a domain logo, if the domain logo exists.
3932: If the domain logo does not exist, a description of the domain.
3933:
3934: =cut
1.112 bowersj2 3935:
1.63 www 3936: ###############################################
3937: sub domainlogo {
1.517 raeburn 3938: my $domain = &determinedomain(shift);
1.518 albertel 3939: my %designhash = &get_domainconf($domain);
1.517 raeburn 3940: # See if there is a logo
3941: if ($designhash{$domain.'.login.domlogo'} ne '') {
1.519 raeburn 3942: my $imgsrc = $designhash{$domain.'.login.domlogo'};
1.538 albertel 3943: if ($imgsrc =~ m{^/(adm|res)/}) {
3944: if ($imgsrc =~ m{^/res/}) {
3945: my $local_name = &Apache::lonnet::filelocation('',$imgsrc);
3946: &Apache::lonnet::repcopy($local_name);
3947: }
3948: $imgsrc = &lonhttpdurl($imgsrc);
1.519 raeburn 3949: }
3950: return '<img src="'.$imgsrc.'" alt="'.$domain.'" />';
1.514 albertel 3951: } elsif (defined(&Apache::lonnet::domain($domain,'description'))) {
3952: return &Apache::lonnet::domain($domain,'description');
1.59 www 3953: } else {
1.60 matthew 3954: return '';
1.59 www 3955: }
3956: }
1.63 www 3957: ##############################################
3958:
3959: =pod
3960:
1.112 bowersj2 3961: =item * &designparm()
1.63 www 3962:
3963: Inputs: $which parameter; $domain (usually will be undef)
3964:
3965: Returns: value of designparamter $which
3966:
3967: =cut
1.112 bowersj2 3968:
1.397 albertel 3969:
1.400 albertel 3970: ##############################################
1.397 albertel 3971: sub designparm {
3972: my ($which,$domain)=@_;
1.258 albertel 3973: if ($env{'browser.blackwhite'} eq 'on') {
1.635 raeburn 3974: if ($which=~/\.(font|alink|vlink|link|textcol)$/) {
1.110 www 3975: return '#000000';
3976: }
1.635 raeburn 3977: if ($which=~/\.(pgbg|sidebg|bgcol)$/) {
1.110 www 3978: return '#FFFFFF';
3979: }
3980: if ($which=~/\.tabbg$/) {
3981: return '#CCCCCC';
3982: }
3983: }
1.397 albertel 3984: if (exists($env{'environment.color.'.$which})) {
1.258 albertel 3985: return $env{'environment.color.'.$which};
1.96 www 3986: }
1.63 www 3987: $domain=&determinedomain($domain);
1.518 albertel 3988: my %domdesign = &get_domainconf($domain);
1.520 raeburn 3989: my $output;
1.517 raeburn 3990: if ($domdesign{$domain.'.'.$which} ne '') {
1.520 raeburn 3991: $output = $domdesign{$domain.'.'.$which};
1.63 www 3992: } else {
1.520 raeburn 3993: $output = $defaultdesign{$which};
3994: }
3995: if (($which =~ /^(student|coordinator|author|admin)\.img$/) ||
1.635 raeburn 3996: ($which =~ /login\.(img|logo|domlogo|login)/)) {
1.538 albertel 3997: if ($output =~ m{^/(adm|res)/}) {
3998: if ($output =~ m{^/res/}) {
3999: my $local_name = &Apache::lonnet::filelocation('',$output);
4000: &Apache::lonnet::repcopy($local_name);
4001: }
1.520 raeburn 4002: $output = &lonhttpdurl($output);
4003: }
1.63 www 4004: }
1.520 raeburn 4005: return $output;
1.63 www 4006: }
1.59 www 4007:
1.60 matthew 4008: ###############################################
4009: ###############################################
4010:
4011: =pod
4012:
1.112 bowersj2 4013: =back
4014:
1.549 albertel 4015: =head1 HTML Helpers
1.112 bowersj2 4016:
4017: =over 4
4018:
4019: =item * &bodytag()
1.60 matthew 4020:
4021: Returns a uniform header for LON-CAPA web pages.
4022:
4023: Inputs:
4024:
1.112 bowersj2 4025: =over 4
4026:
4027: =item * $title, A title to be displayed on the page.
4028:
4029: =item * $function, the current role (can be undef).
4030:
4031: =item * $addentries, extra parameters for the <body> tag.
4032:
4033: =item * $bodyonly, if defined, only return the <body> tag.
4034:
4035: =item * $domain, if defined, force a given domain.
4036:
4037: =item * $forcereg, if page should register as content page (relevant for
1.86 www 4038: text interface only)
1.60 matthew 4039:
1.326 albertel 4040: =item * $customtitle, alternate text to use instead of $title
4041: in the title box that appears, this text
4042: is not auto translated like the $title is
1.309 albertel 4043:
4044: =item * $notopbar, if true, keep the 'what is this' info but remove the
4045: navigational links
1.317 albertel 4046:
1.338 albertel 4047: =item * $bgcolor, used to override the bgcolor on a webpage to a specific value
4048:
4049: =item * $notitle, if true keep the nav controls, but remove the title bar
4050:
1.361 albertel 4051: =item * $no_inline_link, if true and in remote mode, don't show the
4052: 'Switch To Inline Menu' link
4053:
1.460 albertel 4054: =item * $args, optional argument valid values are
4055: no_auto_mt_title -> prevents &mt()ing the title arg
1.562 albertel 4056: inherit_jsmath -> when creating popup window in a page,
4057: should it have jsmath forced on by the
4058: current page
1.460 albertel 4059:
1.112 bowersj2 4060: =back
4061:
1.60 matthew 4062: Returns: A uniform header for LON-CAPA web pages.
4063: If $bodyonly is nonzero, a string containing a <body> tag will be returned.
4064: If $bodyonly is undef or zero, an html string containing a <body> tag and
4065: other decorations will be returned.
4066:
4067: =cut
4068:
1.54 www 4069: sub bodytag {
1.309 albertel 4070: my ($title,$function,$addentries,$bodyonly,$domain,$forcereg,$customtitle,
1.460 albertel 4071: $notopbar,$bgcolor,$notitle,$no_inline_link,$args)=@_;
1.339 albertel 4072:
1.460 albertel 4073: if (!$args->{'no_auto_mt_title'}) { $title = &mt($title); }
1.339 albertel 4074:
1.183 matthew 4075: $function = &get_users_function() if (!$function);
1.339 albertel 4076: my $img = &designparm($function.'.img',$domain);
4077: my $font = &designparm($function.'.font',$domain);
4078: my $pgbg = $bgcolor || &designparm($function.'.pgbg',$domain);
4079:
4080: my %design = ( 'style' => 'margin-top: 0px',
1.535 albertel 4081: 'bgcolor' => $pgbg,
1.339 albertel 4082: 'text' => $font,
4083: 'alink' => &designparm($function.'.alink',$domain),
4084: 'vlink' => &designparm($function.'.vlink',$domain),
4085: 'link' => &designparm($function.'.link',$domain),);
1.438 albertel 4086: @design{keys(%$addentries)} = @$addentries{keys(%$addentries)};
1.339 albertel 4087:
1.63 www 4088: # role and realm
1.378 raeburn 4089: my ($role,$realm) = split(/\./,$env{'request.role'},2);
4090: if ($role eq 'ca') {
1.479 albertel 4091: my ($rdom,$rname) = ($realm =~ m{^/($match_domain)/($match_username)$});
1.500 albertel 4092: $realm = &plainname($rname,$rdom);
1.378 raeburn 4093: }
1.55 www 4094: # realm
1.258 albertel 4095: if ($env{'request.course.id'}) {
1.378 raeburn 4096: if ($env{'request.role'} !~ /^cr/) {
4097: $role = &Apache::lonnet::plaintext($role,&course_type());
4098: }
1.359 albertel 4099: $realm = $env{'course.'.$env{'request.course.id'}.'.description'};
1.378 raeburn 4100: } else {
4101: $role = &Apache::lonnet::plaintext($role);
1.54 www 4102: }
1.433 albertel 4103:
1.359 albertel 4104: if (!$realm) { $realm=' '; }
1.55 www 4105: # Set messages
1.60 matthew 4106: my $messages=&domainlogo($domain);
1.330 albertel 4107:
1.438 albertel 4108: my $extra_body_attr = &make_attr_string($forcereg,\%design);
1.329 albertel 4109:
1.101 www 4110: # construct main body tag
1.359 albertel 4111: my $bodytag = "<body $extra_body_attr>".
1.562 albertel 4112: &Apache::lontexconvert::init_math_support($args->{'inherit_jsmath'});
1.252 albertel 4113:
1.530 albertel 4114: if ($bodyonly) {
1.60 matthew 4115: return $bodytag;
1.258 albertel 4116: } elsif ($env{'browser.interface'} eq 'textual') {
1.95 www 4117: # Accessibility
1.224 raeburn 4118:
1.337 albertel 4119: $bodytag.=&Apache::lonmenu::menubuttons($forcereg,$forcereg);
1.338 albertel 4120: if (!$notitle) {
1.337 albertel 4121: $bodytag.='<h1>LON-CAPA: '.$title.'</h1>';
4122: }
4123: return $bodytag;
1.359 albertel 4124: }
4125:
1.410 albertel 4126: my $name = &plainname($env{'user.name'},$env{'user.domain'});
1.433 albertel 4127: if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
4128: undef($role);
1.434 albertel 4129: } else {
4130: $name = &aboutmewrapper($name,$env{'user.name'},$env{'user.domain'});
1.433 albertel 4131: }
1.359 albertel 4132:
4133: my $roleinfo=(<<ENDROLE);
4134: <td class="LC_title_bar_who">
4135: <div class="LC_title_bar_name">
1.410 albertel 4136: $name
1.361 albertel 4137:
1.359 albertel 4138: </div>
4139: <div class="LC_title_bar_role">
1.361 albertel 4140: $role
1.359 albertel 4141: </div>
4142: <div class="LC_title_bar_realm">
1.361 albertel 4143: $realm
1.359 albertel 4144: </div>
1.206 albertel 4145: </td>
4146: ENDROLE
1.235 raeburn 4147:
1.359 albertel 4148: my $titleinfo = '<span class="LC_title_bar_title">'.$title.'</span>';
4149: if ($customtitle) {
4150: $titleinfo = $customtitle;
4151: }
4152: #
4153: # Extra info if you are the DC
4154: my $dc_info = '';
4155: if ($env{'user.adv'} && exists($env{'user.role.dc./'.
4156: $env{'course.'.$env{'request.course.id'}.
4157: '.domain'}.'/'})) {
4158: my $cid = $env{'request.course.id'};
4159: $dc_info.= $cid.' '.$env{'course.'.$cid.'.internal.coursecode'};
1.380 www 4160: $dc_info =~ s/\s+$//;
1.359 albertel 4161: $dc_info = '('.$dc_info.')';
4162: }
4163:
1.644 www 4164: if (($env{'environment.remote'} eq 'off') || ($args->{'suppress_header_logos'})) {
1.359 albertel 4165: # No Remote
1.258 albertel 4166: if ($env{'request.state'} eq 'construct') {
1.359 albertel 4167: $forcereg=1;
4168: }
4169:
4170: if (!$customtitle && $env{'request.state'} eq 'construct') {
4171: # this is for resources; directories have customtitle, and crumbs
4172: # and select recent are created in lonpubdir.pm
1.229 albertel 4173: my ($uname,$thisdisfn)=
1.258 albertel 4174: ($env{'request.filename'} =~ m|^/home/([^/]+)/public_html/(.*)|);
1.229 albertel 4175: my $formaction='/priv/'.$uname.'/'.$thisdisfn;
4176: $formaction=~s/\/+/\//g;
4177:
1.359 albertel 4178: my $parentpath = '';
4179: my $lastitem = '';
4180: if ($thisdisfn =~ m-(.+/)([^/]*)$-) {
4181: $parentpath = $1;
4182: $lastitem = $2;
4183: } else {
4184: $lastitem = $thisdisfn;
4185: }
4186: $titleinfo =
1.640 bisitz 4187: &Apache::loncommon::help_open_menu('','',3,'Authoring')
4188: .'<b>'.&mt('Construction Space').'</b>: '
4189: .'<form name="dirs" method="post" action="'.$formaction
1.359 albertel 4190: .'" target="_top"><tt><b>'
4191: .&Apache::lonhtmlcommon::crumbs($uname.'/'.$parentpath,'_top','/priv','','+1',1)."<font size=\"+1\">$lastitem</font></b></tt><br />"
4192: .&Apache::lonhtmlcommon::select_recent('construct','recent','this.form.action=this.form.recent.value;this.form.submit()')
4193: .'</form>'
4194: .&Apache::lonmenu::constspaceform();
1.235 raeburn 4195: }
1.359 albertel 4196:
1.337 albertel 4197: my $titletable;
1.338 albertel 4198: if (!$notitle) {
1.337 albertel 4199: $titletable =
1.359 albertel 4200: '<table id="LC_title_bar">'.
4201: "<tr><td> $titleinfo $dc_info</td>".$roleinfo.
4202: '</tr></table>';
1.337 albertel 4203: }
1.359 albertel 4204: if ($notopbar) {
4205: $bodytag .= $titletable;
4206: } else {
4207: if ($env{'request.state'} eq 'construct') {
1.337 albertel 4208: $bodytag .= &Apache::lonmenu::menubuttons($forcereg,$forcereg,
4209: $titletable);
1.272 raeburn 4210: } else {
1.336 albertel 4211: $bodytag .= &Apache::lonmenu::menubuttons($forcereg,$forcereg).
1.359 albertel 4212: $titletable;
1.272 raeburn 4213: }
1.235 raeburn 4214: }
4215: return $bodytag;
1.94 www 4216: }
1.95 www 4217:
1.93 www 4218: #
1.95 www 4219: # Top frame rendering, Remote is up
1.93 www 4220: #
1.359 albertel 4221:
1.517 raeburn 4222: my $imgsrc = $img;
4223: if ($img =~ /^\/adm/) {
1.575 albertel 4224: $imgsrc = &lonhttpdurl($img);
1.517 raeburn 4225: }
4226: my $upperleft='<img src="'.$imgsrc.'" alt="'.$function.'" />';
1.359 albertel 4227:
1.305 www 4228: # Explicit link to get inline menu
1.361 albertel 4229: my $menu= ($no_inline_link?''
4230: :'<br /><a href="/adm/remote?action=collapse">'.&mt('Switch to Inline Menu Mode').'</a>');
1.245 matthew 4231: #
1.338 albertel 4232: if ($notitle) {
1.337 albertel 4233: return $bodytag;
4234: }
1.94 www 4235: return(<<ENDBODY);
1.60 matthew 4236: $bodytag
1.359 albertel 4237: <table id="LC_title_bar" class="LC_with_remote">
1.368 albertel 4238: <tr><td class="LC_title_bar_role_logo">$upperleft</td>
1.359 albertel 4239: <td class="LC_title_bar_domain_logo">$messages </td>
1.54 www 4240: </tr>
1.359 albertel 4241: <tr><td>$titleinfo $dc_info $menu</td>
4242: $roleinfo
1.368 albertel 4243: </tr>
1.356 albertel 4244: </table>
1.54 www 4245: ENDBODY
1.182 matthew 4246: }
4247:
1.330 albertel 4248: sub make_attr_string {
4249: my ($register,$attr_ref) = @_;
4250:
4251: if ($attr_ref && !ref($attr_ref)) {
4252: die("addentries Must be a hash ref ".
4253: join(':',caller(1))." ".
4254: join(':',caller(0))." ");
4255: }
4256:
4257: if ($register) {
1.339 albertel 4258: my ($on_load,$on_unload);
4259: foreach my $key (keys(%{$attr_ref})) {
4260: if (lc($key) eq 'onload') {
4261: $on_load.=$attr_ref->{$key}.';';
4262: delete($attr_ref->{$key});
4263:
4264: } elsif (lc($key) eq 'onunload') {
4265: $on_unload.=$attr_ref->{$key}.';';
4266: delete($attr_ref->{$key});
4267: }
4268: }
4269: $attr_ref->{'onload'} =
4270: &Apache::lonmenu::loadevents(). $on_load;
4271: $attr_ref->{'onunload'}=
4272: &Apache::lonmenu::unloadevents().$on_unload;
4273: }
4274:
4275: # Accessibility font enhance
4276: if ($env{'browser.fontenhance'} eq 'on') {
4277: my $style;
4278: foreach my $key (keys(%{$attr_ref})) {
4279: if (lc($key) eq 'style') {
4280: $style.=$attr_ref->{$key}.';';
4281: delete($attr_ref->{$key});
4282: }
4283: }
4284: $attr_ref->{'style'}=$style.'; font-size: x-large;';
1.330 albertel 4285: }
1.339 albertel 4286:
4287: if ($env{'browser.blackwhite'} eq 'on') {
4288: delete($attr_ref->{'font'});
4289: delete($attr_ref->{'link'});
4290: delete($attr_ref->{'alink'});
4291: delete($attr_ref->{'vlink'});
4292: delete($attr_ref->{'bgcolor'});
4293: delete($attr_ref->{'background'});
4294: }
4295:
1.330 albertel 4296: my $attr_string;
4297: foreach my $attr (keys(%$attr_ref)) {
4298: $attr_string .= " $attr=\"".$attr_ref->{$attr}.'" ';
4299: }
4300: return $attr_string;
4301: }
4302:
4303:
1.182 matthew 4304: ###############################################
1.251 albertel 4305: ###############################################
4306:
4307: =pod
4308:
4309: =item * &endbodytag()
4310:
4311: Returns a uniform footer for LON-CAPA web pages.
4312:
1.635 raeburn 4313: Inputs: 1 - optional reference to an args hash
4314: If in the hash, key for noredirectlink has a value which evaluates to true,
4315: a 'Continue' link is not displayed if the page contains an
4316: internal redirect in the <head></head> section,
4317: i.e., $env{'internal.head.redirect'} exists
1.251 albertel 4318:
4319: =cut
4320:
4321: sub endbodytag {
1.635 raeburn 4322: my ($args) = @_;
1.251 albertel 4323: my $endbodytag='</body>';
1.269 albertel 4324: $endbodytag=&Apache::lontexconvert::jsMath_process()."\n".$endbodytag;
1.315 albertel 4325: if ( exists( $env{'internal.head.redirect'} ) ) {
1.635 raeburn 4326: if (!(ref($args) eq 'HASH' && $args->{'noredirectlink'})) {
4327: $endbodytag=
4328: "<br /><a href=\"$env{'internal.head.redirect'}\">".
4329: &mt('Continue').'</a>'.
4330: $endbodytag;
4331: }
1.315 albertel 4332: }
1.251 albertel 4333: return $endbodytag;
4334: }
4335:
1.352 albertel 4336: =pod
4337:
4338: =item * &standard_css()
4339:
4340: Returns a style sheet
4341:
4342: Inputs: (all optional)
4343: domain -> force to color decorate a page for a specific
4344: domain
4345: function -> force usage of a specific rolish color scheme
4346: bgcolor -> override the default page bgcolor
4347:
4348: =cut
4349:
1.343 albertel 4350: sub standard_css {
1.345 albertel 4351: my ($function,$domain,$bgcolor) = @_;
1.352 albertel 4352: $function = &get_users_function() if (!$function);
4353: my $img = &designparm($function.'.img', $domain);
4354: my $tabbg = &designparm($function.'.tabbg', $domain);
4355: my $font = &designparm($function.'.font', $domain);
1.345 albertel 4356: my $sidebg = &designparm($function.'.sidebg',$domain);
1.382 albertel 4357: my $pgbg_or_bgcolor =
4358: $bgcolor ||
1.352 albertel 4359: &designparm($function.'.pgbg', $domain);
1.382 albertel 4360: my $pgbg = &designparm($function.'.pgbg', $domain);
1.352 albertel 4361: my $alink = &designparm($function.'.alink', $domain);
4362: my $vlink = &designparm($function.'.vlink', $domain);
4363: my $link = &designparm($function.'.link', $domain);
4364:
1.602 albertel 4365: my $sans = 'Verdana,Arial,Helvetica,sans-serif';
1.395 albertel 4366: my $mono = 'monospace';
1.352 albertel 4367: my $data_table_head = $tabbg;
4368: my $data_table_light = '#EEEEEE';
1.470 banghart 4369: my $data_table_dark = '#DDDDDD';
4370: my $data_table_darker = '#CCCCCC';
1.349 albertel 4371: my $data_table_highlight = '#FFFF00';
1.352 albertel 4372: my $mail_new = '#FFBB77';
4373: my $mail_new_hover = '#DD9955';
4374: my $mail_read = '#BBBB77';
4375: my $mail_read_hover = '#999944';
4376: my $mail_replied = '#AAAA88';
4377: my $mail_replied_hover = '#888855';
4378: my $mail_other = '#99BBBB';
4379: my $mail_other_hover = '#669999';
1.391 albertel 4380: my $table_header = '#DDDDDD';
1.489 raeburn 4381: my $feedback_link_bg = '#BBBBBB';
1.392 albertel 4382:
1.608 albertel 4383: my $border = ($env{'browser.type'} eq 'explorer' ||
4384: $env{'browser.type'} eq 'safari' ) ? '0px 2px 0px 2px'
4385: : '0px 3px 0px 4px';
1.448 albertel 4386:
1.523 albertel 4387:
1.343 albertel 4388: return <<END;
1.345 albertel 4389: h1, h2, h3, th { font-family: $sans }
1.343 albertel 4390: a:focus { color: red; background: yellow }
1.510 albertel 4391: table.thinborder,
1.523 albertel 4392:
1.510 albertel 4393: table.thinborder tr th {
4394: border-style: solid;
4395: border-width: 1px;
4396: background: $tabbg;
4397: }
1.523 albertel 4398: table.thinborder tr td {
1.510 albertel 4399: border-style: solid;
4400: border-width: 1px
4401: }
1.426 albertel 4402:
1.343 albertel 4403: form, .inline { display: inline; }
4404: .center { text-align: center; }
1.593 albertel 4405: .LC_filename {font-family: $mono; white-space:pre;}
1.350 albertel 4406: .LC_error {
4407: color: red;
4408: font-size: larger;
4409: }
1.457 albertel 4410: .LC_warning,
4411: .LC_diff_removed {
1.394 albertel 4412: color: red;
4413: }
1.532 albertel 4414:
4415: .LC_info,
1.457 albertel 4416: .LC_success,
4417: .LC_diff_added {
1.350 albertel 4418: color: green;
4419: }
1.543 albertel 4420: .LC_unknown {
4421: color: yellow;
4422: }
4423:
1.440 albertel 4424: .LC_icon {
4425: border: 0px;
4426: }
1.539 albertel 4427: .LC_indexer_icon {
4428: border: 0px;
4429: height: 22px;
4430: }
1.543 albertel 4431: .LC_docs_spacer {
4432: width: 25px;
4433: height: 1px;
4434: border: 0px;
4435: }
1.346 albertel 4436:
1.532 albertel 4437: .LC_internal_info {
4438: color: #999;
4439: }
4440:
1.458 albertel 4441: table.LC_pastsubmission {
4442: border: 1px solid black;
4443: margin: 2px;
4444: }
4445:
1.606 albertel 4446: table#LC_top_nav, table#LC_menubuttons,table#LC_nav_location {
1.345 albertel 4447: width: 100%;
4448: background: $pgbg;
1.392 albertel 4449: border: 2px;
1.402 albertel 4450: border-collapse: separate;
1.403 albertel 4451: padding: 0px;
1.345 albertel 4452: }
1.392 albertel 4453:
1.606 albertel 4454: table#LC_title_bar, table.LC_breadcrumbs,
1.393 albertel 4455: table#LC_title_bar.LC_with_remote {
1.359 albertel 4456: width: 100%;
1.392 albertel 4457: border-color: $pgbg;
4458: border-style: solid;
4459: border-width: $border;
4460:
1.379 albertel 4461: background: $pgbg;
4462: font-family: $sans;
1.392 albertel 4463: border-collapse: collapse;
1.403 albertel 4464: padding: 0px;
1.359 albertel 4465: }
1.392 albertel 4466:
1.409 albertel 4467: table.LC_docs_path {
4468: width: 100%;
4469: border: 0;
4470: background: $pgbg;
4471: font-family: $sans;
4472: border-collapse: collapse;
4473: padding: 0px;
4474: }
4475:
1.359 albertel 4476: table#LC_title_bar td {
4477: background: $tabbg;
4478: }
4479: table#LC_title_bar td.LC_title_bar_who {
4480: background: $tabbg;
4481: color: $font;
1.427 albertel 4482: font: small $sans;
1.359 albertel 4483: text-align: right;
4484: }
1.469 banghart 4485: span.LC_metadata {
4486: font-family: $sans;
4487: }
1.359 albertel 4488: span.LC_title_bar_title {
1.416 albertel 4489: font: bold x-large $sans;
1.359 albertel 4490: }
4491: table#LC_title_bar td.LC_title_bar_domain_logo {
4492: background: $sidebg;
4493: text-align: right;
1.368 albertel 4494: padding: 0px;
4495: }
4496: table#LC_title_bar td.LC_title_bar_role_logo {
4497: background: $sidebg;
4498: padding: 0px;
1.359 albertel 4499: }
4500:
1.346 albertel 4501: table#LC_menubuttons_mainmenu {
1.526 www 4502: width: 100%;
1.346 albertel 4503: border: 0px;
4504: border-spacing: 1px;
1.372 albertel 4505: padding: 0px 1px;
1.346 albertel 4506: margin: 0px;
4507: border-collapse: separate;
4508: }
4509: table#LC_menubuttons img, table#LC_menubuttons_mainmenu img {
4510: border: 0px;
4511: }
1.345 albertel 4512: table#LC_top_nav td {
4513: background: $tabbg;
1.392 albertel 4514: border: 0px;
1.407 albertel 4515: font-size: small;
1.345 albertel 4516: }
4517: table#LC_top_nav td a, div#LC_top_nav a {
4518: color: $font;
4519: font-family: $sans;
4520: }
1.364 albertel 4521: table#LC_top_nav td.LC_top_nav_logo {
4522: background: $tabbg;
1.432 albertel 4523: text-align: left;
1.408 albertel 4524: white-space: nowrap;
1.432 albertel 4525: width: 31px;
1.408 albertel 4526: }
4527: table#LC_top_nav td.LC_top_nav_logo img {
1.432 albertel 4528: border: 0px;
1.408 albertel 4529: vertical-align: bottom;
1.364 albertel 4530: }
1.432 albertel 4531: table#LC_top_nav td.LC_top_nav_exit,
4532: table#LC_top_nav td.LC_top_nav_help {
4533: width: 2.0em;
4534: }
1.442 albertel 4535: table#LC_top_nav td.LC_top_nav_login {
4536: width: 4.0em;
4537: text-align: center;
4538: }
1.409 albertel 4539: table.LC_breadcrumbs td, table.LC_docs_path td {
1.357 albertel 4540: background: $tabbg;
4541: color: $font;
4542: font-family: $sans;
1.358 albertel 4543: font-size: smaller;
1.357 albertel 4544: }
1.411 albertel 4545: table.LC_breadcrumbs td.LC_breadcrumbs_component,
1.409 albertel 4546: table.LC_docs_path td.LC_docs_path_component {
1.357 albertel 4547: background: $tabbg;
4548: color: $font;
4549: font-family: $sans;
4550: font-size: larger;
4551: text-align: right;
4552: }
1.383 albertel 4553: td.LC_table_cell_checkbox {
4554: text-align: center;
4555: }
1.522 albertel 4556: table#LC_mainmenu td.LC_mainmenu_column {
4557: vertical-align: top;
4558: }
4559:
1.346 albertel 4560: .LC_menubuttons_inline_text {
4561: color: $font;
4562: font-family: $sans;
4563: font-size: smaller;
4564: }
4565:
1.526 www 4566: .LC_menubuttons_link {
4567: text-decoration: none;
4568: }
1.680 riegler 4569: #2008--9-5: new menu style sheet.Changed category
1.522 albertel 4570: .LC_menubuttons_category {
1.521 www 4571: color: $font;
1.526 www 4572: background: $pgbg;
1.521 www 4573: font-family: $sans;
4574: font-size: larger;
4575: font-weight: bold;
4576: }
4577:
1.346 albertel 4578: td.LC_menubuttons_text {
1.526 www 4579: width: 90%;
1.346 albertel 4580: color: $font;
4581: font-family: $sans;
4582: }
1.526 www 4583:
1.346 albertel 4584: td.LC_menubuttons_img {
4585: }
1.526 www 4586:
1.346 albertel 4587: .LC_current_location {
4588: font-family: $sans;
4589: background: $tabbg;
4590: }
4591: .LC_new_mail {
4592: font-family: $sans;
1.634 www 4593: background: $tabbg;
1.346 albertel 4594: font-weight: bold;
4595: }
1.347 albertel 4596:
1.526 www 4597: .LC_rolesmenu_is {
4598: font-family: $sans;
4599: }
4600:
4601: .LC_rolesmenu_selected {
4602: font-family: $sans;
4603: }
4604:
4605: .LC_rolesmenu_future {
4606: font-family: $sans;
4607: }
4608:
4609:
4610: .LC_rolesmenu_will {
4611: font-family: $sans;
4612: }
4613:
4614: .LC_rolesmenu_will_not {
4615: font-family: $sans;
4616: }
4617:
4618: .LC_rolesmenu_expired {
4619: font-family: $sans;
4620: }
4621:
4622: .LC_rolesinfo {
4623: font-family: $sans;
4624: }
4625:
1.527 www 4626: .LC_dropadd_labeltext {
4627: font-family: $sans;
4628: text-align: right;
4629: }
4630:
4631: .LC_preferences_labeltext {
4632: font-family: $sans;
4633: text-align: right;
4634: }
4635:
1.666 raeburn 4636: .LC_roleslog_note {
4637: font-size: smaller;
4638: }
4639:
1.440 albertel 4640: table.LC_aboutme_port {
4641: border: 0px;
4642: border-collapse: collapse;
4643: border-spacing: 0px;
4644: }
1.349 albertel 4645: table.LC_data_table, table.LC_mail_list {
1.347 albertel 4646: border: 1px solid #000000;
1.402 albertel 4647: border-collapse: separate;
1.426 albertel 4648: border-spacing: 1px;
1.610 albertel 4649: background: $pgbg;
1.347 albertel 4650: }
1.422 albertel 4651: .LC_data_table_dense {
4652: font-size: small;
4653: }
1.507 raeburn 4654: table.LC_nested_outer {
4655: border: 1px solid #000000;
1.589 raeburn 4656: border-collapse: collapse;
1.507 raeburn 4657: border-spacing: 0px;
4658: width: 100%;
4659: }
4660: table.LC_nested {
4661: border: 0px;
1.589 raeburn 4662: border-collapse: collapse;
1.507 raeburn 4663: border-spacing: 0px;
4664: width: 100%;
4665: }
1.523 albertel 4666: table.LC_data_table tr th, table.LC_calendar tr th, table.LC_mail_list tr th,
4667: table.LC_prior_tries tr th {
1.349 albertel 4668: font-weight: bold;
4669: background-color: $data_table_head;
1.421 albertel 4670: font-size: smaller;
1.347 albertel 4671: }
1.610 albertel 4672: table.LC_data_table tr.LC_odd_row > td,
1.440 albertel 4673: table.LC_aboutme_port tr td {
1.349 albertel 4674: background-color: $data_table_light;
1.425 albertel 4675: padding: 2px;
1.347 albertel 4676: }
1.610 albertel 4677: table.LC_data_table tr.LC_even_row > td,
1.440 albertel 4678: table.LC_aboutme_port tr.LC_even_row td {
1.349 albertel 4679: background-color: $data_table_dark;
1.347 albertel 4680: }
1.425 albertel 4681: table.LC_data_table tr.LC_data_table_highlight td {
4682: background-color: $data_table_darker;
4683: }
1.639 raeburn 4684: table.LC_data_table tr td.LC_leftcol_header {
4685: background-color: $data_table_head;
4686: font-weight: bold;
4687: }
1.451 albertel 4688: table.LC_data_table tr.LC_empty_row td,
1.507 raeburn 4689: table.LC_nested tr.LC_empty_row td {
1.347 albertel 4690: background-color: #FFFFFF;
1.421 albertel 4691: font-weight: bold;
4692: font-style: italic;
4693: text-align: center;
4694: padding: 8px;
1.347 albertel 4695: }
1.507 raeburn 4696: table.LC_nested tr.LC_empty_row td {
1.465 albertel 4697: padding: 4ex
4698: }
1.507 raeburn 4699: table.LC_nested_outer tr th {
4700: font-weight: bold;
4701: background-color: $data_table_head;
4702: font-size: smaller;
4703: border-bottom: 1px solid #000000;
4704: }
4705: table.LC_nested_outer tr td.LC_subheader {
4706: background-color: $data_table_head;
4707: font-weight: bold;
4708: font-size: small;
4709: border-bottom: 1px solid #000000;
4710: text-align: right;
1.451 albertel 4711: }
1.507 raeburn 4712: table.LC_nested tr.LC_info_row td {
1.451 albertel 4713: background-color: #CCC;
4714: font-weight: bold;
4715: font-size: small;
1.507 raeburn 4716: text-align: center;
4717: }
1.589 raeburn 4718: table.LC_nested tr.LC_info_row td.LC_left_item,
4719: table.LC_nested_outer tr th.LC_left_item {
1.507 raeburn 4720: text-align: left;
1.451 albertel 4721: }
1.507 raeburn 4722: table.LC_nested td {
1.451 albertel 4723: background-color: #FFF;
4724: font-size: small;
1.507 raeburn 4725: }
4726: table.LC_nested_outer tr th.LC_right_item,
4727: table.LC_nested tr.LC_info_row td.LC_right_item,
4728: table.LC_nested tr.LC_odd_row td.LC_right_item,
4729: table.LC_nested tr td.LC_right_item {
1.451 albertel 4730: text-align: right;
4731: }
4732:
1.507 raeburn 4733: table.LC_nested tr.LC_odd_row td {
1.451 albertel 4734: background-color: #EEE;
4735: }
4736:
1.473 raeburn 4737: table.LC_createuser {
4738: }
4739:
4740: table.LC_createuser tr.LC_section_row td {
4741: font-size: smaller;
4742: }
4743:
4744: table.LC_createuser tr.LC_info_row td {
4745: background-color: #CCC;
4746: font-weight: bold;
4747: text-align: center;
4748: }
4749:
1.349 albertel 4750: table.LC_calendar {
4751: border: 1px solid #000000;
4752: border-collapse: collapse;
4753: }
4754: table.LC_calendar_pickdate {
4755: font-size: xx-small;
4756: }
4757: table.LC_calendar tr td {
4758: border: 1px solid #000000;
4759: vertical-align: top;
4760: }
4761: table.LC_calendar tr td.LC_calendar_day_empty {
4762: background-color: $data_table_dark;
4763: }
4764: table.LC_calendar tr td.LC_calendar_day_current {
4765: background-color: $data_table_highlight;
4766: }
4767:
4768: table.LC_mail_list tr.LC_mail_new {
4769: background-color: $mail_new;
4770: }
4771: table.LC_mail_list tr.LC_mail_new:hover {
4772: background-color: $mail_new_hover;
4773: }
4774: table.LC_mail_list tr.LC_mail_read {
4775: background-color: $mail_read;
4776: }
4777: table.LC_mail_list tr.LC_mail_read:hover {
4778: background-color: $mail_read_hover;
4779: }
4780: table.LC_mail_list tr.LC_mail_replied {
4781: background-color: $mail_replied;
4782: }
4783: table.LC_mail_list tr.LC_mail_replied:hover {
4784: background-color: $mail_replied_hover;
4785: }
4786: table.LC_mail_list tr.LC_mail_other {
4787: background-color: $mail_other;
4788: }
4789: table.LC_mail_list tr.LC_mail_other:hover {
4790: background-color: $mail_other_hover;
4791: }
1.494 raeburn 4792: table.LC_mail_list tr.LC_mail_even {
4793: }
4794: table.LC_mail_list tr.LC_mail_odd {
4795: }
4796:
1.385 albertel 4797:
1.386 albertel 4798: table#LC_portfolio_actions {
4799: width: auto;
4800: background: $pgbg;
4801: border: 0px;
4802: border-spacing: 2px 2px;
4803: padding: 0px;
4804: margin: 0px;
4805: border-collapse: separate;
4806: }
4807: table#LC_portfolio_actions td.LC_label {
4808: background: $tabbg;
4809: text-align: right;
4810: }
4811: table#LC_portfolio_actions td.LC_value {
4812: background: $tabbg;
4813: }
1.385 albertel 4814:
1.391 albertel 4815: table#LC_cstr_controls {
4816: width: 100%;
4817: border-collapse: collapse;
4818: }
4819: table#LC_cstr_controls tr td {
4820: border: 4px solid $pgbg;
4821: padding: 4px;
4822: text-align: center;
4823: background: $tabbg;
4824: }
4825: table#LC_cstr_controls tr th {
4826: border: 4px solid $pgbg;
4827: background: $table_header;
4828: text-align: center;
4829: font-family: $sans;
4830: font-size: smaller;
4831: }
4832:
1.389 albertel 4833: table#LC_browser {
4834:
4835: }
4836: table#LC_browser tr th {
1.391 albertel 4837: background: $table_header;
1.389 albertel 4838: }
1.390 albertel 4839: table#LC_browser tr td {
4840: padding: 2px;
4841: }
1.389 albertel 4842: table#LC_browser tr.LC_browser_file,
4843: table#LC_browser tr.LC_browser_file_published {
4844: background: #CCFF88;
4845: }
4846: table#LC_browser tr.LC_browser_file_locked,
4847: table#LC_browser tr.LC_browser_file_unpublished {
4848: background: #FFAA99;
1.387 albertel 4849: }
1.389 albertel 4850: table#LC_browser tr.LC_browser_file_obsolete {
4851: background: #AAAAAA;
1.387 albertel 4852: }
1.455 albertel 4853: table#LC_browser tr.LC_browser_file_modified,
4854: table#LC_browser tr.LC_browser_file_metamodified {
1.389 albertel 4855: background: #FFFF77;
1.387 albertel 4856: }
1.389 albertel 4857: table#LC_browser tr.LC_browser_folder {
4858: background: #CCCCFF;
1.387 albertel 4859: }
1.388 albertel 4860: span.LC_current_location {
4861: font-size: x-large;
4862: background: $pgbg;
4863: }
1.387 albertel 4864:
1.395 albertel 4865: span.LC_parm_menu_item {
4866: font-size: larger;
4867: font-family: $sans;
4868: }
4869: span.LC_parm_scope_all {
4870: color: red;
4871: }
4872: span.LC_parm_scope_folder {
4873: color: green;
4874: }
4875: span.LC_parm_scope_resource {
4876: color: orange;
4877: }
4878: span.LC_parm_part {
4879: color: blue;
4880: }
4881: span.LC_parm_folder, span.LC_parm_symb {
4882: font-size: x-small;
4883: font-family: $mono;
4884: color: #AAAAAA;
4885: }
4886:
1.396 albertel 4887: td.LC_parm_overview_level_menu, td.LC_parm_overview_map_menu,
4888: td.LC_parm_overview_parm_selectors, td.LC_parm_overview_parm_restrictions {
4889: border: 1px solid black;
4890: border-collapse: collapse;
4891: }
4892: table.LC_parm_overview_restrictions td {
4893: border-width: 1px 4px 1px 4px;
4894: border-style: solid;
4895: border-color: $pgbg;
4896: text-align: center;
4897: }
4898: table.LC_parm_overview_restrictions th {
4899: background: $tabbg;
4900: border-width: 1px 4px 1px 4px;
4901: border-style: solid;
4902: border-color: $pgbg;
4903: }
1.398 albertel 4904: table#LC_helpmenu {
4905: border: 0px;
4906: height: 55px;
4907: border-spacing: 0px;
4908: }
4909:
4910: table#LC_helpmenu fieldset legend {
4911: font-size: larger;
4912: font-weight: bold;
4913: }
1.397 albertel 4914: table#LC_helpmenu_links {
4915: width: 100%;
4916: border: 1px solid black;
4917: background: $pgbg;
4918: padding: 0px;
4919: border-spacing: 1px;
4920: }
4921: table#LC_helpmenu_links tr td {
4922: padding: 1px;
4923: background: $tabbg;
1.399 albertel 4924: text-align: center;
4925: font-weight: bold;
1.397 albertel 4926: }
1.396 albertel 4927:
1.397 albertel 4928: table#LC_helpmenu_links a:link, table#LC_helpmenu_links a:visited,
4929: table#LC_helpmenu_links a:active {
4930: text-decoration: none;
4931: color: $font;
4932: }
4933: table#LC_helpmenu_links a:hover {
4934: text-decoration: underline;
4935: color: $vlink;
4936: }
1.396 albertel 4937:
1.417 albertel 4938: .LC_chrt_popup_exists {
4939: border: 1px solid #339933;
4940: margin: -1px;
4941: }
4942: .LC_chrt_popup_up {
4943: border: 1px solid yellow;
4944: margin: -1px;
4945: }
4946: .LC_chrt_popup {
4947: border: 1px solid #8888FF;
4948: background: #CCCCFF;
4949: }
1.421 albertel 4950: table.LC_pick_box {
4951: border-collapse: separate;
4952: background: white;
4953: border: 1px solid black;
4954: border-spacing: 1px;
4955: }
4956: table.LC_pick_box td.LC_pick_box_title {
4957: background: $tabbg;
4958: font-weight: bold;
4959: text-align: right;
4960: width: 184px;
4961: padding: 8px;
4962: }
1.645 raeburn 4963: table.LC_pick_box td.LC_selfenroll_pick_box_title {
4964: background: $tabbg;
4965: font-weight: bold;
4966: text-align: right;
4967: width: 350px;
4968: padding: 8px;
4969: }
4970:
1.579 raeburn 4971: table.LC_pick_box td.LC_pick_box_value {
4972: text-align: left;
4973: padding: 8px;
4974: }
4975: table.LC_pick_box td.LC_pick_box_select {
4976: text-align: left;
4977: padding: 8px;
4978: }
1.424 albertel 4979: table.LC_pick_box td.LC_pick_box_separator {
1.421 albertel 4980: padding: 0px;
4981: height: 1px;
4982: background: black;
4983: }
4984: table.LC_pick_box td.LC_pick_box_submit {
4985: text-align: right;
4986: }
1.579 raeburn 4987: table.LC_pick_box td.LC_evenrow_value {
4988: text-align: left;
4989: padding: 8px;
4990: background-color: $data_table_light;
4991: }
4992: table.LC_pick_box td.LC_oddrow_value {
4993: text-align: left;
4994: padding: 8px;
4995: background-color: $data_table_light;
4996: }
4997: table.LC_helpform_receipt {
4998: width: 620px;
4999: border-collapse: separate;
5000: background: white;
5001: border: 1px solid black;
5002: border-spacing: 1px;
5003: }
5004: table.LC_helpform_receipt td.LC_pick_box_title {
5005: background: $tabbg;
5006: font-weight: bold;
5007: text-align: right;
5008: width: 184px;
5009: padding: 8px;
5010: }
5011: table.LC_helpform_receipt td.LC_evenrow_value {
5012: text-align: left;
5013: padding: 8px;
5014: background-color: $data_table_light;
5015: }
5016: table.LC_helpform_receipt td.LC_oddrow_value {
5017: text-align: left;
5018: padding: 8px;
5019: background-color: $data_table_light;
5020: }
5021: table.LC_helpform_receipt td.LC_pick_box_separator {
5022: padding: 0px;
5023: height: 1px;
5024: background: black;
5025: }
5026: span.LC_helpform_receipt_cat {
5027: font-weight: bold;
5028: }
1.424 albertel 5029: table.LC_group_priv_box {
5030: background: white;
5031: border: 1px solid black;
5032: border-spacing: 1px;
5033: }
5034: table.LC_group_priv_box td.LC_pick_box_title {
5035: background: $tabbg;
5036: font-weight: bold;
5037: text-align: right;
5038: width: 184px;
5039: }
5040: table.LC_group_priv_box td.LC_groups_fixed {
5041: background: $data_table_light;
5042: text-align: center;
5043: }
5044: table.LC_group_priv_box td.LC_groups_optional {
5045: background: $data_table_dark;
5046: text-align: center;
5047: }
5048: table.LC_group_priv_box td.LC_groups_functionality {
5049: background: $data_table_darker;
5050: text-align: center;
5051: font-weight: bold;
5052: }
5053: table.LC_group_priv td {
5054: text-align: left;
5055: padding: 0px;
5056: }
5057:
1.421 albertel 5058: table.LC_notify_front_page {
5059: background: white;
5060: border: 1px solid black;
5061: padding: 8px;
5062: }
5063: table.LC_notify_front_page td {
5064: padding: 8px;
5065: }
1.424 albertel 5066: .LC_navbuttons {
5067: margin: 2ex 0ex 2ex 0ex;
5068: }
1.423 albertel 5069: .LC_topic_bar {
5070: font-family: $sans;
5071: font-weight: bold;
5072: width: 100%;
5073: background: $tabbg;
5074: vertical-align: middle;
5075: margin: 2ex 0ex 2ex 0ex;
5076: }
5077: .LC_topic_bar span {
5078: vertical-align: middle;
5079: }
5080: .LC_topic_bar img {
5081: vertical-align: bottom;
5082: }
5083: table.LC_course_group_status {
5084: margin: 20px;
5085: }
5086: table.LC_status_selector td {
5087: vertical-align: top;
5088: text-align: center;
1.424 albertel 5089: padding: 4px;
5090: }
5091: table.LC_descriptive_input td.LC_description {
5092: vertical-align: top;
5093: text-align: right;
5094: font-weight: bold;
1.423 albertel 5095: }
1.599 albertel 5096: div.LC_feedback_link {
1.616 albertel 5097: clear: both;
1.599 albertel 5098: background: white;
5099: width: 100%;
1.489 raeburn 5100: }
5101: span.LC_feedback_link {
1.599 albertel 5102: background: $feedback_link_bg;
5103: font-size: larger;
5104: }
5105: span.LC_message_link {
5106: background: $feedback_link_bg;
5107: font-size: larger;
5108: position: absolute;
5109: right: 1em;
1.489 raeburn 5110: }
1.421 albertel 5111:
1.515 albertel 5112: table.LC_prior_tries {
1.524 albertel 5113: border: 1px solid #000000;
5114: border-collapse: separate;
5115: border-spacing: 1px;
1.515 albertel 5116: }
1.523 albertel 5117:
1.515 albertel 5118: table.LC_prior_tries td {
1.524 albertel 5119: padding: 2px;
1.515 albertel 5120: }
1.523 albertel 5121:
5122: .LC_answer_correct {
5123: background: #AAFFAA;
5124: color: black;
5125: }
5126: .LC_answer_charged_try {
5127: background: #FFAAAA ! important;
5128: color: black;
5129: }
5130: .LC_answer_not_charged_try,
5131: .LC_answer_no_grade,
5132: .LC_answer_late {
5133: background: #FFFFAA;
5134: color: black;
5135: }
5136: .LC_answer_previous {
5137: background: #AAAAFF;
5138: color: black;
5139: }
5140: .LC_answer_no_message {
5141: background: #FFFFFF;
5142: color: black;
5143: }
5144: .LC_answer_unknown {
5145: background: orange;
5146: color: black;
5147: }
5148:
5149:
1.529 albertel 5150: span.LC_prior_numerical,
5151: span.LC_prior_string,
5152: span.LC_prior_custom,
5153: span.LC_prior_reaction,
5154: span.LC_prior_math {
1.523 albertel 5155: font-family: monospace;
5156: white-space: pre;
5157: }
5158:
1.525 albertel 5159: span.LC_prior_string {
5160: font-family: monospace;
5161: white-space: pre;
5162: }
5163:
1.523 albertel 5164: table.LC_prior_option {
5165: width: 100%;
5166: border-collapse: collapse;
5167: }
1.528 albertel 5168: table.LC_prior_rank, table.LC_prior_match {
5169: border-collapse: collapse;
5170: }
5171: table.LC_prior_option tr td,
5172: table.LC_prior_rank tr td,
5173: table.LC_prior_match tr td {
1.524 albertel 5174: border: 1px solid #000000;
1.515 albertel 5175: }
5176:
1.519 raeburn 5177: span.LC_nobreak {
1.544 albertel 5178: white-space: nowrap;
1.519 raeburn 5179: }
5180:
1.576 raeburn 5181: span.LC_cusr_emph {
5182: font-style: italic;
5183: }
5184:
1.633 raeburn 5185: span.LC_cusr_subheading {
5186: font-weight: normal;
5187: font-size: 85%;
5188: }
5189:
1.545 albertel 5190: table.LC_docs_documents {
5191: background: #BBBBBB;
1.547 albertel 5192: border-width: 0px;
1.545 albertel 5193: border-collapse: collapse;
5194: }
5195:
5196: table.LC_docs_documents td.LC_docs_document {
5197: border: 2px solid black;
5198: padding: 4px;
5199: }
5200:
5201: .LC_docs_course_commands div {
5202: float: left;
5203: border: 4px solid #AAAAAA;
5204: padding: 4px;
5205: background: #DDDDCC;
5206: }
5207:
5208: .LC_docs_entry_move {
5209: border: 0px;
5210: border-collapse: collapse;
1.544 albertel 5211: }
5212:
1.545 albertel 5213: .LC_docs_entry_move td {
5214: border: 2px solid #BBBBBB;
5215: background: #DDDDDD;
5216: }
5217:
5218: .LC_docs_editor td.LC_docs_entry_commands {
5219: background: #DDDDDD;
5220: font-size: x-small;
5221: }
1.544 albertel 5222: .LC_docs_copy {
1.545 albertel 5223: color: #000099;
1.544 albertel 5224: }
5225: .LC_docs_cut {
1.545 albertel 5226: color: #550044;
1.544 albertel 5227: }
5228: .LC_docs_rename {
1.545 albertel 5229: color: #009900;
1.544 albertel 5230: }
5231: .LC_docs_remove {
1.545 albertel 5232: color: #990000;
5233: }
5234:
1.547 albertel 5235: .LC_docs_reinit_warn,
5236: .LC_docs_ext_edit {
5237: font-size: x-small;
5238: }
5239:
1.545 albertel 5240: .LC_docs_editor td.LC_docs_entry_title,
5241: .LC_docs_editor td.LC_docs_entry_icon {
5242: background: #FFFFBB;
5243: }
5244: .LC_docs_editor td.LC_docs_entry_parameter {
5245: background: #BBBBFF;
5246: font-size: x-small;
5247: white-space: nowrap;
5248: }
5249:
5250: table.LC_docs_adddocs td,
5251: table.LC_docs_adddocs th {
5252: border: 1px solid #BBBBBB;
5253: padding: 4px;
5254: background: #DDDDDD;
1.543 albertel 5255: }
5256:
1.584 albertel 5257: table.LC_sty_begin {
5258: background: #BBFFBB;
5259: }
5260: table.LC_sty_end {
5261: background: #FFBBBB;
5262: }
5263:
1.589 raeburn 5264: table.LC_double_column {
5265: border-width: 0px;
5266: border-collapse: collapse;
5267: width: 100%;
5268: padding: 2px;
5269: }
5270:
5271: table.LC_double_column tr td.LC_left_col {
1.590 raeburn 5272: top: 2px;
1.589 raeburn 5273: left: 2px;
5274: width: 47%;
5275: vertical-align: top;
5276: }
5277:
5278: table.LC_double_column tr td.LC_right_col {
5279: top: 2px;
5280: right: 2px;
5281: width: 47%;
5282: vertical-align: top;
5283: }
5284:
1.594 raeburn 5285: span.LC_role_level {
5286: font-weight: bold;
5287: }
5288:
1.591 raeburn 5289: div.LC_left_float {
5290: float: left;
5291: padding-right: 5%;
1.597 albertel 5292: padding-bottom: 4px;
1.591 raeburn 5293: }
5294:
5295: div.LC_clear_float_header {
1.597 albertel 5296: padding-bottom: 2px;
1.591 raeburn 5297: }
5298:
5299: div.LC_clear_float_footer {
1.597 albertel 5300: padding-top: 10px;
1.591 raeburn 5301: clear: both;
5302: }
5303:
1.597 albertel 5304:
1.601 albertel 5305: div.LC_grade_select_mode {
1.604 albertel 5306: font-family: $sans;
1.601 albertel 5307: }
5308: div.LC_grade_select_mode div div {
5309: margin: 5px;
5310: }
5311: div.LC_grade_select_mode_selector {
5312: margin: 5px;
5313: float: left;
5314: }
5315: div.LC_grade_select_mode_selector_header {
5316: font: bold medium $sans;
5317: }
5318: div.LC_grade_select_mode_type {
5319: clear: left;
5320: }
5321:
1.597 albertel 5322: div.LC_grade_show_user {
5323: margin-top: 20px;
5324: border: 1px solid black;
5325: }
5326: div.LC_grade_user_name {
5327: background: #DDDDEE;
5328: border-bottom: 1px solid black;
5329: font: bold large $sans;
5330: }
5331: div.LC_grade_show_user_odd_row div.LC_grade_user_name {
5332: background: #DDEEDD;
5333: }
5334:
5335: div.LC_grade_show_problem,
5336: div.LC_grade_submissions,
5337: div.LC_grade_message_center,
5338: div.LC_grade_info_links,
5339: div.LC_grade_assign {
5340: margin: 5px;
5341: width: 99%;
5342: background: #FFFFFF;
5343: }
5344: div.LC_grade_show_problem_header,
5345: div.LC_grade_submissions_header,
5346: div.LC_grade_message_center_header,
5347: div.LC_grade_assign_header {
5348: font: bold large $sans;
5349: }
5350: div.LC_grade_show_problem_problem,
5351: div.LC_grade_submissions_body,
5352: div.LC_grade_message_center_body,
5353: div.LC_grade_assign_body {
5354: border: 1px solid black;
5355: width: 99%;
5356: background: #FFFFFF;
5357: }
1.598 albertel 5358: span.LC_grade_check_note {
5359: font: normal medium $sans;
5360: display: inline;
5361: position: absolute;
5362: right: 1em;
5363: }
1.597 albertel 5364:
1.613 albertel 5365: table.LC_scantron_action {
5366: width: 100%;
5367: }
5368: table.LC_scantron_action tr th {
5369: font: normal bold $sans;
5370: }
1.600 albertel 5371:
1.614 albertel 5372: div.LC_edit_problem_header,
5373: div.LC_edit_problem_footer {
1.600 albertel 5374: font: normal medium $sans;
1.602 albertel 5375: margin: 2px;
1.600 albertel 5376: }
5377: div.LC_edit_problem_header,
1.602 albertel 5378: div.LC_edit_problem_header div,
1.614 albertel 5379: div.LC_edit_problem_footer,
5380: div.LC_edit_problem_footer div,
1.602 albertel 5381: div.LC_edit_problem_editxml_header,
5382: div.LC_edit_problem_editxml_header div {
1.600 albertel 5383: margin-top: 5px;
5384: }
1.602 albertel 5385: div.LC_edit_problem_header_edit_row {
5386: background: $tabbg;
5387: padding: 3px;
5388: margin-bottom: 5px;
5389: }
1.600 albertel 5390: div.LC_edit_problem_header_title {
1.602 albertel 5391: font: larger bold $sans;
5392: background: $tabbg;
5393: padding: 3px;
5394: }
5395: table.LC_edit_problem_header_title {
5396: font: larger bold $sans;
5397: width: 100%;
5398: border-color: $pgbg;
5399: border-style: solid;
5400: border-width: $border;
5401:
1.600 albertel 5402: background: $tabbg;
1.602 albertel 5403: border-collapse: collapse;
5404: padding: 0px
5405: }
5406:
5407: div.LC_edit_problem_discards {
5408: float: left;
5409: padding-bottom: 5px;
5410: }
5411: div.LC_edit_problem_saves {
5412: float: right;
5413: padding-bottom: 5px;
1.600 albertel 5414: }
5415: hr.LC_edit_problem_divide {
1.602 albertel 5416: clear: both;
1.600 albertel 5417: color: $tabbg;
5418: background-color: $tabbg;
5419: height: 3px;
5420: border: 0px;
5421: }
1.679 riegler 5422: img.stift{
1.678 riegler 5423: border-width:0;
1.679 riegler 5424: vertical-align:middle;
1.677 riegler 5425: }
1.680 riegler 5426:
1.681 riegler 5427: table#LC_mainmenu{
5428: margin-top:10px;
5429: width:80%;
5430:
5431: }
5432:
1.680 riegler 5433: table#LC_mainmenu td.LC_mainmenu_col_fieldset{
5434: vertical-align: top;
5435: width: 45%;
5436: }
5437: .LC_mainmenu_fieldset_category {
5438: color: $font;
5439: background: $pgbg;
5440: font-family: $sans;
5441: font-size: small;
5442: font-weight: bold;
5443: }
5444: fieldset#LC_mainmenu_fieldset {
1.681 riegler 5445: margin:0px 10px 10px 0px;
1.680 riegler 5446:
5447: }
1.343 albertel 5448: END
5449: }
5450:
1.306 albertel 5451: =pod
5452:
5453: =item * &headtag()
5454:
5455: Returns a uniform footer for LON-CAPA web pages.
5456:
1.307 albertel 5457: Inputs: $title - optional title for the head
5458: $head_extra - optional extra HTML to put inside the <head>
1.315 albertel 5459: $args - optional arguments
1.319 albertel 5460: force_register - if is true call registerurl so the remote is
5461: informed
1.415 albertel 5462: redirect -> array ref of
5463: 1- seconds before redirect occurs
5464: 2- url to redirect to
5465: 3- whether the side effect should occur
1.315 albertel 5466: (side effect of setting
5467: $env{'internal.head.redirect'} to the url
5468: redirected too)
1.352 albertel 5469: domain -> force to color decorate a page for a specific
5470: domain
5471: function -> force usage of a specific rolish color scheme
5472: bgcolor -> override the default page bgcolor
1.460 albertel 5473: no_auto_mt_title
5474: -> prevent &mt()ing the title arg
1.464 albertel 5475:
1.306 albertel 5476: =cut
5477:
5478: sub headtag {
1.313 albertel 5479: my ($title,$head_extra,$args) = @_;
1.306 albertel 5480:
1.363 albertel 5481: my $function = $args->{'function'} || &get_users_function();
5482: my $domain = $args->{'domain'} || &determinedomain();
5483: my $bgcolor = $args->{'bgcolor'} || &designparm($function.'.pgbg',$domain);
1.418 albertel 5484: my $url = join(':',$env{'user.name'},$env{'user.domain'},
1.458 albertel 5485: $Apache::lonnet::perlvar{'lonVersion'},
1.531 albertel 5486: #time(),
1.418 albertel 5487: $env{'environment.color.timestamp'},
1.363 albertel 5488: $function,$domain,$bgcolor);
5489:
1.369 www 5490: $url = '/adm/css/'.&escape($url).'.css';
1.363 albertel 5491:
1.308 albertel 5492: my $result =
5493: '<head>'.
1.461 albertel 5494: &font_settings();
1.319 albertel 5495:
1.461 albertel 5496: if (!$args->{'frameset'}) {
5497: $result .= &Apache::lonhtmlcommon::htmlareaheaders();
5498: }
1.319 albertel 5499: if ($args->{'force_register'}) {
5500: $result .= &Apache::lonmenu::registerurl(1);
5501: }
1.436 albertel 5502: if (!$args->{'no_nav_bar'}
5503: && !$args->{'only_body'}
5504: && !$args->{'frameset'}) {
5505: $result .= &help_menu_js();
5506: }
1.319 albertel 5507:
1.314 albertel 5508: if (ref($args->{'redirect'})) {
1.414 albertel 5509: my ($time,$url,$inhibit_continue) = @{$args->{'redirect'}};
1.315 albertel 5510: $url = &Apache::lonenc::check_encrypt($url);
1.414 albertel 5511: if (!$inhibit_continue) {
5512: $env{'internal.head.redirect'} = $url;
5513: }
1.313 albertel 5514: $result.=<<ADDMETA
5515: <meta http-equiv="pragma" content="no-cache" />
1.344 albertel 5516: <meta http-equiv="Refresh" content="$time; url=$url" />
1.313 albertel 5517: ADDMETA
5518: }
1.306 albertel 5519: if (!defined($title)) {
5520: $title = 'The LearningOnline Network with CAPA';
5521: }
1.460 albertel 5522: if (!$args->{'no_auto_mt_title'}) { $title = &mt($title); }
5523: $result .= '<title> LON-CAPA '.$title.'</title>'
1.414 albertel 5524: .'<link rel="stylesheet" type="text/css" href="'.$url.'" />'
5525: .$head_extra;
1.306 albertel 5526: return $result;
5527: }
5528:
5529: =pod
5530:
1.340 albertel 5531: =item * &font_settings()
5532:
5533: Returns neccessary <meta> to set the proper encoding
5534:
5535: Inputs: none
5536:
5537: =cut
5538:
5539: sub font_settings {
5540: my $headerstring='';
1.647 www 5541: if (!$env{'browser.mathml'} && $env{'browser.unicode'}) {
1.340 albertel 5542: $headerstring.=
5543: '<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />';
5544: }
5545: return $headerstring;
5546: }
5547:
1.341 albertel 5548: =pod
5549:
5550: =item * &xml_begin()
5551:
5552: Returns the needed doctype and <html>
5553:
5554: Inputs: none
5555:
5556: =cut
5557:
5558: sub xml_begin {
5559: my $output='';
5560:
1.592 albertel 5561: if ($env{'internal.start_page'}==1) {
5562: &Apache::lonhtmlcommon::init_htmlareafields();
5563: }
1.342 albertel 5564:
1.341 albertel 5565: if ($env{'browser.mathml'}) {
5566: $output='<?xml version="1.0"?>'
5567: #.'<?xml-stylesheet type="text/css" href="/adm/MathML/mathml.css"?>'."\n"
5568: # .'<!DOCTYPE html SYSTEM "/adm/MathML/mathml.dtd" '
5569:
5570: # .'<!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">] >'
5571: .'<!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">'
5572: .'<html xmlns:math="http://www.w3.org/1998/Math/MathML" '
5573: .'xmlns="http://www.w3.org/1999/xhtml">';
5574: } else {
5575: $output='<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"><html>';
5576: }
5577: return $output;
5578: }
1.340 albertel 5579:
5580: =pod
5581:
1.306 albertel 5582: =item * &endheadtag()
5583:
5584: Returns a uniform </head> for LON-CAPA web pages.
5585:
5586: Inputs: none
5587:
5588: =cut
5589:
5590: sub endheadtag {
5591: return '</head>';
5592: }
5593:
5594: =pod
5595:
5596: =item * &head()
5597:
5598: Returns a uniform complete <head>..</head> section for LON-CAPA web pages.
5599:
1.648 raeburn 5600: Inputs:
5601:
5602: =over 4
5603:
5604: $title - optional title for the page
5605:
5606: $head_extra - optional extra HTML to put inside the <head>
5607:
5608: =back
1.405 albertel 5609:
1.306 albertel 5610: =cut
5611:
5612: sub head {
1.325 albertel 5613: my ($title,$head_extra,$args) = @_;
5614: return &headtag($title,$head_extra,$args).&endheadtag();
1.306 albertel 5615: }
5616:
5617: =pod
5618:
5619: =item * &start_page()
5620:
5621: Returns a complete <html> .. <body> section for LON-CAPA web pages.
5622:
1.648 raeburn 5623: Inputs:
5624:
5625: =over 4
5626:
5627: $title - optional title for the page
5628:
5629: $head_extra - optional extra HTML to incude inside the <head>
5630:
5631: $args - additional optional args supported are:
5632:
5633: =over 8
5634:
5635: only_body -> is true will set &bodytag() onlybodytag
1.317 albertel 5636: arg on
1.648 raeburn 5637: no_nav_bar -> is true will set &bodytag() notopbar arg on
5638: add_entries -> additional attributes to add to the <body>
5639: domain -> force to color decorate a page for a
1.317 albertel 5640: specific domain
1.648 raeburn 5641: function -> force usage of a specific rolish color
1.317 albertel 5642: scheme
1.648 raeburn 5643: redirect -> see &headtag()
5644: bgcolor -> override the default page bg color
5645: js_ready -> return a string ready for being used in
1.317 albertel 5646: a javascript writeln
1.648 raeburn 5647: html_encode -> return a string ready for being used in
1.320 albertel 5648: a html attribute
1.648 raeburn 5649: force_register -> if is true will turn on the &bodytag()
1.317 albertel 5650: $forcereg arg
1.648 raeburn 5651: body_title -> alternate text to use instead of $title
1.326 albertel 5652: in the title box that appears, this text
5653: is not auto translated like the $title is
1.648 raeburn 5654: frameset -> if true will start with a <frameset>
1.330 albertel 5655: rather than <body>
1.648 raeburn 5656: no_title -> if true the title bar won't be shown
5657: skip_phases -> hash ref of
1.338 albertel 5658: head -> skip the <html><head> generation
5659: body -> skip all <body> generation
1.648 raeburn 5660: no_inline_link -> if true and in remote mode, don't show the
1.361 albertel 5661: 'Switch To Inline Menu' link
1.648 raeburn 5662: no_auto_mt_title -> prevent &mt()ing the title arg
5663: inherit_jsmath -> when creating popup window in a page,
5664: should it have jsmath forced on by the
5665: current page
1.361 albertel 5666:
1.648 raeburn 5667: =back
1.460 albertel 5668:
1.648 raeburn 5669: =back
1.562 albertel 5670:
1.306 albertel 5671: =cut
5672:
5673: sub start_page {
1.309 albertel 5674: my ($title,$head_extra,$args) = @_;
1.318 albertel 5675: #&Apache::lonnet::logthis("start_page ".join(':',caller(0)));
1.313 albertel 5676: my %head_args;
1.352 albertel 5677: foreach my $arg ('redirect','force_register','domain','function',
1.460 albertel 5678: 'bgcolor','frameset','no_nav_bar','only_body',
5679: 'no_auto_mt_title') {
1.319 albertel 5680: if (defined($args->{$arg})) {
1.324 raeburn 5681: $head_args{$arg} = $args->{$arg};
1.319 albertel 5682: }
1.313 albertel 5683: }
1.319 albertel 5684:
1.315 albertel 5685: $env{'internal.start_page'}++;
1.338 albertel 5686: my $result;
5687: if (! exists($args->{'skip_phases'}{'head'}) ) {
5688: $result.=
1.341 albertel 5689: &xml_begin().
1.338 albertel 5690: &headtag($title,$head_extra,\%head_args).&endheadtag();
5691: }
5692:
5693: if (! exists($args->{'skip_phases'}{'body'}) ) {
5694: if ($args->{'frameset'}) {
5695: my $attr_string = &make_attr_string($args->{'force_register'},
5696: $args->{'add_entries'});
5697: $result .= "\n<frameset $attr_string>\n";
5698: } else {
5699: $result .=
5700: &bodytag($title,
5701: $args->{'function'}, $args->{'add_entries'},
5702: $args->{'only_body'}, $args->{'domain'},
5703: $args->{'force_register'}, $args->{'body_title'},
5704: $args->{'no_nav_bar'}, $args->{'bgcolor'},
1.460 albertel 5705: $args->{'no_title'}, $args->{'no_inline_link'},
5706: $args);
1.338 albertel 5707: }
1.330 albertel 5708: }
1.338 albertel 5709:
1.315 albertel 5710: if ($args->{'js_ready'}) {
1.317 albertel 5711: $result = &js_ready($result);
1.315 albertel 5712: }
1.320 albertel 5713: if ($args->{'html_encode'}) {
5714: $result = &html_encode($result);
5715: }
1.315 albertel 5716: return $result;
1.306 albertel 5717: }
5718:
1.330 albertel 5719:
1.306 albertel 5720: =pod
5721:
5722: =item * &head()
5723:
5724: Returns a complete </body></html> section for LON-CAPA web pages.
5725:
1.315 albertel 5726: Inputs: $args - additional optional args supported are:
5727: js_ready -> return a string ready for being used in
5728: a javascript writeln
1.320 albertel 5729: html_encode -> return a string ready for being used in
5730: a html attribute
1.330 albertel 5731: frameset -> if true will start with a <frameset>
5732: rather than <body>
1.493 albertel 5733: dicsussion -> if true will get discussion from
5734: lonxml::xmlend
5735: (you can pass the target and parser arguments
5736: through optional 'target' and 'parser' args
5737: to this routine)
1.306 albertel 5738:
5739: =cut
5740:
5741: sub end_page {
1.315 albertel 5742: my ($args) = @_;
5743: $env{'internal.end_page'}++;
1.330 albertel 5744: my $result;
1.335 albertel 5745: if ($args->{'discussion'}) {
5746: my ($target,$parser);
5747: if (ref($args->{'discussion'})) {
5748: ($target,$parser) =($args->{'discussion'}{'target'},
5749: $args->{'discussion'}{'parser'});
5750: }
5751: $result .= &Apache::lonxml::xmlend($target,$parser);
5752: }
5753:
1.330 albertel 5754: if ($args->{'frameset'}) {
5755: $result .= '</frameset>';
5756: } else {
1.635 raeburn 5757: $result .= &endbodytag($args);
1.330 albertel 5758: }
5759: $result .= "\n</html>";
5760:
1.315 albertel 5761: if ($args->{'js_ready'}) {
1.317 albertel 5762: $result = &js_ready($result);
1.315 albertel 5763: }
1.335 albertel 5764:
1.320 albertel 5765: if ($args->{'html_encode'}) {
5766: $result = &html_encode($result);
5767: }
1.335 albertel 5768:
1.315 albertel 5769: return $result;
5770: }
5771:
1.320 albertel 5772: sub html_encode {
5773: my ($result) = @_;
5774:
1.322 albertel 5775: $result = &HTML::Entities::encode($result,'<>&"');
1.320 albertel 5776:
5777: return $result;
5778: }
1.317 albertel 5779: sub js_ready {
5780: my ($result) = @_;
5781:
1.323 albertel 5782: $result =~ s/[\n\r]/ /xmsg;
5783: $result =~ s/\\/\\\\/xmsg;
5784: $result =~ s/'/\\'/xmsg;
1.372 albertel 5785: $result =~ s{</}{<\\/}xmsg;
1.317 albertel 5786:
5787: return $result;
5788: }
5789:
1.315 albertel 5790: sub validate_page {
5791: if ( exists($env{'internal.start_page'})
1.316 albertel 5792: && $env{'internal.start_page'} > 1) {
5793: &Apache::lonnet::logthis('start_page called multiple times '.
1.318 albertel 5794: $env{'internal.start_page'}.' '.
1.316 albertel 5795: $ENV{'request.filename'});
1.315 albertel 5796: }
5797: if ( exists($env{'internal.end_page'})
1.316 albertel 5798: && $env{'internal.end_page'} > 1) {
5799: &Apache::lonnet::logthis('end_page called multiple times '.
1.318 albertel 5800: $env{'internal.end_page'}.' '.
1.316 albertel 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('start_page called without end_page '.
5806: $env{'request.filename'});
1.315 albertel 5807: }
5808: if ( ! exists($env{'internal.start_page'})
5809: && exists($env{'internal.end_page'})) {
1.316 albertel 5810: &Apache::lonnet::logthis('end_page called without start_page'.
5811: $env{'request.filename'});
1.315 albertel 5812: }
1.306 albertel 5813: }
1.315 albertel 5814:
1.318 albertel 5815: sub simple_error_page {
5816: my ($r,$title,$msg) = @_;
5817: my $page =
5818: &Apache::loncommon::start_page($title).
5819: &mt($msg).
5820: &Apache::loncommon::end_page();
5821: if (ref($r)) {
5822: $r->print($page);
1.327 albertel 5823: return;
1.318 albertel 5824: }
5825: return $page;
5826: }
1.347 albertel 5827:
5828: {
1.610 albertel 5829: my @row_count;
1.347 albertel 5830: sub start_data_table {
1.422 albertel 5831: my ($add_class) = @_;
5832: my $css_class = (join(' ','LC_data_table',$add_class));
1.610 albertel 5833: unshift(@row_count,0);
1.422 albertel 5834: return '<table class="'.$css_class.'">'."\n";
1.347 albertel 5835: }
5836:
5837: sub end_data_table {
1.610 albertel 5838: shift(@row_count);
1.389 albertel 5839: return '</table>'."\n";;
1.347 albertel 5840: }
5841:
5842: sub start_data_table_row {
1.422 albertel 5843: my ($add_class) = @_;
1.610 albertel 5844: $row_count[0]++;
5845: my $css_class = ($row_count[0] % 2)?'LC_odd_row':'LC_even_row';
1.428 albertel 5846: $css_class = (join(' ',$css_class,$add_class));
1.422 albertel 5847: return '<tr class="'.$css_class.'">'."\n";;
1.347 albertel 5848: }
1.471 banghart 5849:
5850: sub continue_data_table_row {
5851: my ($add_class) = @_;
1.610 albertel 5852: my $css_class = ($row_count[0] % 2)?'LC_odd_row':'LC_even_row';
1.471 banghart 5853: $css_class = (join(' ',$css_class,$add_class));
5854: return '<tr class="'.$css_class.'">'."\n";;
5855: }
1.347 albertel 5856:
5857: sub end_data_table_row {
1.389 albertel 5858: return '</tr>'."\n";;
1.347 albertel 5859: }
1.367 www 5860:
1.421 albertel 5861: sub start_data_table_empty_row {
1.610 albertel 5862: $row_count[0]++;
1.421 albertel 5863: return '<tr class="LC_empty_row" >'."\n";;
5864: }
5865:
5866: sub end_data_table_empty_row {
5867: return '</tr>'."\n";;
5868: }
5869:
1.367 www 5870: sub start_data_table_header_row {
1.389 albertel 5871: return '<tr class="LC_header_row">'."\n";;
1.367 www 5872: }
5873:
5874: sub end_data_table_header_row {
1.389 albertel 5875: return '</tr>'."\n";;
1.367 www 5876: }
1.347 albertel 5877: }
5878:
1.548 albertel 5879: =pod
5880:
5881: =item * &inhibit_menu_check($arg)
5882:
5883: Checks for a inhibitmenu state and generates output to preserve it
5884:
5885: Inputs: $arg - can be any of
5886: - undef - in which case the return value is a string
5887: to add into arguments list of a uri
5888: - 'input' - in which case the return value is a HTML
5889: <form> <input> field of type hidden to
5890: preserve the value
5891: - a url - in which case the return value is the url with
5892: the neccesary cgi args added to preserve the
5893: inhibitmenu state
5894: - a ref to a url - no return value, but the string is
5895: updated to include the neccessary cgi
5896: args to preserve the inhibitmenu state
5897:
5898: =cut
5899:
5900: sub inhibit_menu_check {
5901: my ($arg) = @_;
5902: &get_unprocessed_cgi($ENV{'QUERY_STRING'}, ['inhibitmenu']);
5903: if ($arg eq 'input') {
5904: if ($env{'form.inhibitmenu'}) {
5905: return '<input type="hidden" name="inhibitmenu" value="'.$env{'form.inhibitmenu'}.'" />';
5906: } else {
5907: return
5908: }
5909: }
5910: if ($env{'form.inhibitmenu'}) {
5911: if (ref($arg)) {
5912: $$arg .= '?inhibitmenu='.$env{'form.inhibitmenu'};
5913: } elsif ($arg eq '') {
5914: $arg .= 'inhibitmenu='.$env{'form.inhibitmenu'};
5915: } else {
5916: $arg .= '?inhibitmenu='.$env{'form.inhibitmenu'};
5917: }
5918: }
5919: if (!ref($arg)) {
5920: return $arg;
5921: }
5922: }
5923:
1.251 albertel 5924: ###############################################
1.182 matthew 5925:
5926: =pod
5927:
1.549 albertel 5928: =back
5929:
5930: =head1 User Information Routines
5931:
5932: =over 4
5933:
1.405 albertel 5934: =item * &get_users_function()
1.182 matthew 5935:
5936: Used by &bodytag to determine the current users primary role.
5937: Returns either 'student','coordinator','admin', or 'author'.
5938:
5939: =cut
5940:
5941: ###############################################
5942: sub get_users_function {
5943: my $function = 'student';
1.258 albertel 5944: if ($env{'request.role'}=~/^(cc|in|ta|ep)/) {
1.182 matthew 5945: $function='coordinator';
5946: }
1.258 albertel 5947: if ($env{'request.role'}=~/^(su|dc|ad|li)/) {
1.182 matthew 5948: $function='admin';
5949: }
1.258 albertel 5950: if (($env{'request.role'}=~/^(au|ca)/) ||
1.182 matthew 5951: ($ENV{'REQUEST_URI'}=~/^(\/priv|\~)/)) {
5952: $function='author';
5953: }
5954: return $function;
1.54 www 5955: }
1.99 www 5956:
5957: ###############################################
5958:
1.233 raeburn 5959: =pod
5960:
1.542 raeburn 5961: =item * &check_user_status()
1.274 raeburn 5962:
5963: Determines current status of supplied role for a
5964: specific user. Roles can be active, previous or future.
5965:
5966: Inputs:
5967: user's domain, user's username, course's domain,
1.375 raeburn 5968: course's number, optional section ID.
1.274 raeburn 5969:
5970: Outputs:
5971: role status: active, previous or future.
5972:
5973: =cut
5974:
5975: sub check_user_status {
1.412 raeburn 5976: my ($udom,$uname,$cdom,$crs,$role,$sec) = @_;
1.274 raeburn 5977: my %userinfo = &Apache::lonnet::dump('roles',$udom,$uname);
5978: my @uroles = keys %userinfo;
5979: my $srchstr;
5980: my $active_chk = 'none';
1.412 raeburn 5981: my $now = time;
1.274 raeburn 5982: if (@uroles > 0) {
1.412 raeburn 5983: if (($role eq 'cc') || ($sec eq '') || (!defined($sec))) {
1.274 raeburn 5984: $srchstr = '/'.$cdom.'/'.$crs.'_'.$role;
5985: } else {
1.412 raeburn 5986: $srchstr = '/'.$cdom.'/'.$crs.'/'.$sec.'_'.$role;
5987: }
5988: if (grep/^\Q$srchstr\E$/,@uroles) {
1.274 raeburn 5989: my $role_end = 0;
5990: my $role_start = 0;
5991: $active_chk = 'active';
1.412 raeburn 5992: if ($userinfo{$srchstr} =~ m/^\Q$role\E_(\d+)/) {
5993: $role_end = $1;
5994: if ($userinfo{$srchstr} =~ m/^\Q$role\E_\Q$role_end\E_(\d+)$/) {
5995: $role_start = $1;
1.274 raeburn 5996: }
5997: }
5998: if ($role_start > 0) {
1.412 raeburn 5999: if ($now < $role_start) {
1.274 raeburn 6000: $active_chk = 'future';
6001: }
6002: }
6003: if ($role_end > 0) {
1.412 raeburn 6004: if ($now > $role_end) {
1.274 raeburn 6005: $active_chk = 'previous';
6006: }
6007: }
6008: }
6009: }
6010: return $active_chk;
6011: }
6012:
6013: ###############################################
6014:
6015: =pod
6016:
1.405 albertel 6017: =item * &get_sections()
1.233 raeburn 6018:
6019: Determines all the sections for a course including
6020: sections with students and sections containing other roles.
1.419 raeburn 6021: Incoming parameters:
6022:
6023: 1. domain
6024: 2. course number
6025: 3. reference to array containing roles for which sections should
6026: be gathered (optional).
6027: 4. reference to array containing status types for which sections
6028: should be gathered (optional).
6029:
6030: If the third argument is undefined, sections are gathered for any role.
6031: If the fourth argument is undefined, sections are gathered for any status.
6032: Permissible values are 'active' or 'future' or 'previous'.
1.233 raeburn 6033:
1.374 raeburn 6034: Returns section hash (keys are section IDs, values are
6035: number of users in each section), subject to the
1.419 raeburn 6036: optional roles filter, optional status filter
1.233 raeburn 6037:
6038: =cut
6039:
6040: ###############################################
6041: sub get_sections {
1.419 raeburn 6042: my ($cdom,$cnum,$possible_roles,$possible_status) = @_;
1.366 albertel 6043: if (!defined($cdom) || !defined($cnum)) {
6044: my $cid = $env{'request.course.id'};
6045:
6046: return if (!defined($cid));
6047:
6048: $cdom = $env{'course.'.$cid.'.domain'};
6049: $cnum = $env{'course.'.$cid.'.num'};
6050: }
6051:
6052: my %sectioncount;
1.419 raeburn 6053: my $now = time;
1.240 albertel 6054:
1.366 albertel 6055: if (!defined($possible_roles) || (grep(/^st$/,@$possible_roles))) {
1.276 albertel 6056: my ($classlist) = &Apache::loncoursedata::get_classlist($cdom,$cnum);
1.240 albertel 6057: my $sec_index = &Apache::loncoursedata::CL_SECTION();
6058: my $status_index = &Apache::loncoursedata::CL_STATUS();
1.419 raeburn 6059: my $start_index = &Apache::loncoursedata::CL_START();
6060: my $end_index = &Apache::loncoursedata::CL_END();
6061: my $status;
1.366 albertel 6062: while (my ($student,$data) = each(%$classlist)) {
1.419 raeburn 6063: my ($section,$stu_status,$start,$end) = ($data->[$sec_index],
6064: $data->[$status_index],
6065: $data->[$start_index],
6066: $data->[$end_index]);
6067: if ($stu_status eq 'Active') {
6068: $status = 'active';
6069: } elsif ($end < $now) {
6070: $status = 'previous';
6071: } elsif ($start > $now) {
6072: $status = 'future';
6073: }
6074: if ($section ne '-1' && $section !~ /^\s*$/) {
6075: if ((!defined($possible_status)) || (($status ne '') &&
6076: (grep/^\Q$status\E$/,@{$possible_status}))) {
6077: $sectioncount{$section}++;
6078: }
1.240 albertel 6079: }
6080: }
6081: }
6082: my %courseroles = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum);
6083: foreach my $user (sort(keys(%courseroles))) {
6084: if ($user !~ /^(\w{2})/) { next; }
6085: my ($role) = ($user =~ /^(\w{2})/);
6086: if ($possible_roles && !(grep(/^$role$/,@$possible_roles))) { next; }
1.419 raeburn 6087: my ($section,$status);
1.240 albertel 6088: if ($role eq 'cr' &&
6089: $user =~ m-^$role/[^/]*/[^/]*/[^/]*:[^:]*:[^:]*:(\w+)-) {
6090: $section=$1;
6091: }
6092: if ($user =~ /^$role:[^:]*:[^:]*:(\w+)/) { $section=$1; }
6093: if (!defined($section) || $section eq '-1') { next; }
1.419 raeburn 6094: my ($end,$start) = ($courseroles{$user} =~ /^([^:]*):([^:]*)$/);
6095: if ($end == -1 && $start == -1) {
6096: next; #deleted role
6097: }
6098: if (!defined($possible_status)) {
6099: $sectioncount{$section}++;
6100: } else {
6101: if ((!$end || $end >= $now) && (!$start || $start <= $now)) {
6102: $status = 'active';
6103: } elsif ($end < $now) {
6104: $status = 'future';
6105: } elsif ($start > $now) {
6106: $status = 'previous';
6107: }
6108: if (($status ne '') && (grep/^\Q$status\E$/,@{$possible_status})) {
6109: $sectioncount{$section}++;
6110: }
6111: }
1.233 raeburn 6112: }
1.366 albertel 6113: return %sectioncount;
1.233 raeburn 6114: }
6115:
1.274 raeburn 6116: ###############################################
1.294 raeburn 6117:
6118: =pod
1.405 albertel 6119:
6120: =item * &get_course_users()
6121:
1.275 raeburn 6122: Retrieves usernames:domains for users in the specified course
6123: with specific role(s), and access status.
6124:
6125: Incoming parameters:
1.277 albertel 6126: 1. course domain
6127: 2. course number
6128: 3. access status: users must have - either active,
1.275 raeburn 6129: previous, future, or all.
1.277 albertel 6130: 4. reference to array of permissible roles
1.288 raeburn 6131: 5. reference to array of section restrictions (optional)
6132: 6. reference to results object (hash of hashes).
6133: 7. reference to optional userdata hash
1.609 raeburn 6134: 8. reference to optional statushash
1.630 raeburn 6135: 9. flag if privileged users (except those set to unhide in
6136: course settings) should be excluded
1.609 raeburn 6137: Keys of top level results hash are roles.
1.275 raeburn 6138: Keys of inner hashes are username:domain, with
6139: values set to access type.
1.288 raeburn 6140: Optional userdata hash returns an array with arguments in the
6141: same order as loncoursedata::get_classlist() for student data.
6142:
1.609 raeburn 6143: Optional statushash returns
6144:
1.288 raeburn 6145: Entries for end, start, section and status are blank because
6146: of the possibility of multiple values for non-student roles.
6147:
1.275 raeburn 6148: =cut
1.405 albertel 6149:
1.275 raeburn 6150: ###############################################
1.405 albertel 6151:
1.275 raeburn 6152: sub get_course_users {
1.630 raeburn 6153: my ($cdom,$cnum,$types,$roles,$sections,$users,$userdata,$statushash,$hidepriv) = @_;
1.288 raeburn 6154: my %idx = ();
1.419 raeburn 6155: my %seclists;
1.288 raeburn 6156:
6157: $idx{udom} = &Apache::loncoursedata::CL_SDOM();
6158: $idx{uname} = &Apache::loncoursedata::CL_SNAME();
6159: $idx{end} = &Apache::loncoursedata::CL_END();
6160: $idx{start} = &Apache::loncoursedata::CL_START();
6161: $idx{id} = &Apache::loncoursedata::CL_ID();
6162: $idx{section} = &Apache::loncoursedata::CL_SECTION();
6163: $idx{fullname} = &Apache::loncoursedata::CL_FULLNAME();
6164: $idx{status} = &Apache::loncoursedata::CL_STATUS();
6165:
1.290 albertel 6166: if (grep(/^st$/,@{$roles})) {
1.276 albertel 6167: my ($classlist,$keylist)=&Apache::loncoursedata::get_classlist($cdom,$cnum);
1.278 raeburn 6168: my $now = time;
1.277 albertel 6169: foreach my $student (keys(%{$classlist})) {
1.288 raeburn 6170: my $match = 0;
1.412 raeburn 6171: my $secmatch = 0;
1.419 raeburn 6172: my $section = $$classlist{$student}[$idx{section}];
1.609 raeburn 6173: my $status = $$classlist{$student}[$idx{status}];
1.419 raeburn 6174: if ($section eq '') {
6175: $section = 'none';
6176: }
1.291 albertel 6177: if ((ref($sections) eq 'ARRAY') && (@{$sections} > 0)) {
1.420 albertel 6178: if (grep(/^all$/,@{$sections})) {
1.412 raeburn 6179: $secmatch = 1;
6180: } elsif ($$classlist{$student}[$idx{section}] eq '') {
1.420 albertel 6181: if (grep(/^none$/,@{$sections})) {
1.412 raeburn 6182: $secmatch = 1;
6183: }
6184: } else {
1.419 raeburn 6185: if (grep(/^\Q$section\E$/,@{$sections})) {
1.412 raeburn 6186: $secmatch = 1;
6187: }
1.290 albertel 6188: }
1.412 raeburn 6189: if (!$secmatch) {
6190: next;
6191: }
1.419 raeburn 6192: }
1.275 raeburn 6193: if (defined($$types{'active'})) {
1.288 raeburn 6194: if ($$classlist{$student}[$idx{status}] eq 'Active') {
1.275 raeburn 6195: push(@{$$users{st}{$student}},'active');
1.288 raeburn 6196: $match = 1;
1.275 raeburn 6197: }
6198: }
6199: if (defined($$types{'previous'})) {
1.609 raeburn 6200: if ($$classlist{$student}[$idx{status}] eq 'Expired') {
1.275 raeburn 6201: push(@{$$users{st}{$student}},'previous');
1.288 raeburn 6202: $match = 1;
1.275 raeburn 6203: }
6204: }
6205: if (defined($$types{'future'})) {
1.609 raeburn 6206: if ($$classlist{$student}[$idx{status}] eq 'Future') {
1.275 raeburn 6207: push(@{$$users{st}{$student}},'future');
1.288 raeburn 6208: $match = 1;
1.275 raeburn 6209: }
6210: }
1.609 raeburn 6211: if ($match) {
6212: push(@{$seclists{$student}},$section);
6213: if (ref($userdata) eq 'HASH') {
6214: $$userdata{$student} = $$classlist{$student};
6215: }
6216: if (ref($statushash) eq 'HASH') {
6217: $statushash->{$student}{'st'}{$section} = $status;
6218: }
1.288 raeburn 6219: }
1.275 raeburn 6220: }
6221: }
1.412 raeburn 6222: if ((@{$roles} > 1) || ((@{$roles} == 1) && ($$roles[0] ne "st"))) {
1.439 raeburn 6223: my %coursepersonnel = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum);
6224: my $now = time;
1.609 raeburn 6225: my %displaystatus = ( previous => 'Expired',
6226: active => 'Active',
6227: future => 'Future',
6228: );
1.630 raeburn 6229: my %nothide;
6230: if ($hidepriv) {
6231: my %coursehash=&Apache::lonnet::coursedescription($cdom.'_'.$cnum);
6232: foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
6233: if ($user !~ /:/) {
6234: $nothide{join(':',split(/[\@]/,$user))}=1;
6235: } else {
6236: $nothide{$user} = 1;
6237: }
6238: }
6239: }
1.439 raeburn 6240: foreach my $person (sort(keys(%coursepersonnel))) {
1.288 raeburn 6241: my $match = 0;
1.412 raeburn 6242: my $secmatch = 0;
1.439 raeburn 6243: my $status;
1.412 raeburn 6244: my ($role,$user,$usec) = ($person =~ /^([^:]*):([^:]+:[^:]+):([^:]*)/);
1.275 raeburn 6245: $user =~ s/:$//;
1.439 raeburn 6246: my ($end,$start) = split(/:/,$coursepersonnel{$person});
6247: if ($end == -1 || $start == -1) {
6248: next;
6249: }
6250: if (($role) && ((grep(/^\Q$role\E$/,@{$roles})) ||
6251: (grep(/^cr$/,@{$roles}) && $role =~ /^cr\//))) {
1.412 raeburn 6252: my ($uname,$udom) = split(/:/,$user);
6253: if ((ref($sections) eq 'ARRAY') && (@{$sections} > 0)) {
1.420 albertel 6254: if (grep(/^all$/,@{$sections})) {
1.412 raeburn 6255: $secmatch = 1;
6256: } elsif ($usec eq '') {
1.420 albertel 6257: if (grep(/^none$/,@{$sections})) {
1.412 raeburn 6258: $secmatch = 1;
6259: }
6260: } else {
6261: if (grep(/^\Q$usec\E$/,@{$sections})) {
6262: $secmatch = 1;
6263: }
6264: }
6265: if (!$secmatch) {
6266: next;
6267: }
1.288 raeburn 6268: }
1.419 raeburn 6269: if ($usec eq '') {
6270: $usec = 'none';
6271: }
1.275 raeburn 6272: if ($uname ne '' && $udom ne '') {
1.630 raeburn 6273: if ($hidepriv) {
6274: if ((&Apache::lonnet::privileged($uname,$udom)) &&
6275: (!$nothide{$uname.':'.$udom})) {
6276: next;
6277: }
6278: }
1.503 raeburn 6279: if ($end > 0 && $end < $now) {
1.439 raeburn 6280: $status = 'previous';
6281: } elsif ($start > $now) {
6282: $status = 'future';
6283: } else {
6284: $status = 'active';
6285: }
1.277 albertel 6286: foreach my $type (keys(%{$types})) {
1.275 raeburn 6287: if ($status eq $type) {
1.420 albertel 6288: if (!grep(/^\Q$type\E$/,@{$$users{$role}{$user}})) {
1.419 raeburn 6289: push(@{$$users{$role}{$user}},$type);
6290: }
1.288 raeburn 6291: $match = 1;
6292: }
6293: }
1.419 raeburn 6294: if (($match) && (ref($userdata) eq 'HASH')) {
6295: if (!exists($$userdata{$uname.':'.$udom})) {
6296: &get_user_info($udom,$uname,\%idx,$userdata);
6297: }
1.420 albertel 6298: if (!grep(/^\Q$usec\E$/,@{$seclists{$uname.':'.$udom}})) {
1.419 raeburn 6299: push(@{$seclists{$uname.':'.$udom}},$usec);
6300: }
1.609 raeburn 6301: if (ref($statushash) eq 'HASH') {
6302: $statushash->{$uname.':'.$udom}{$role}{$usec} = $displaystatus{$status};
6303: }
1.275 raeburn 6304: }
6305: }
6306: }
6307: }
1.290 albertel 6308: if (grep(/^ow$/,@{$roles})) {
1.279 raeburn 6309: if ((defined($cdom)) && (defined($cnum))) {
6310: my %csettings = &Apache::lonnet::get('environment',['internal.courseowner'],$cdom,$cnum);
6311: if ( defined($csettings{'internal.courseowner'}) ) {
6312: my $owner = $csettings{'internal.courseowner'};
1.609 raeburn 6313: next if ($owner eq '');
6314: my ($ownername,$ownerdom);
6315: if ($owner =~ /^([^:]+):([^:]+)$/) {
6316: $ownername = $1;
6317: $ownerdom = $2;
6318: } else {
6319: $ownername = $owner;
6320: $ownerdom = $cdom;
6321: $owner = $ownername.':'.$ownerdom;
1.439 raeburn 6322: }
6323: @{$$users{'ow'}{$owner}} = 'any';
1.290 albertel 6324: if (defined($userdata) &&
1.609 raeburn 6325: !exists($$userdata{$owner})) {
6326: &get_user_info($ownerdom,$ownername,\%idx,$userdata);
6327: if (!grep(/^none$/,@{$seclists{$owner}})) {
6328: push(@{$seclists{$owner}},'none');
6329: }
6330: if (ref($statushash) eq 'HASH') {
6331: $statushash->{$owner}{'ow'}{'none'} = 'Any';
1.419 raeburn 6332: }
1.290 albertel 6333: }
1.279 raeburn 6334: }
6335: }
6336: }
1.419 raeburn 6337: foreach my $user (keys(%seclists)) {
6338: @{$seclists{$user}} = (sort {$a <=> $b} @{$seclists{$user}});
6339: $$userdata{$user}[$idx{section}] = join(',',@{$seclists{$user}});
6340: }
1.275 raeburn 6341: }
6342: return;
6343: }
6344:
1.288 raeburn 6345: sub get_user_info {
6346: my ($udom,$uname,$idx,$userdata) = @_;
1.289 albertel 6347: $$userdata{$uname.':'.$udom}[$$idx{fullname}] =
6348: &plainname($uname,$udom,'lastname');
1.291 albertel 6349: $$userdata{$uname.':'.$udom}[$$idx{uname}] = $uname;
1.297 raeburn 6350: $$userdata{$uname.':'.$udom}[$$idx{udom}] = $udom;
1.609 raeburn 6351: my %idhash = &Apache::lonnet::idrget($udom,($uname));
6352: $$userdata{$uname.':'.$udom}[$$idx{id}] = $idhash{$uname};
1.288 raeburn 6353: return;
6354: }
1.275 raeburn 6355:
1.472 raeburn 6356: ###############################################
6357:
6358: =pod
6359:
6360: =item * &get_user_quota()
6361:
6362: Retrieves quota assigned for storage of portfolio files for a user
6363:
6364: Incoming parameters:
6365: 1. user's username
6366: 2. user's domain
6367:
6368: Returns:
1.536 raeburn 6369: 1. Disk quota (in Mb) assigned to student.
6370: 2. (Optional) Type of setting: custom or default
6371: (individually assigned or default for user's
6372: institutional status).
6373: 3. (Optional) - User's institutional status (e.g., faculty, staff
6374: or student - types as defined in localenroll::inst_usertypes
6375: for user's domain, which determines default quota for user.
6376: 4. (Optional) - Default quota which would apply to the user.
1.472 raeburn 6377:
6378: If a value has been stored in the user's environment,
1.536 raeburn 6379: it will return that, otherwise it returns the maximal default
6380: defined for the user's instituional status(es) in the domain.
1.472 raeburn 6381:
6382: =cut
6383:
6384: ###############################################
6385:
6386:
6387: sub get_user_quota {
6388: my ($uname,$udom) = @_;
1.536 raeburn 6389: my ($quota,$quotatype,$settingstatus,$defquota);
1.472 raeburn 6390: if (!defined($udom)) {
6391: $udom = $env{'user.domain'};
6392: }
6393: if (!defined($uname)) {
6394: $uname = $env{'user.name'};
6395: }
6396: if (($udom eq '' || $uname eq '') ||
6397: ($udom eq 'public') && ($uname eq 'public')) {
6398: $quota = 0;
1.536 raeburn 6399: $quotatype = 'default';
6400: $defquota = 0;
1.472 raeburn 6401: } else {
1.536 raeburn 6402: my $inststatus;
1.472 raeburn 6403: if ($udom eq $env{'user.domain'} && $uname eq $env{'user.name'}) {
6404: $quota = $env{'environment.portfolioquota'};
1.536 raeburn 6405: $inststatus = $env{'environment.inststatus'};
1.472 raeburn 6406: } else {
1.536 raeburn 6407: my %userenv =
6408: &Apache::lonnet::get('environment',['portfolioquota',
6409: 'inststatus'],$udom,$uname);
1.472 raeburn 6410: my ($tmp) = keys(%userenv);
6411: if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
6412: $quota = $userenv{'portfolioquota'};
1.536 raeburn 6413: $inststatus = $userenv{'inststatus'};
1.472 raeburn 6414: } else {
6415: undef(%userenv);
6416: }
6417: }
1.536 raeburn 6418: ($defquota,$settingstatus) = &default_quota($udom,$inststatus);
1.472 raeburn 6419: if ($quota eq '') {
1.536 raeburn 6420: $quota = $defquota;
6421: $quotatype = 'default';
6422: } else {
6423: $quotatype = 'custom';
1.472 raeburn 6424: }
6425: }
1.536 raeburn 6426: if (wantarray) {
6427: return ($quota,$quotatype,$settingstatus,$defquota);
6428: } else {
6429: return $quota;
6430: }
1.472 raeburn 6431: }
6432:
6433: ###############################################
6434:
6435: =pod
6436:
6437: =item * &default_quota()
6438:
1.536 raeburn 6439: Retrieves default quota assigned for storage of user portfolio files,
6440: given an (optional) user's institutional status.
1.472 raeburn 6441:
6442: Incoming parameters:
6443: 1. domain
1.536 raeburn 6444: 2. (Optional) institutional status(es). This is a : separated list of
6445: status types (e.g., faculty, staff, student etc.)
6446: which apply to the user for whom the default is being retrieved.
6447: If the institutional status string in undefined, the domain
6448: default quota will be returned.
1.472 raeburn 6449:
6450: Returns:
6451: 1. Default disk quota (in Mb) for user portfolios in the domain.
1.536 raeburn 6452: 2. (Optional) institutional type which determined the value of the
6453: default quota.
1.472 raeburn 6454:
6455: If a value has been stored in the domain's configuration db,
6456: it will return that, otherwise it returns 20 (for backwards
6457: compatibility with domains which have not set up a configuration
6458: db file; the original statically defined portfolio quota was 20 Mb).
6459:
1.536 raeburn 6460: If the user's status includes multiple types (e.g., staff and student),
6461: the largest default quota which applies to the user determines the
6462: default quota returned.
6463:
1.472 raeburn 6464: =cut
6465:
6466: ###############################################
6467:
6468:
6469: sub default_quota {
1.536 raeburn 6470: my ($udom,$inststatus) = @_;
6471: my ($defquota,$settingstatus);
6472: my %quotahash = &Apache::lonnet::get_dom('configuration',
1.622 raeburn 6473: ['quotas'],$udom);
6474: if (ref($quotahash{'quotas'}) eq 'HASH') {
1.536 raeburn 6475: if ($inststatus ne '') {
6476: my @statuses = split(/:/,$inststatus);
6477: foreach my $item (@statuses) {
1.622 raeburn 6478: if ($quotahash{'quotas'}{$item} ne '') {
1.536 raeburn 6479: if ($defquota eq '') {
1.622 raeburn 6480: $defquota = $quotahash{'quotas'}{$item};
1.536 raeburn 6481: $settingstatus = $item;
1.622 raeburn 6482: } elsif ($quotahash{'quotas'}{$item} > $defquota) {
6483: $defquota = $quotahash{'quotas'}{$item};
1.536 raeburn 6484: $settingstatus = $item;
6485: }
6486: }
6487: }
6488: }
6489: if ($defquota eq '') {
1.622 raeburn 6490: $defquota = $quotahash{'quotas'}{'default'};
1.536 raeburn 6491: $settingstatus = 'default';
6492: }
6493: } else {
6494: $settingstatus = 'default';
6495: $defquota = 20;
6496: }
6497: if (wantarray) {
6498: return ($defquota,$settingstatus);
1.472 raeburn 6499: } else {
1.536 raeburn 6500: return $defquota;
1.472 raeburn 6501: }
6502: }
6503:
1.384 raeburn 6504: sub get_secgrprole_info {
6505: my ($cdom,$cnum,$needroles,$type) = @_;
6506: my %sections_count = &get_sections($cdom,$cnum);
6507: my @sections = (sort {$a <=> $b} keys(%sections_count));
6508: my %curr_groups = &Apache::longroup::coursegroups($cdom,$cnum);
6509: my @groups = sort(keys(%curr_groups));
6510: my $allroles = [];
6511: my $rolehash;
6512: my $accesshash = {
6513: active => 'Currently has access',
6514: future => 'Will have future access',
6515: previous => 'Previously had access',
6516: };
6517: if ($needroles) {
6518: $rolehash = {'all' => 'all'};
1.385 albertel 6519: my %user_roles = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum);
6520: if (&Apache::lonnet::error(%user_roles)) {
6521: undef(%user_roles);
6522: }
6523: foreach my $item (keys(%user_roles)) {
1.384 raeburn 6524: my ($role)=split(/\:/,$item,2);
6525: if ($role eq 'cr') { next; }
6526: if ($role =~ /^cr/) {
6527: $$rolehash{$role} = (split('/',$role))[3];
6528: } else {
6529: $$rolehash{$role} = &Apache::lonnet::plaintext($role,$type);
6530: }
6531: }
6532: foreach my $key (sort(keys(%{$rolehash}))) {
6533: push(@{$allroles},$key);
6534: }
6535: push (@{$allroles},'st');
6536: $$rolehash{'st'} = &Apache::lonnet::plaintext('st',$type);
6537: }
6538: return (\@sections,\@groups,$allroles,$rolehash,$accesshash);
6539: }
6540:
1.555 raeburn 6541: sub user_picker {
1.627 raeburn 6542: my ($dom,$srch,$forcenewuser,$caller,$cancreate,$usertype) = @_;
1.555 raeburn 6543: my $currdom = $dom;
6544: my %curr_selected = (
6545: srchin => 'dom',
1.580 raeburn 6546: srchby => 'lastname',
1.555 raeburn 6547: );
6548: my $srchterm;
1.625 raeburn 6549: if ((ref($srch) eq 'HASH') && ($env{'form.origform'} ne 'crtusername')) {
1.555 raeburn 6550: if ($srch->{'srchby'} ne '') {
6551: $curr_selected{'srchby'} = $srch->{'srchby'};
6552: }
6553: if ($srch->{'srchin'} ne '') {
6554: $curr_selected{'srchin'} = $srch->{'srchin'};
6555: }
6556: if ($srch->{'srchtype'} ne '') {
6557: $curr_selected{'srchtype'} = $srch->{'srchtype'};
6558: }
6559: if ($srch->{'srchdomain'} ne '') {
6560: $currdom = $srch->{'srchdomain'};
6561: }
6562: $srchterm = $srch->{'srchterm'};
6563: }
6564: my %lt=&Apache::lonlocal::texthash(
1.573 raeburn 6565: 'usr' => 'Search criteria',
1.563 raeburn 6566: 'doma' => 'Domain/institution to search',
1.558 albertel 6567: 'uname' => 'username',
6568: 'lastname' => 'last name',
1.555 raeburn 6569: 'lastfirst' => 'last name, first name',
1.558 albertel 6570: 'crs' => 'in this course',
1.576 raeburn 6571: 'dom' => 'in selected LON-CAPA domain',
1.558 albertel 6572: 'alc' => 'all LON-CAPA',
1.573 raeburn 6573: 'instd' => 'in institutional directory for selected domain',
1.558 albertel 6574: 'exact' => 'is',
6575: 'contains' => 'contains',
1.569 raeburn 6576: 'begins' => 'begins with',
1.571 raeburn 6577: 'youm' => "You must include some text to search for.",
6578: 'thte' => "The text you are searching for must contain at least two characters when using a 'begins' type search.",
6579: 'thet' => "The text you are searching for must contain at least three characters when using a 'contains' type search.",
6580: 'yomc' => "You must choose a domain when using an institutional directory search.",
6581: 'ymcd' => "You must choose a domain when using a domain search.",
6582: 'whus' => "When using searching by last,first you must include a comma as separator between last name and first name.",
6583: 'whse' => "When searching by last,first you must include at least one character in the first name.",
6584: 'thfo' => "The following need to be corrected before the search can be run:",
1.555 raeburn 6585: );
1.563 raeburn 6586: my $domform = &select_dom_form($currdom,'srchdomain',1,1);
6587: my $srchinsel = ' <select name="srchin">';
1.555 raeburn 6588:
6589: my @srchins = ('crs','dom','alc','instd');
6590:
6591: foreach my $option (@srchins) {
6592: # FIXME 'alc' option unavailable until
6593: # loncreateuser::print_user_query_page()
6594: # has been completed.
6595: next if ($option eq 'alc');
6596: next if ($option eq 'crs' && !$env{'request.course.id'});
1.563 raeburn 6597: if ($curr_selected{'srchin'} eq $option) {
6598: $srchinsel .= '
6599: <option value="'.$option.'" selected="selected">'.$lt{$option}.'</option>';
6600: } else {
6601: $srchinsel .= '
6602: <option value="'.$option.'">'.$lt{$option}.'</option>';
6603: }
1.555 raeburn 6604: }
1.563 raeburn 6605: $srchinsel .= "\n </select>\n";
1.555 raeburn 6606:
6607: my $srchbysel = ' <select name="srchby">';
1.580 raeburn 6608: foreach my $option ('lastname','lastfirst','uname') {
1.555 raeburn 6609: if ($curr_selected{'srchby'} eq $option) {
6610: $srchbysel .= '
6611: <option value="'.$option.'" selected="selected">'.$lt{$option}.'</option>';
6612: } else {
6613: $srchbysel .= '
6614: <option value="'.$option.'">'.$lt{$option}.'</option>';
6615: }
6616: }
6617: $srchbysel .= "\n </select>\n";
6618:
6619: my $srchtypesel = ' <select name="srchtype">';
1.580 raeburn 6620: foreach my $option ('begins','contains','exact') {
1.555 raeburn 6621: if ($curr_selected{'srchtype'} eq $option) {
6622: $srchtypesel .= '
6623: <option value="'.$option.'" selected="selected">'.$lt{$option}.'</option>';
6624: } else {
6625: $srchtypesel .= '
6626: <option value="'.$option.'">'.$lt{$option}.'</option>';
6627: }
6628: }
6629: $srchtypesel .= "\n </select>\n";
6630:
1.558 albertel 6631: my ($newuserscript,$new_user_create);
1.556 raeburn 6632:
6633: if ($forcenewuser) {
1.576 raeburn 6634: if (ref($srch) eq 'HASH') {
6635: if ($srch->{'srchby'} eq 'uname' && $srch->{'srchtype'} eq 'exact' && $srch->{'srchin'} eq 'dom' && $srch->{'srchdomain'} eq $env{'request.role.domain'}) {
1.627 raeburn 6636: if ($cancreate) {
6637: $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>';
6638: } else {
6639: my $helplink = ' href="javascript:helpMenu('."'display'".')"';
6640: my %usertypetext = (
6641: official => 'institutional',
6642: unofficial => 'non-institutional',
6643: );
6644: $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 />';
6645: }
1.576 raeburn 6646: }
6647: }
6648:
1.556 raeburn 6649: $newuserscript = <<"ENDSCRIPT";
6650:
1.570 raeburn 6651: function setSearch(createnew,callingForm) {
1.556 raeburn 6652: if (createnew == 1) {
1.570 raeburn 6653: for (var i=0; i<callingForm.srchby.length; i++) {
6654: if (callingForm.srchby.options[i].value == 'uname') {
6655: callingForm.srchby.selectedIndex = i;
1.556 raeburn 6656: }
6657: }
1.570 raeburn 6658: for (var i=0; i<callingForm.srchin.length; i++) {
6659: if ( callingForm.srchin.options[i].value == 'dom') {
6660: callingForm.srchin.selectedIndex = i;
1.556 raeburn 6661: }
6662: }
1.570 raeburn 6663: for (var i=0; i<callingForm.srchtype.length; i++) {
6664: if (callingForm.srchtype.options[i].value == 'exact') {
6665: callingForm.srchtype.selectedIndex = i;
1.556 raeburn 6666: }
6667: }
1.570 raeburn 6668: for (var i=0; i<callingForm.srchdomain.length; i++) {
6669: if (callingForm.srchdomain.options[i].value == '$env{'request.role.domain'}') {
6670: callingForm.srchdomain.selectedIndex = i;
1.556 raeburn 6671: }
6672: }
6673: }
6674: }
6675: ENDSCRIPT
1.558 albertel 6676:
1.556 raeburn 6677: }
6678:
1.555 raeburn 6679: my $output = <<"END_BLOCK";
1.556 raeburn 6680: <script type="text/javascript">
1.570 raeburn 6681: function validateEntry(callingForm) {
1.558 albertel 6682:
1.556 raeburn 6683: var checkok = 1;
1.558 albertel 6684: var srchin;
1.570 raeburn 6685: for (var i=0; i<callingForm.srchin.length; i++) {
6686: if ( callingForm.srchin[i].checked ) {
6687: srchin = callingForm.srchin[i].value;
1.558 albertel 6688: }
6689: }
6690:
1.570 raeburn 6691: var srchtype = callingForm.srchtype.options[callingForm.srchtype.selectedIndex].value;
6692: var srchby = callingForm.srchby.options[callingForm.srchby.selectedIndex].value;
6693: var srchdomain = callingForm.srchdomain.options[callingForm.srchdomain.selectedIndex].value;
6694: var srchterm = callingForm.srchterm.value;
6695: var srchin = callingForm.srchin.options[callingForm.srchin.selectedIndex].value;
1.556 raeburn 6696: var msg = "";
6697:
6698: if (srchterm == "") {
6699: checkok = 0;
1.571 raeburn 6700: msg += "$lt{'youm'}\\n";
1.556 raeburn 6701: }
6702:
1.569 raeburn 6703: if (srchtype== 'begins') {
6704: if (srchterm.length < 2) {
6705: checkok = 0;
1.571 raeburn 6706: msg += "$lt{'thte'}\\n";
1.569 raeburn 6707: }
6708: }
6709:
1.556 raeburn 6710: if (srchtype== 'contains') {
6711: if (srchterm.length < 3) {
6712: checkok = 0;
1.571 raeburn 6713: msg += "$lt{'thet'}\\n";
1.556 raeburn 6714: }
6715: }
6716: if (srchin == 'instd') {
6717: if (srchdomain == '') {
6718: checkok = 0;
1.571 raeburn 6719: msg += "$lt{'yomc'}\\n";
1.556 raeburn 6720: }
6721: }
6722: if (srchin == 'dom') {
6723: if (srchdomain == '') {
6724: checkok = 0;
1.571 raeburn 6725: msg += "$lt{'ymcd'}\\n";
1.556 raeburn 6726: }
6727: }
6728: if (srchby == 'lastfirst') {
6729: if (srchterm.indexOf(",") == -1) {
6730: checkok = 0;
1.571 raeburn 6731: msg += "$lt{'whus'}\\n";
1.556 raeburn 6732: }
6733: if (srchterm.indexOf(",") == srchterm.length -1) {
6734: checkok = 0;
1.571 raeburn 6735: msg += "$lt{'whse'}\\n";
1.556 raeburn 6736: }
6737: }
6738: if (checkok == 0) {
1.571 raeburn 6739: alert("$lt{'thfo'}\\n"+msg);
1.556 raeburn 6740: return;
6741: }
6742: if (checkok == 1) {
1.570 raeburn 6743: callingForm.submit();
1.556 raeburn 6744: }
6745: }
6746:
6747: $newuserscript
6748:
6749: </script>
1.558 albertel 6750:
6751: $new_user_create
6752:
1.555 raeburn 6753: <table>
1.558 albertel 6754: <tr>
1.573 raeburn 6755: <td>$lt{'doma'}:</td>
6756: <td>$domform</td>
6757: </td>
6758: </tr>
6759: <tr>
6760: <td>$lt{'usr'}:</td>
1.563 raeburn 6761: <td>$srchbysel
6762: $srchtypesel
6763: <input type="text" size="15" name="srchterm" value="$srchterm" />
1.564 albertel 6764: $srchinsel
1.563 raeburn 6765: </td>
6766: </tr>
1.555 raeburn 6767: </table>
6768: <br />
6769: END_BLOCK
1.558 albertel 6770:
1.555 raeburn 6771: return $output;
6772: }
6773:
1.612 raeburn 6774: sub user_rule_check {
1.615 raeburn 6775: my ($usershash,$checks,$alerts,$rulematch,$inst_results,$curr_rules,$got_rules) = @_;
1.612 raeburn 6776: my $response;
6777: if (ref($usershash) eq 'HASH') {
6778: foreach my $user (keys(%{$usershash})) {
6779: my ($uname,$udom) = split(/:/,$user);
6780: next if ($udom eq '' || $uname eq '');
1.615 raeburn 6781: my ($id,$newuser);
1.612 raeburn 6782: if (ref($usershash->{$user}) eq 'HASH') {
1.615 raeburn 6783: $newuser = $usershash->{$user}->{'newuser'};
1.612 raeburn 6784: $id = $usershash->{$user}->{'id'};
6785: }
6786: my $inst_response;
6787: if (ref($checks) eq 'HASH') {
6788: if (defined($checks->{'username'})) {
1.615 raeburn 6789: ($inst_response,%{$inst_results->{$user}}) =
1.612 raeburn 6790: &Apache::lonnet::get_instuser($udom,$uname);
6791: } elsif (defined($checks->{'id'})) {
1.615 raeburn 6792: ($inst_response,%{$inst_results->{$user}}) =
1.612 raeburn 6793: &Apache::lonnet::get_instuser($udom,undef,$id);
6794: }
1.615 raeburn 6795: } else {
6796: ($inst_response,%{$inst_results->{$user}}) =
6797: &Apache::lonnet::get_instuser($udom,$uname);
6798: return;
1.612 raeburn 6799: }
1.615 raeburn 6800: if (!$got_rules->{$udom}) {
1.612 raeburn 6801: my %domconfig = &Apache::lonnet::get_dom('configuration',
6802: ['usercreation'],$udom);
6803: if (ref($domconfig{'usercreation'}) eq 'HASH') {
1.615 raeburn 6804: foreach my $item ('username','id') {
1.612 raeburn 6805: if (ref($domconfig{'usercreation'}{$item.'_rule'}) eq 'ARRAY') {
6806: $$curr_rules{$udom}{$item} =
6807: $domconfig{'usercreation'}{$item.'_rule'};
1.585 raeburn 6808: }
6809: }
6810: }
1.615 raeburn 6811: $got_rules->{$udom} = 1;
1.585 raeburn 6812: }
1.612 raeburn 6813: foreach my $item (keys(%{$checks})) {
6814: if (ref($$curr_rules{$udom}) eq 'HASH') {
6815: if (ref($$curr_rules{$udom}{$item}) eq 'ARRAY') {
6816: if (@{$$curr_rules{$udom}{$item}} > 0) {
6817: my %rule_check = &Apache::lonnet::inst_rulecheck($udom,$uname,$id,$item,$$curr_rules{$udom}{$item});
6818: foreach my $rule (@{$$curr_rules{$udom}{$item}}) {
6819: if ($rule_check{$rule}) {
6820: $$rulematch{$user}{$item} = $rule;
6821: if ($inst_response eq 'ok') {
1.615 raeburn 6822: if (ref($inst_results) eq 'HASH') {
6823: if (ref($inst_results->{$user}) eq 'HASH') {
6824: if (keys(%{$inst_results->{$user}}) == 0) {
6825: $$alerts{$item}{$udom}{$uname} = 1;
6826: }
1.612 raeburn 6827: }
6828: }
1.615 raeburn 6829: }
6830: last;
1.585 raeburn 6831: }
6832: }
6833: }
6834: }
6835: }
6836: }
6837: }
6838: }
1.612 raeburn 6839: return;
6840: }
6841:
6842: sub user_rule_formats {
6843: my ($domain,$domdesc,$curr_rules,$check) = @_;
6844: my %text = (
6845: 'username' => 'Usernames',
6846: 'id' => 'IDs',
6847: );
6848: my $output;
6849: my ($rules,$ruleorder) = &Apache::lonnet::inst_userrules($domain,$check);
6850: if ((ref($rules) eq 'HASH') && (ref($ruleorder) eq 'ARRAY')) {
6851: if (@{$ruleorder} > 0) {
6852: $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>';
6853: foreach my $rule (@{$ruleorder}) {
6854: if (ref($curr_rules) eq 'ARRAY') {
6855: if (grep(/^\Q$rule\E$/,@{$curr_rules})) {
6856: if (ref($rules->{$rule}) eq 'HASH') {
6857: $output .= '<li>'.$rules->{$rule}{'name'}.': '.
6858: $rules->{$rule}{'desc'}.'</li>';
6859: }
6860: }
6861: }
6862: }
6863: $output .= '</ul>';
6864: }
6865: }
6866: return $output;
6867: }
6868:
6869: sub instrule_disallow_msg {
1.615 raeburn 6870: my ($checkitem,$domdesc,$count,$mode) = @_;
1.612 raeburn 6871: my $response;
6872: my %text = (
6873: item => 'username',
6874: items => 'usernames',
6875: match => 'matches',
6876: do => 'does',
6877: action => 'a username',
6878: one => 'one',
6879: );
6880: if ($count > 1) {
6881: $text{'item'} = 'usernames';
6882: $text{'match'} ='match';
6883: $text{'do'} = 'do';
6884: $text{'action'} = 'usernames',
6885: $text{'one'} = 'ones';
6886: }
6887: if ($checkitem eq 'id') {
6888: $text{'items'} = 'IDs';
6889: $text{'item'} = 'ID';
6890: $text{'action'} = 'an ID';
1.615 raeburn 6891: if ($count > 1) {
6892: $text{'item'} = 'IDs';
6893: $text{'action'} = 'IDs';
6894: }
1.612 raeburn 6895: }
1.674 bisitz 6896: $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 6897: if ($mode eq 'upload') {
6898: if ($checkitem eq 'username') {
6899: $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'}.");
6900: } elsif ($checkitem eq 'id') {
1.674 bisitz 6901: $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 6902: }
1.669 raeburn 6903: } elsif ($mode eq 'selfcreate') {
6904: if ($checkitem eq 'id') {
6905: $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.");
6906: }
1.615 raeburn 6907: } else {
6908: if ($checkitem eq 'username') {
6909: $response .= &mt("You must choose $text{'action'} with a different format -- $text{'one'} that will not conflict with 'official' institutional $text{'items'}.");
6910: } elsif ($checkitem eq 'id') {
6911: $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.");
6912: }
1.612 raeburn 6913: }
6914: return $response;
1.585 raeburn 6915: }
6916:
1.624 raeburn 6917: sub personal_data_fieldtitles {
6918: my %fieldtitles = &Apache::lonlocal::texthash (
6919: id => 'Student/Employee ID',
6920: permanentemail => 'E-mail address',
6921: lastname => 'Last Name',
6922: firstname => 'First Name',
6923: middlename => 'Middle Name',
6924: generation => 'Generation',
6925: gen => 'Generation',
6926: );
6927: return %fieldtitles;
6928: }
6929:
1.642 raeburn 6930: sub sorted_inst_types {
6931: my ($dom) = @_;
6932: my ($usertypes,$order) = &Apache::lonnet::retrieve_inst_usertypes($dom);
6933: my $othertitle = &mt('All users');
6934: if ($env{'request.course.id'}) {
1.668 raeburn 6935: $othertitle = &mt('Any users');
1.642 raeburn 6936: }
6937: my @types;
6938: if (ref($order) eq 'ARRAY') {
6939: @types = @{$order};
6940: }
6941: if (@types == 0) {
6942: if (ref($usertypes) eq 'HASH') {
6943: @types = sort(keys(%{$usertypes}));
6944: }
6945: }
6946: if (keys(%{$usertypes}) > 0) {
6947: $othertitle = &mt('Other users');
6948: }
6949: return ($othertitle,$usertypes,\@types);
6950: }
6951:
1.645 raeburn 6952: sub get_institutional_codes {
6953: my ($settings,$allcourses,$LC_code) = @_;
6954: # Get complete list of course sections to update
6955: my @currsections = ();
6956: my @currxlists = ();
6957: my $coursecode = $$settings{'internal.coursecode'};
6958:
6959: if ($$settings{'internal.sectionnums'} ne '') {
6960: @currsections = split(/,/,$$settings{'internal.sectionnums'});
6961: }
6962:
6963: if ($$settings{'internal.crosslistings'} ne '') {
6964: @currxlists = split(/,/,$$settings{'internal.crosslistings'});
6965: }
6966:
6967: if (@currxlists > 0) {
6968: foreach (@currxlists) {
6969: if (m/^([^:]+):(\w*)$/) {
6970: unless (grep/^$1$/,@{$allcourses}) {
6971: push @{$allcourses},$1;
6972: $$LC_code{$1} = $2;
6973: }
6974: }
6975: }
6976: }
6977:
6978: if (@currsections > 0) {
6979: foreach (@currsections) {
6980: if (m/^(\w+):(\w*)$/) {
6981: my $sec = $coursecode.$1;
6982: my $lc_sec = $2;
6983: unless (grep/^$sec$/,@{$allcourses}) {
6984: push @{$allcourses},$sec;
6985: $$LC_code{$sec} = $lc_sec;
6986: }
6987: }
6988: }
6989: }
6990: return;
6991: }
6992:
1.112 bowersj2 6993: =pod
6994:
1.549 albertel 6995: =back
6996:
6997: =head1 HTTP Helpers
6998:
6999: =over 4
7000:
1.648 raeburn 7001: =item * &get_unprocessed_cgi($query,$possible_names)
1.112 bowersj2 7002:
1.258 albertel 7003: Modify the %env hash to contain unprocessed CGI form parameters held in
1.112 bowersj2 7004: $query. The parameters listed in $possible_names (an array reference),
1.258 albertel 7005: will be set in $env{'form.name'} if they do not already exist.
1.112 bowersj2 7006:
7007: Typically called with $ENV{'QUERY_STRING'} as the first parameter.
7008: $possible_names is an ref to an array of form element names. As an example:
7009: get_unprocessed_cgi($ENV{'QUERY_STRING'},['uname','udom']);
1.258 albertel 7010: will result in $env{'form.uname'} and $env{'form.udom'} being set.
1.112 bowersj2 7011:
7012: =cut
1.1 albertel 7013:
1.6 albertel 7014: sub get_unprocessed_cgi {
1.25 albertel 7015: my ($query,$possible_names)= @_;
1.26 matthew 7016: # $Apache::lonxml::debug=1;
1.356 albertel 7017: foreach my $pair (split(/&/,$query)) {
7018: my ($name, $value) = split(/=/,$pair);
1.369 www 7019: $name = &unescape($name);
1.25 albertel 7020: if (!defined($possible_names) || (grep {$_ eq $name} @$possible_names)) {
7021: $value =~ tr/+/ /;
7022: $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
1.258 albertel 7023: unless (defined($env{'form.'.$name})) { &add_to_env('form.'.$name,$value) };
1.25 albertel 7024: }
1.16 harris41 7025: }
1.6 albertel 7026: }
7027:
1.112 bowersj2 7028: =pod
7029:
1.648 raeburn 7030: =item * &cacheheader()
1.112 bowersj2 7031:
7032: returns cache-controlling header code
7033:
7034: =cut
7035:
1.7 albertel 7036: sub cacheheader {
1.258 albertel 7037: unless ($env{'request.method'} eq 'GET') { return ''; }
1.216 albertel 7038: my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
7039: my $output .='<meta HTTP-EQUIV="Expires" CONTENT="'.$date.'" />
1.7 albertel 7040: <meta HTTP-EQUIV="Cache-control" CONTENT="no-cache" />
7041: <meta HTTP-EQUIV="Pragma" CONTENT="no-cache" />';
1.216 albertel 7042: return $output;
1.7 albertel 7043: }
7044:
1.112 bowersj2 7045: =pod
7046:
1.648 raeburn 7047: =item * &no_cache($r)
1.112 bowersj2 7048:
7049: specifies header code to not have cache
7050:
7051: =cut
7052:
1.9 albertel 7053: sub no_cache {
1.216 albertel 7054: my ($r) = @_;
7055: if ($ENV{'REQUEST_METHOD'} ne 'GET' &&
1.258 albertel 7056: $env{'request.method'} ne 'GET') { return ''; }
1.216 albertel 7057: my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime(time));
7058: $r->no_cache(1);
7059: $r->header_out("Expires" => $date);
7060: $r->header_out("Pragma" => "no-cache");
1.123 www 7061: }
7062:
7063: sub content_type {
1.181 albertel 7064: my ($r,$type,$charset) = @_;
1.299 foxr 7065: if ($r) {
7066: # Note that printout.pl calls this with undef for $r.
7067: &no_cache($r);
7068: }
1.258 albertel 7069: if ($env{'browser.mathml'} && $type eq 'text/html') { $type='text/xml'; }
1.181 albertel 7070: unless ($charset) {
7071: $charset=&Apache::lonlocal::current_encoding;
7072: }
7073: if ($charset) { $type.='; charset='.$charset; }
7074: if ($r) {
7075: $r->content_type($type);
7076: } else {
7077: print("Content-type: $type\n\n");
7078: }
1.9 albertel 7079: }
1.25 albertel 7080:
1.112 bowersj2 7081: =pod
7082:
1.648 raeburn 7083: =item * &add_to_env($name,$value)
1.112 bowersj2 7084:
1.258 albertel 7085: adds $name to the %env hash with value
1.112 bowersj2 7086: $value, if $name already exists, the entry is converted to an array
7087: reference and $value is added to the array.
7088:
7089: =cut
7090:
1.25 albertel 7091: sub add_to_env {
7092: my ($name,$value)=@_;
1.258 albertel 7093: if (defined($env{$name})) {
7094: if (ref($env{$name})) {
1.25 albertel 7095: #already have multiple values
1.258 albertel 7096: push(@{ $env{$name} },$value);
1.25 albertel 7097: } else {
7098: #first time seeing multiple values, convert hash entry to an arrayref
1.258 albertel 7099: my $first=$env{$name};
7100: undef($env{$name});
7101: push(@{ $env{$name} },$first,$value);
1.25 albertel 7102: }
7103: } else {
1.258 albertel 7104: $env{$name}=$value;
1.25 albertel 7105: }
1.31 albertel 7106: }
1.149 albertel 7107:
7108: =pod
7109:
1.648 raeburn 7110: =item * &get_env_multiple($name)
1.149 albertel 7111:
1.258 albertel 7112: gets $name from the %env hash, it seemlessly handles the cases where multiple
1.149 albertel 7113: values may be defined and end up as an array ref.
7114:
7115: returns an array of values
7116:
7117: =cut
7118:
7119: sub get_env_multiple {
7120: my ($name) = @_;
7121: my @values;
1.258 albertel 7122: if (defined($env{$name})) {
1.149 albertel 7123: # exists is it an array
1.258 albertel 7124: if (ref($env{$name})) {
7125: @values=@{ $env{$name} };
1.149 albertel 7126: } else {
1.258 albertel 7127: $values[0]=$env{$name};
1.149 albertel 7128: }
7129: }
7130: return(@values);
7131: }
7132:
1.660 raeburn 7133: sub ask_for_embedded_content {
7134: my ($actionurl,$state,$allfiles,$codebase,$args)=@_;
7135: my $upload_output = '
7136: <form name="upload_embedded" action="'.$actionurl.'"
7137: method="post" enctype="multipart/form-data">';
7138: $upload_output .= $state;
1.661 raeburn 7139: $upload_output .= '<b>Upload embedded files</b>:<br />'.&start_data_table();
1.660 raeburn 7140:
7141: my $num = 0;
7142: foreach my $embed_file (sort {lc($a) cmp lc($b)} keys(%{$allfiles})) {
7143: $upload_output .= &start_data_table_row().
7144: '<td>'.$embed_file.'</td><td>';
7145: if ($args->{'ignore_remote_references'}
7146: && $embed_file =~ m{^\w+://}) {
7147: $upload_output.='<span class="LC_warning">'.&mt("URL points to other server.").'</span>';
7148: } elsif ($args->{'error_on_invalid_names'}
7149: && $embed_file ne &Apache::lonnet::clean_filename($embed_file,{'keep_path' => 1,})) {
7150:
7151: $upload_output.='<span class="LC_warning">'.&mt("Invalid characters").'</span>';
7152:
7153: } else {
7154: $upload_output .='
1.661 raeburn 7155: <input name="embedded_item_'.$num.'" type="file" value="" />
1.660 raeburn 7156: <input name="embedded_orig_'.$num.'" type="hidden" value="'.&escape($embed_file).'" />';
7157: my $attrib = join(':',@{$$allfiles{$embed_file}});
7158: $upload_output .=
7159: "\n\t\t".
7160: '<input name="embedded_attrib_'.$num.'" type="hidden" value="'.
7161: $attrib.'" />';
7162: if (exists($$codebase{$embed_file})) {
7163: $upload_output .=
7164: "\n\t\t".
7165: '<input name="codebase_'.$num.'" type="hidden" value="'.
7166: &escape($$codebase{$embed_file}).'" />';
7167: }
7168: }
7169: $upload_output .= '</td>'.&Apache::loncommon::end_data_table_row();
7170: $num++;
7171: }
7172: $upload_output .= &Apache::loncommon::end_data_table().'<br />
7173: <input type ="hidden" name="number_embedded_items" value="'.$num.'" />
7174: <input type ="submit" value="'.&mt('Upload Listed Files').'" />
7175: '.&mt('(only files for which a location has been provided will be uploaded)').'
7176: </form>';
7177: return $upload_output;
7178: }
7179:
1.661 raeburn 7180: sub upload_embedded {
7181: my ($context,$dirpath,$uname,$udom,$dir_root,$url_root,$group,$disk_quota,
7182: $current_disk_usage) = @_;
7183: my $output;
7184: for (my $i=0; $i<$env{'form.number_embedded_items'}; $i++) {
7185: next if (!exists($env{'form.embedded_item_'.$i.'.filename'}));
7186: my $orig_uploaded_filename =
7187: $env{'form.embedded_item_'.$i.'.filename'};
7188:
7189: $env{'form.embedded_orig_'.$i} =
7190: &unescape($env{'form.embedded_orig_'.$i});
7191: my ($path,$fname) =
7192: ($env{'form.embedded_orig_'.$i} =~ m{(.*/)([^/]*)});
7193: # no path, whole string is fname
7194: if (!$fname) { $fname = $env{'form.embedded_orig_'.$i} };
7195:
7196: $path = $env{'form.currentpath'}.$path;
7197: $fname = &Apache::lonnet::clean_filename($fname);
7198: # See if there is anything left
7199: next if ($fname eq '');
7200:
7201: # Check if file already exists as a file or directory.
7202: my ($state,$msg);
7203: if ($context eq 'portfolio') {
7204: my $port_path = $dirpath;
7205: if ($group ne '') {
7206: $port_path = "groups/$group/$port_path";
7207: }
7208: ($state,$msg) = &check_for_upload($path,$fname,$group,'embedded_item_'.$i,
7209: $dir_root,$port_path,$disk_quota,
7210: $current_disk_usage,$uname,$udom);
7211: if ($state eq 'will_exceed_quota'
7212: || $state eq 'file_locked'
7213: || $state eq 'file_exists' ) {
7214: $output .= $msg;
7215: next;
7216: }
7217: } elsif (($context eq 'author') || ($context eq 'testbank')) {
7218: ($state,$msg) = &check_for_existing($path,$fname,'embedded_item_'.$i);
7219: if ($state eq 'exists') {
7220: $output .= $msg;
7221: next;
7222: }
7223: }
7224: # Check if extension is valid
7225: if (($fname =~ /\.(\w+)$/) &&
7226: (&Apache::loncommon::fileembstyle($1) eq 'hdn')) {
7227: $output .= &mt('Invalid file extension ([_1]) - reserved for LONCAPA use - rename the file with a different extension and re-upload. ',$1);
7228: next;
7229: } elsif (($fname =~ /\.(\w+)$/) &&
7230: (!defined(&Apache::loncommon::fileembstyle($1)))) {
7231: $output .= &mt('Unrecognized file extension ([_1]) - rename the file with a proper extension and re-upload.',$1);
7232: next;
7233: } elsif ($fname=~/\.(\d+)\.(\w+)$/) {
7234: $output .= &mt('File name not allowed - rename the file to remove the number immediately before the file extension([_1]) and re-upload.',$2);
7235: next;
7236: }
7237:
7238: $env{'form.embedded_item_'.$i.'.filename'}=$fname;
7239: if ($context eq 'portfolio') {
7240: my $result=
7241: &Apache::lonnet::userfileupload('embedded_item_'.$i,'',
7242: $dirpath.$path);
7243: if ($result !~ m|^/uploaded/|) {
7244: $output .= '<span class="LC_error">'
7245: .&mt('An error occurred ([_1]) while trying to upload [_2] for embedded element [_3].'
7246: ,$result,$orig_uploaded_filename,$env{'form.embedded_orig_'.$i})
7247: .'</span><br />';
7248: next;
7249: } else {
7250: $output .= '<p>'.&mt('Uploaded [_1]','<span class="LC_filename">'.
7251: $path.$fname.'</span>').'</p>';
7252: }
7253: } else {
7254: # Save the file
7255: my $target = $env{'form.embedded_item_'.$i};
7256: my $fullpath = $dir_root.$dirpath.'/'.$path;
7257: my $dest = $fullpath.$fname;
7258: my $url = $url_root.$dirpath.'/'.$path.$fname;
7259: my @parts=split(/\//,$fullpath);
7260: my $count;
7261: my $filepath = $dir_root;
7262: for ($count=4;$count<=$#parts;$count++) {
7263: $filepath .= "/$parts[$count]";
7264: if ((-e $filepath)!=1) {
7265: mkdir($filepath,0770);
7266: }
7267: }
7268: my $fh;
7269: if (!open($fh,'>'.$dest)) {
7270: &Apache::lonnet::logthis('Failed to create '.$dest);
7271: $output .= '<span class="LC_error">'.
7272: &mt('An error occurred while trying to upload [_1] for embedded element [_2].',$orig_uploaded_filename,$env{'form.embedded_orig_'.$i}).
7273: '</span><br />';
7274: } else {
7275: if (!print $fh $env{'form.embedded_item_'.$i}) {
7276: &Apache::lonnet::logthis('Failed to write to '.$dest);
7277: $output .= '<span class="LC_error">'.
7278: &mt('An error occurred while writing the file [_1] for embedded element [_2].',$orig_uploaded_filename,$env{'form.embedded_orig_'.$i}).
7279: '</span><br />';
7280: } else {
7281: if ($context eq 'testbank') {
7282: $output .= &mt('Embedded file uploaded successfully:').
7283: ' <a href="'.$url.'">'.
7284: $orig_uploaded_filename.'</a><br />';
7285: } else {
7286: $output .= '<font size="+2">'.
7287: &mt('View embedded file: [_1]','<a href="'.$url.'">'.
7288: $orig_uploaded_filename.'</a>').'</font><br />';
7289: }
7290: }
7291: close($fh);
7292: }
7293: }
7294: }
7295: return $output;
7296: }
7297:
7298: sub check_for_existing {
7299: my ($path,$fname,$element) = @_;
7300: my ($state,$msg);
7301: if (-d $path.'/'.$fname) {
7302: $state = 'exists';
7303: $msg = &mt('Unable to upload [_1]. A directory by that name was found in [_2].','<span class="LC_filename">'.$fname.'</span>',$path);
7304: } elsif (-e $path.'/'.$fname) {
7305: $state = 'exists';
7306: $msg = &mt('Unable to upload [_1]. A file by that name was found in [_2].','<span class="LC_filename">'.$fname.'</span>',$path);
7307: }
7308: if ($state eq 'exists') {
7309: $msg = '<span class="LC_error">'.$msg.'</span><br />';
7310: }
7311: return ($state,$msg);
7312: }
7313:
7314: sub check_for_upload {
7315: my ($path,$fname,$group,$element,$portfolio_root,$port_path,
7316: $disk_quota,$current_disk_usage,$uname,$udom) = @_;
7317: my $filesize = (length($env{'form.'.$element})) / 1000; #express in k (1024?)
7318: my $getpropath = 1;
7319: my @dir_list = &Apache::lonnet::dirlist($portfolio_root.$path,$udom,$uname,
7320: $getpropath);
7321: my $found_file = 0;
7322: my $locked_file = 0;
7323: foreach my $line (@dir_list) {
7324: my ($file_name)=split(/\&/,$line,2);
7325: if ($file_name eq $fname){
7326: $file_name = $path.$file_name;
7327: if ($group ne '') {
7328: $file_name = $group.$file_name;
7329: }
7330: $found_file = 1;
7331: if (&Apache::lonnet::is_locked($file_name,$udom,$uname) eq 'true') {
7332: $locked_file = 1;
7333: }
7334: }
7335: }
7336: if (($current_disk_usage + $filesize) > $disk_quota){
7337: my $msg = '<span class="LC_error">'.
7338: &mt('Unable to upload [_1]. (size = [_2] kilobytes). Disk quota will be exceeded.','<span class="LC_filename">'.$fname.'</span>',$filesize).'</span>'.
7339: '<br />'.&mt('Disk quota is [_1] kilobytes. Your current disk usage is [_2] kilobytes.',$disk_quota,$current_disk_usage);
7340: return ('will_exceed_quota',$msg);
7341: } elsif ($found_file) {
7342: if ($locked_file) {
7343: my $msg = '<span class="LC_error">';
7344: $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>');
7345: $msg .= '</span><br />';
7346: $msg .= &mt('You will be able to rename or delete existing [_1] after a grade has been assigned.','<span class="LC_filename">'.$fname.'</span>');
7347: return ('file_locked',$msg);
7348: } else {
7349: my $msg = '<span class="LC_error">';
7350: $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'});
7351: $msg .= '</span>';
7352: $msg .= '<br />';
7353: $msg .= &mt('To upload, rename or delete existing [_1] in [_2].','<span class="LC_filename">'.$fname.'</span>', $port_path.$env{'form.currentpath'});
7354: return ('file_exists',$msg);
7355: }
7356: }
7357: }
7358:
1.31 albertel 7359:
1.41 ng 7360: =pod
1.45 matthew 7361:
1.464 albertel 7362: =back
1.41 ng 7363:
1.112 bowersj2 7364: =head1 CSV Upload/Handling functions
1.38 albertel 7365:
1.41 ng 7366: =over 4
7367:
1.648 raeburn 7368: =item * &upfile_store($r)
1.41 ng 7369:
7370: Store uploaded file, $r should be the HTTP Request object,
1.258 albertel 7371: needs $env{'form.upfile'}
1.41 ng 7372: returns $datatoken to be put into hidden field
7373:
7374: =cut
1.31 albertel 7375:
7376: sub upfile_store {
7377: my $r=shift;
1.258 albertel 7378: $env{'form.upfile'}=~s/\r/\n/gs;
7379: $env{'form.upfile'}=~s/\f/\n/gs;
7380: $env{'form.upfile'}=~s/\n+/\n/gs;
7381: $env{'form.upfile'}=~s/\n+$//gs;
1.31 albertel 7382:
1.258 albertel 7383: my $datatoken=$env{'user.name'}.'_'.$env{'user.domain'}.
7384: '_enroll_'.$env{'request.course.id'}.'_'.time.'_'.$$;
1.31 albertel 7385: {
1.158 raeburn 7386: my $datafile = $r->dir_config('lonDaemons').
7387: '/tmp/'.$datatoken.'.tmp';
7388: if ( open(my $fh,">$datafile") ) {
1.258 albertel 7389: print $fh $env{'form.upfile'};
1.158 raeburn 7390: close($fh);
7391: }
1.31 albertel 7392: }
7393: return $datatoken;
7394: }
7395:
1.56 matthew 7396: =pod
7397:
1.648 raeburn 7398: =item * &load_tmp_file($r)
1.41 ng 7399:
7400: Load uploaded file from tmp, $r should be the HTTP Request object,
1.258 albertel 7401: needs $env{'form.datatoken'},
7402: sets $env{'form.upfile'} to the contents of the file
1.41 ng 7403:
7404: =cut
1.31 albertel 7405:
7406: sub load_tmp_file {
7407: my $r=shift;
7408: my @studentdata=();
7409: {
1.158 raeburn 7410: my $studentfile = $r->dir_config('lonDaemons').
1.258 albertel 7411: '/tmp/'.$env{'form.datatoken'}.'.tmp';
1.158 raeburn 7412: if ( open(my $fh,"<$studentfile") ) {
7413: @studentdata=<$fh>;
7414: close($fh);
7415: }
1.31 albertel 7416: }
1.258 albertel 7417: $env{'form.upfile'}=join('',@studentdata);
1.31 albertel 7418: }
7419:
1.56 matthew 7420: =pod
7421:
1.648 raeburn 7422: =item * &upfile_record_sep()
1.41 ng 7423:
7424: Separate uploaded file into records
7425: returns array of records,
1.258 albertel 7426: needs $env{'form.upfile'} and $env{'form.upfiletype'}
1.41 ng 7427:
7428: =cut
1.31 albertel 7429:
7430: sub upfile_record_sep {
1.258 albertel 7431: if ($env{'form.upfiletype'} eq 'xml') {
1.31 albertel 7432: } else {
1.248 albertel 7433: my @records;
1.258 albertel 7434: foreach my $line (split(/\n/,$env{'form.upfile'})) {
1.248 albertel 7435: if ($line=~/^\s*$/) { next; }
7436: push(@records,$line);
7437: }
7438: return @records;
1.31 albertel 7439: }
7440: }
7441:
1.56 matthew 7442: =pod
7443:
1.648 raeburn 7444: =item * &record_sep($record)
1.41 ng 7445:
1.258 albertel 7446: Separate a record into fields $record should be an item from the upfile_record_sep(), needs $env{'form.upfiletype'}
1.41 ng 7447:
7448: =cut
7449:
1.263 www 7450: sub takeleft {
7451: my $index=shift;
7452: return substr('0000'.$index,-4,4);
7453: }
7454:
1.31 albertel 7455: sub record_sep {
7456: my $record=shift;
7457: my %components=();
1.258 albertel 7458: if ($env{'form.upfiletype'} eq 'xml') {
7459: } elsif ($env{'form.upfiletype'} eq 'space') {
1.31 albertel 7460: my $i=0;
1.356 albertel 7461: foreach my $field (split(/\s+/,$record)) {
1.31 albertel 7462: $field=~s/^(\"|\')//;
7463: $field=~s/(\"|\')$//;
1.263 www 7464: $components{&takeleft($i)}=$field;
1.31 albertel 7465: $i++;
7466: }
1.258 albertel 7467: } elsif ($env{'form.upfiletype'} eq 'tab') {
1.31 albertel 7468: my $i=0;
1.356 albertel 7469: foreach my $field (split(/\t/,$record)) {
1.31 albertel 7470: $field=~s/^(\"|\')//;
7471: $field=~s/(\"|\')$//;
1.263 www 7472: $components{&takeleft($i)}=$field;
1.31 albertel 7473: $i++;
7474: }
7475: } else {
1.561 www 7476: my $separator=',';
1.480 banghart 7477: if ($env{'form.upfiletype'} eq 'semisv') {
1.561 www 7478: $separator=';';
1.480 banghart 7479: }
1.31 albertel 7480: my $i=0;
1.561 www 7481: # the character we are looking for to indicate the end of a quote or a record
7482: my $looking_for=$separator;
7483: # do not add the characters to the fields
7484: my $ignore=0;
7485: # we just encountered a separator (or the beginning of the record)
7486: my $just_found_separator=1;
7487: # store the field we are working on here
7488: my $field='';
7489: # work our way through all characters in record
7490: foreach my $character ($record=~/(.)/g) {
7491: if ($character eq $looking_for) {
7492: if ($character ne $separator) {
7493: # Found the end of a quote, again looking for separator
7494: $looking_for=$separator;
7495: $ignore=1;
7496: } else {
7497: # Found a separator, store away what we got
7498: $components{&takeleft($i)}=$field;
7499: $i++;
7500: $just_found_separator=1;
7501: $ignore=0;
7502: $field='';
7503: }
7504: next;
7505: }
7506: # single or double quotation marks after a separator indicate beginning of a quote
7507: # we are now looking for the end of the quote and need to ignore separators
7508: if ((($character eq '"') || ($character eq "'")) && ($just_found_separator)) {
7509: $looking_for=$character;
7510: next;
7511: }
7512: # ignore would be true after we reached the end of a quote
7513: if ($ignore) { next; }
7514: if (($just_found_separator) && ($character=~/\s/)) { next; }
7515: $field.=$character;
7516: $just_found_separator=0;
1.31 albertel 7517: }
1.561 www 7518: # catch the very last entry, since we never encountered the separator
7519: $components{&takeleft($i)}=$field;
1.31 albertel 7520: }
7521: return %components;
7522: }
7523:
1.144 matthew 7524: ######################################################
7525: ######################################################
7526:
1.56 matthew 7527: =pod
7528:
1.648 raeburn 7529: =item * &upfile_select_html()
1.41 ng 7530:
1.144 matthew 7531: Return HTML code to select a file from the users machine and specify
7532: the file type.
1.41 ng 7533:
7534: =cut
7535:
1.144 matthew 7536: ######################################################
7537: ######################################################
1.31 albertel 7538: sub upfile_select_html {
1.144 matthew 7539: my %Types = (
7540: csv => &mt('CSV (comma separated values, spreadsheet)'),
1.480 banghart 7541: semisv => &mt('Semicolon separated values'),
1.144 matthew 7542: space => &mt('Space separated'),
7543: tab => &mt('Tabulator separated'),
7544: # xml => &mt('HTML/XML'),
7545: );
7546: my $Str = '<input type="file" name="upfile" size="50" />'.
7547: '<br />Type: <select name="upfiletype">';
7548: foreach my $type (sort(keys(%Types))) {
7549: $Str .= '<option value="'.$type.'" >'.$Types{$type}."</option>\n";
7550: }
7551: $Str .= "</select>\n";
7552: return $Str;
1.31 albertel 7553: }
7554:
1.301 albertel 7555: sub get_samples {
7556: my ($records,$toget) = @_;
7557: my @samples=({});
7558: my $got=0;
7559: foreach my $rec (@$records) {
7560: my %temp = &record_sep($rec);
7561: if (! grep(/\S/, values(%temp))) { next; }
7562: if (%temp) {
7563: $samples[$got]=\%temp;
7564: $got++;
7565: if ($got == $toget) { last; }
7566: }
7567: }
7568: return \@samples;
7569: }
7570:
1.144 matthew 7571: ######################################################
7572: ######################################################
7573:
1.56 matthew 7574: =pod
7575:
1.648 raeburn 7576: =item * &csv_print_samples($r,$records)
1.41 ng 7577:
7578: Prints a table of sample values from each column uploaded $r is an
7579: Apache Request ref, $records is an arrayref from
7580: &Apache::loncommon::upfile_record_sep
7581:
7582: =cut
7583:
1.144 matthew 7584: ######################################################
7585: ######################################################
1.31 albertel 7586: sub csv_print_samples {
7587: my ($r,$records) = @_;
1.662 bisitz 7588: my $samples = &get_samples($records,5);
1.301 albertel 7589:
1.594 raeburn 7590: $r->print(&mt('Samples').'<br />'.&start_data_table().
7591: &start_data_table_header_row());
1.356 albertel 7592: foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
7593: $r->print('<th>'.&mt('Column [_1]',($sample+1)).'</th>'); }
1.594 raeburn 7594: $r->print(&end_data_table_header_row());
1.301 albertel 7595: foreach my $hash (@$samples) {
1.594 raeburn 7596: $r->print(&start_data_table_row());
1.356 albertel 7597: foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
1.31 albertel 7598: $r->print('<td>');
1.356 albertel 7599: if (defined($$hash{$sample})) { $r->print($$hash{$sample}); }
1.31 albertel 7600: $r->print('</td>');
7601: }
1.594 raeburn 7602: $r->print(&end_data_table_row());
1.31 albertel 7603: }
1.594 raeburn 7604: $r->print(&end_data_table().'<br />'."\n");
1.31 albertel 7605: }
7606:
1.144 matthew 7607: ######################################################
7608: ######################################################
7609:
1.56 matthew 7610: =pod
7611:
1.648 raeburn 7612: =item * &csv_print_select_table($r,$records,$d)
1.41 ng 7613:
7614: Prints a table to create associations between values and table columns.
1.144 matthew 7615:
1.41 ng 7616: $r is an Apache Request ref,
7617: $records is an arrayref from &Apache::loncommon::upfile_record_sep,
1.174 matthew 7618: $d is an array of 2 element arrays (internal name, displayed name,defaultcol)
1.41 ng 7619:
7620: =cut
7621:
1.144 matthew 7622: ######################################################
7623: ######################################################
1.31 albertel 7624: sub csv_print_select_table {
7625: my ($r,$records,$d) = @_;
1.301 albertel 7626: my $i=0;
7627: my $samples = &get_samples($records,1);
1.144 matthew 7628: $r->print(&mt('Associate columns with student attributes.')."\n".
1.594 raeburn 7629: &start_data_table().&start_data_table_header_row().
1.144 matthew 7630: '<th>'.&mt('Attribute').'</th>'.
1.594 raeburn 7631: '<th>'.&mt('Column').'</th>'.
7632: &end_data_table_header_row()."\n");
1.356 albertel 7633: foreach my $array_ref (@$d) {
7634: my ($value,$display,$defaultcol)=@{ $array_ref };
1.594 raeburn 7635: $r->print(&start_data_table_row().'<tr><td>'.$display.'</td>');
1.31 albertel 7636:
7637: $r->print('<td><select name=f'.$i.
1.32 matthew 7638: ' onchange="javascript:flip(this.form,'.$i.');">');
1.31 albertel 7639: $r->print('<option value="none"></option>');
1.356 albertel 7640: foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
7641: $r->print('<option value="'.$sample.'"'.
7642: ($sample eq $defaultcol ? ' selected="selected" ' : '').
1.662 bisitz 7643: '>'.&mt('Column [_1]',($sample+1)).'</option>');
1.31 albertel 7644: }
1.594 raeburn 7645: $r->print('</select></td>'.&end_data_table_row()."\n");
1.31 albertel 7646: $i++;
7647: }
1.594 raeburn 7648: $r->print(&end_data_table());
1.31 albertel 7649: $i--;
7650: return $i;
7651: }
1.56 matthew 7652:
1.144 matthew 7653: ######################################################
7654: ######################################################
7655:
1.56 matthew 7656: =pod
1.31 albertel 7657:
1.648 raeburn 7658: =item * &csv_samples_select_table($r,$records,$d)
1.41 ng 7659:
7660: Prints a table of sample values from the upload and can make associate samples to internal names.
7661:
7662: $r is an Apache Request ref,
7663: $records is an arrayref from &Apache::loncommon::upfile_record_sep,
7664: $d is an array of 2 element arrays (internal name, displayed name)
7665:
7666: =cut
7667:
1.144 matthew 7668: ######################################################
7669: ######################################################
1.31 albertel 7670: sub csv_samples_select_table {
7671: my ($r,$records,$d) = @_;
7672: my $i=0;
1.144 matthew 7673: #
1.662 bisitz 7674: my $max_samples = 5;
7675: my $samples = &get_samples($records,$max_samples);
1.594 raeburn 7676: $r->print(&start_data_table().
7677: &start_data_table_header_row().'<th>'.
7678: &mt('Field').'</th><th>'.&mt('Samples').'</th>'.
7679: &end_data_table_header_row());
1.301 albertel 7680:
7681: foreach my $key (sort(keys(%{ $samples->[0] }))) {
1.594 raeburn 7682: $r->print(&start_data_table_row().'<td><select name="f'.$i.'"'.
1.32 matthew 7683: ' onchange="javascript:flip(this.form,'.$i.');">');
1.301 albertel 7684: foreach my $option (@$d) {
7685: my ($value,$display,$defaultcol)=@{ $option };
1.174 matthew 7686: $r->print('<option value="'.$value.'"'.
1.253 albertel 7687: ($i eq $defaultcol ? ' selected="selected" ':'').'>'.
1.174 matthew 7688: $display.'</option>');
1.31 albertel 7689: }
7690: $r->print('</select></td><td>');
1.662 bisitz 7691: foreach my $line (0..($max_samples-1)) {
1.301 albertel 7692: if (defined($samples->[$line]{$key})) {
7693: $r->print($samples->[$line]{$key}."<br />\n");
7694: }
7695: }
1.594 raeburn 7696: $r->print('</td>'.&end_data_table_row());
1.31 albertel 7697: $i++;
7698: }
1.594 raeburn 7699: $r->print(&end_data_table());
1.31 albertel 7700: $i--;
7701: return($i);
1.115 matthew 7702: }
7703:
1.144 matthew 7704: ######################################################
7705: ######################################################
7706:
1.115 matthew 7707: =pod
7708:
1.648 raeburn 7709: =item * &clean_excel_name($name)
1.115 matthew 7710:
7711: Returns a replacement for $name which does not contain any illegal characters.
7712:
7713: =cut
7714:
1.144 matthew 7715: ######################################################
7716: ######################################################
1.115 matthew 7717: sub clean_excel_name {
7718: my ($name) = @_;
7719: $name =~ s/[:\*\?\/\\]//g;
7720: if (length($name) > 31) {
7721: $name = substr($name,0,31);
7722: }
7723: return $name;
1.25 albertel 7724: }
1.84 albertel 7725:
1.85 albertel 7726: =pod
7727:
1.648 raeburn 7728: =item * &check_if_partid_hidden($id,$symb,$udom,$uname)
1.85 albertel 7729:
7730: Returns either 1 or undef
7731:
7732: 1 if the part is to be hidden, undef if it is to be shown
7733:
7734: Arguments are:
7735:
7736: $id the id of the part to be checked
7737: $symb, optional the symb of the resource to check
7738: $udom, optional the domain of the user to check for
7739: $uname, optional the username of the user to check for
7740:
7741: =cut
1.84 albertel 7742:
7743: sub check_if_partid_hidden {
7744: my ($id,$symb,$udom,$uname) = @_;
1.133 albertel 7745: my $hiddenparts=&Apache::lonnet::EXT('resource.0.hiddenparts',
1.84 albertel 7746: $symb,$udom,$uname);
1.141 albertel 7747: my $truth=1;
7748: #if the string starts with !, then the list is the list to show not hide
7749: if ($hiddenparts=~s/^\s*!//) { $truth=undef; }
1.84 albertel 7750: my @hiddenlist=split(/,/,$hiddenparts);
7751: foreach my $checkid (@hiddenlist) {
1.141 albertel 7752: if ($checkid =~ /^\s*\Q$id\E\s*$/) { return $truth; }
1.84 albertel 7753: }
1.141 albertel 7754: return !$truth;
1.84 albertel 7755: }
1.127 matthew 7756:
1.138 matthew 7757:
7758: ############################################################
7759: ############################################################
7760:
7761: =pod
7762:
1.157 matthew 7763: =back
7764:
1.138 matthew 7765: =head1 cgi-bin script and graphing routines
7766:
1.157 matthew 7767: =over 4
7768:
1.648 raeburn 7769: =item * &get_cgi_id()
1.138 matthew 7770:
7771: Inputs: none
7772:
7773: Returns an id which can be used to pass environment variables
7774: to various cgi-bin scripts. These environment variables will
7775: be removed from the users environment after a given time by
7776: the routine &Apache::lonnet::transfer_profile_to_env.
7777:
7778: =cut
7779:
7780: ############################################################
7781: ############################################################
1.152 albertel 7782: my $uniq=0;
1.136 matthew 7783: sub get_cgi_id {
1.154 albertel 7784: $uniq=($uniq+1)%100000;
1.280 albertel 7785: return (time.'_'.$$.'_'.$uniq);
1.136 matthew 7786: }
7787:
1.127 matthew 7788: ############################################################
7789: ############################################################
7790:
7791: =pod
7792:
1.648 raeburn 7793: =item * &DrawBarGraph()
1.127 matthew 7794:
1.138 matthew 7795: Facilitates the plotting of data in a (stacked) bar graph.
7796: Puts plot definition data into the users environment in order for
7797: graph.png to plot it. Returns an <img> tag for the plot.
7798: The bars on the plot are labeled '1','2',...,'n'.
7799:
7800: Inputs:
7801:
7802: =over 4
7803:
7804: =item $Title: string, the title of the plot
7805:
7806: =item $xlabel: string, text describing the X-axis of the plot
7807:
7808: =item $ylabel: string, text describing the Y-axis of the plot
7809:
7810: =item $Max: scalar, the maximum Y value to use in the plot
7811: If $Max is < any data point, the graph will not be rendered.
7812:
1.140 matthew 7813: =item $colors: array ref holding the colors to be used for the data sets when
1.138 matthew 7814: they are plotted. If undefined, default values will be used.
7815:
1.178 matthew 7816: =item $labels: array ref holding the labels to use on the x-axis for the bars.
7817:
1.138 matthew 7818: =item @Values: An array of array references. Each array reference holds data
7819: to be plotted in a stacked bar chart.
7820:
1.239 matthew 7821: =item If the final element of @Values is a hash reference the key/value
7822: pairs will be added to the graph definition.
7823:
1.138 matthew 7824: =back
7825:
7826: Returns:
7827:
7828: An <img> tag which references graph.png and the appropriate identifying
7829: information for the plot.
7830:
1.127 matthew 7831: =cut
7832:
7833: ############################################################
7834: ############################################################
1.134 matthew 7835: sub DrawBarGraph {
1.178 matthew 7836: my ($Title,$xlabel,$ylabel,$Max,$colors,$labels,@Values)=@_;
1.134 matthew 7837: #
7838: if (! defined($colors)) {
7839: $colors = ['#33ff00',
7840: '#0033cc', '#990000', '#aaaa66', '#663399', '#ff9933',
7841: '#66ccff', '#ff9999', '#cccc33', '#660000', '#33cc66',
7842: ];
7843: }
1.228 matthew 7844: my $extra_settings = {};
7845: if (ref($Values[-1]) eq 'HASH') {
7846: $extra_settings = pop(@Values);
7847: }
1.127 matthew 7848: #
1.136 matthew 7849: my $identifier = &get_cgi_id();
7850: my $id = 'cgi.'.$identifier;
1.129 matthew 7851: if (! @Values || ref($Values[0]) ne 'ARRAY') {
1.127 matthew 7852: return '';
7853: }
1.225 matthew 7854: #
7855: my @Labels;
7856: if (defined($labels)) {
7857: @Labels = @$labels;
7858: } else {
7859: for (my $i=0;$i<@{$Values[0]};$i++) {
7860: push (@Labels,$i+1);
7861: }
7862: }
7863: #
1.129 matthew 7864: my $NumBars = scalar(@{$Values[0]});
1.225 matthew 7865: if ($NumBars < scalar(@Labels)) { $NumBars = scalar(@Labels); }
1.129 matthew 7866: my %ValuesHash;
7867: my $NumSets=1;
7868: foreach my $array (@Values) {
7869: next if (! ref($array));
1.136 matthew 7870: $ValuesHash{$id.'.data.'.$NumSets++} =
1.132 matthew 7871: join(',',@$array);
1.129 matthew 7872: }
1.127 matthew 7873: #
1.136 matthew 7874: my ($height,$width,$xskip,$bar_width) = (200,120,1,15);
1.225 matthew 7875: if ($NumBars < 3) {
7876: $width = 120+$NumBars*32;
1.220 matthew 7877: $xskip = 1;
1.225 matthew 7878: $bar_width = 30;
7879: } elsif ($NumBars < 5) {
7880: $width = 120+$NumBars*20;
7881: $xskip = 1;
7882: $bar_width = 20;
1.220 matthew 7883: } elsif ($NumBars < 10) {
1.136 matthew 7884: $width = 120+$NumBars*15;
7885: $xskip = 1;
7886: $bar_width = 15;
7887: } elsif ($NumBars <= 25) {
7888: $width = 120+$NumBars*11;
7889: $xskip = 5;
7890: $bar_width = 8;
7891: } elsif ($NumBars <= 50) {
7892: $width = 120+$NumBars*8;
7893: $xskip = 5;
7894: $bar_width = 4;
7895: } else {
7896: $width = 120+$NumBars*8;
7897: $xskip = 5;
7898: $bar_width = 4;
7899: }
7900: #
1.137 matthew 7901: $Max = 1 if ($Max < 1);
7902: if ( int($Max) < $Max ) {
7903: $Max++;
7904: $Max = int($Max);
7905: }
1.127 matthew 7906: $Title = '' if (! defined($Title));
7907: $xlabel = '' if (! defined($xlabel));
7908: $ylabel = '' if (! defined($ylabel));
1.369 www 7909: $ValuesHash{$id.'.title'} = &escape($Title);
7910: $ValuesHash{$id.'.xlabel'} = &escape($xlabel);
7911: $ValuesHash{$id.'.ylabel'} = &escape($ylabel);
1.137 matthew 7912: $ValuesHash{$id.'.y_max_value'} = $Max;
1.136 matthew 7913: $ValuesHash{$id.'.NumBars'} = $NumBars;
7914: $ValuesHash{$id.'.NumSets'} = $NumSets;
7915: $ValuesHash{$id.'.PlotType'} = 'bar';
7916: $ValuesHash{$id.'.Colors'} = join(',',@{$colors});
7917: $ValuesHash{$id.'.height'} = $height;
7918: $ValuesHash{$id.'.width'} = $width;
7919: $ValuesHash{$id.'.xskip'} = $xskip;
7920: $ValuesHash{$id.'.bar_width'} = $bar_width;
7921: $ValuesHash{$id.'.labels'} = join(',',@Labels);
1.127 matthew 7922: #
1.228 matthew 7923: # Deal with other parameters
7924: while (my ($key,$value) = each(%$extra_settings)) {
7925: $ValuesHash{$id.'.'.$key} = $value;
7926: }
7927: #
1.646 raeburn 7928: &Apache::lonnet::appenv(\%ValuesHash);
1.137 matthew 7929: return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';
7930: }
7931:
7932: ############################################################
7933: ############################################################
7934:
7935: =pod
7936:
1.648 raeburn 7937: =item * &DrawXYGraph()
1.137 matthew 7938:
1.138 matthew 7939: Facilitates the plotting of data in an XY graph.
7940: Puts plot definition data into the users environment in order for
7941: graph.png to plot it. Returns an <img> tag for the plot.
7942:
7943: Inputs:
7944:
7945: =over 4
7946:
7947: =item $Title: string, the title of the plot
7948:
7949: =item $xlabel: string, text describing the X-axis of the plot
7950:
7951: =item $ylabel: string, text describing the Y-axis of the plot
7952:
7953: =item $Max: scalar, the maximum Y value to use in the plot
7954: If $Max is < any data point, the graph will not be rendered.
7955:
7956: =item $colors: Array ref containing the hex color codes for the data to be
7957: plotted in. If undefined, default values will be used.
7958:
7959: =item $Xlabels: Array ref containing the labels to be used for the X-axis.
7960:
7961: =item $Ydata: Array ref containing Array refs.
1.185 www 7962: Each of the contained arrays will be plotted as a separate curve.
1.138 matthew 7963:
7964: =item %Values: hash indicating or overriding any default values which are
7965: passed to graph.png.
7966: Possible values are: width, xskip, x_ticks, x_tick_offset, among others.
7967:
7968: =back
7969:
7970: Returns:
7971:
7972: An <img> tag which references graph.png and the appropriate identifying
7973: information for the plot.
7974:
1.137 matthew 7975: =cut
7976:
7977: ############################################################
7978: ############################################################
7979: sub DrawXYGraph {
7980: my ($Title,$xlabel,$ylabel,$Max,$colors,$Xlabels,$Ydata,%Values)=@_;
7981: #
7982: # Create the identifier for the graph
7983: my $identifier = &get_cgi_id();
7984: my $id = 'cgi.'.$identifier;
7985: #
7986: $Title = '' if (! defined($Title));
7987: $xlabel = '' if (! defined($xlabel));
7988: $ylabel = '' if (! defined($ylabel));
7989: my %ValuesHash =
7990: (
1.369 www 7991: $id.'.title' => &escape($Title),
7992: $id.'.xlabel' => &escape($xlabel),
7993: $id.'.ylabel' => &escape($ylabel),
1.137 matthew 7994: $id.'.y_max_value'=> $Max,
7995: $id.'.labels' => join(',',@$Xlabels),
7996: $id.'.PlotType' => 'XY',
7997: );
7998: #
7999: if (defined($colors) && ref($colors) eq 'ARRAY') {
8000: $ValuesHash{$id.'.Colors'} = join(',',@{$colors});
8001: }
8002: #
8003: if (! ref($Ydata) || ref($Ydata) ne 'ARRAY') {
8004: return '';
8005: }
8006: my $NumSets=1;
1.138 matthew 8007: foreach my $array (@{$Ydata}){
1.137 matthew 8008: next if (! ref($array));
8009: $ValuesHash{$id.'.data.'.$NumSets++} = join(',',@$array);
8010: }
1.138 matthew 8011: $ValuesHash{$id.'.NumSets'} = $NumSets-1;
1.137 matthew 8012: #
8013: # Deal with other parameters
8014: while (my ($key,$value) = each(%Values)) {
8015: $ValuesHash{$id.'.'.$key} = $value;
1.127 matthew 8016: }
8017: #
1.646 raeburn 8018: &Apache::lonnet::appenv(\%ValuesHash);
1.136 matthew 8019: return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';
8020: }
8021:
8022: ############################################################
8023: ############################################################
8024:
8025: =pod
8026:
1.648 raeburn 8027: =item * &DrawXYYGraph()
1.138 matthew 8028:
8029: Facilitates the plotting of data in an XY graph with two Y axes.
8030: Puts plot definition data into the users environment in order for
8031: graph.png to plot it. Returns an <img> tag for the plot.
8032:
8033: Inputs:
8034:
8035: =over 4
8036:
8037: =item $Title: string, the title of the plot
8038:
8039: =item $xlabel: string, text describing the X-axis of the plot
8040:
8041: =item $ylabel: string, text describing the Y-axis of the plot
8042:
8043: =item $colors: Array ref containing the hex color codes for the data to be
8044: plotted in. If undefined, default values will be used.
8045:
8046: =item $Xlabels: Array ref containing the labels to be used for the X-axis.
8047:
8048: =item $Ydata1: The first data set
8049:
8050: =item $Min1: The minimum value of the left Y-axis
8051:
8052: =item $Max1: The maximum value of the left Y-axis
8053:
8054: =item $Ydata2: The second data set
8055:
8056: =item $Min2: The minimum value of the right Y-axis
8057:
8058: =item $Max2: The maximum value of the left Y-axis
8059:
8060: =item %Values: hash indicating or overriding any default values which are
8061: passed to graph.png.
8062: Possible values are: width, xskip, x_ticks, x_tick_offset, among others.
8063:
8064: =back
8065:
8066: Returns:
8067:
8068: An <img> tag which references graph.png and the appropriate identifying
8069: information for the plot.
1.136 matthew 8070:
8071: =cut
8072:
8073: ############################################################
8074: ############################################################
1.137 matthew 8075: sub DrawXYYGraph {
8076: my ($Title,$xlabel,$ylabel,$colors,$Xlabels,$Ydata1,$Min1,$Max1,
8077: $Ydata2,$Min2,$Max2,%Values)=@_;
1.136 matthew 8078: #
8079: # Create the identifier for the graph
8080: my $identifier = &get_cgi_id();
8081: my $id = 'cgi.'.$identifier;
8082: #
8083: $Title = '' if (! defined($Title));
8084: $xlabel = '' if (! defined($xlabel));
8085: $ylabel = '' if (! defined($ylabel));
8086: my %ValuesHash =
8087: (
1.369 www 8088: $id.'.title' => &escape($Title),
8089: $id.'.xlabel' => &escape($xlabel),
8090: $id.'.ylabel' => &escape($ylabel),
1.136 matthew 8091: $id.'.labels' => join(',',@$Xlabels),
8092: $id.'.PlotType' => 'XY',
8093: $id.'.NumSets' => 2,
1.137 matthew 8094: $id.'.two_axes' => 1,
8095: $id.'.y1_max_value' => $Max1,
8096: $id.'.y1_min_value' => $Min1,
8097: $id.'.y2_max_value' => $Max2,
8098: $id.'.y2_min_value' => $Min2,
1.136 matthew 8099: );
8100: #
1.137 matthew 8101: if (defined($colors) && ref($colors) eq 'ARRAY') {
8102: $ValuesHash{$id.'.Colors'} = join(',',@{$colors});
8103: }
8104: #
8105: if (! ref($Ydata1) || ref($Ydata1) ne 'ARRAY' ||
8106: ! ref($Ydata2) || ref($Ydata2) ne 'ARRAY'){
1.136 matthew 8107: return '';
8108: }
8109: my $NumSets=1;
1.137 matthew 8110: foreach my $array ($Ydata1,$Ydata2){
1.136 matthew 8111: next if (! ref($array));
8112: $ValuesHash{$id.'.data.'.$NumSets++} = join(',',@$array);
1.137 matthew 8113: }
8114: #
8115: # Deal with other parameters
8116: while (my ($key,$value) = each(%Values)) {
8117: $ValuesHash{$id.'.'.$key} = $value;
1.136 matthew 8118: }
8119: #
1.646 raeburn 8120: &Apache::lonnet::appenv(\%ValuesHash);
1.130 albertel 8121: return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';
1.139 matthew 8122: }
8123:
8124: ############################################################
8125: ############################################################
8126:
8127: =pod
8128:
1.157 matthew 8129: =back
8130:
1.139 matthew 8131: =head1 Statistics helper routines?
8132:
8133: Bad place for them but what the hell.
8134:
1.157 matthew 8135: =over 4
8136:
1.648 raeburn 8137: =item * &chartlink()
1.139 matthew 8138:
8139: Returns a link to the chart for a specific student.
8140:
8141: Inputs:
8142:
8143: =over 4
8144:
8145: =item $linktext: The text of the link
8146:
8147: =item $sname: The students username
8148:
8149: =item $sdomain: The students domain
8150:
8151: =back
8152:
1.157 matthew 8153: =back
8154:
1.139 matthew 8155: =cut
8156:
8157: ############################################################
8158: ############################################################
8159: sub chartlink {
8160: my ($linktext, $sname, $sdomain) = @_;
8161: my $link = '<a href="/adm/statistics?reportSelected=student_assessment'.
1.369 www 8162: '&SelectedStudent='.&escape($sname.':'.$sdomain).
1.219 albertel 8163: '&chartoutputmode='.HTML::Entities::encode('html, with all links').
1.139 matthew 8164: '">'.$linktext.'</a>';
1.153 matthew 8165: }
8166:
8167: #######################################################
8168: #######################################################
8169:
8170: =pod
8171:
8172: =head1 Course Environment Routines
1.157 matthew 8173:
8174: =over 4
1.153 matthew 8175:
1.648 raeburn 8176: =item * &restore_course_settings()
1.153 matthew 8177:
1.648 raeburn 8178: =item * &store_course_settings()
1.153 matthew 8179:
8180: Restores/Store indicated form parameters from the course environment.
8181: Will not overwrite existing values of the form parameters.
8182:
8183: Inputs:
8184: a scalar describing the data (e.g. 'chart', 'problem_analysis')
8185:
8186: a hash ref describing the data to be stored. For example:
8187:
8188: %Save_Parameters = ('Status' => 'scalar',
8189: 'chartoutputmode' => 'scalar',
8190: 'chartoutputdata' => 'scalar',
8191: 'Section' => 'array',
1.373 raeburn 8192: 'Group' => 'array',
1.153 matthew 8193: 'StudentData' => 'array',
8194: 'Maps' => 'array');
8195:
8196: Returns: both routines return nothing
8197:
1.631 raeburn 8198: =back
8199:
1.153 matthew 8200: =cut
8201:
8202: #######################################################
8203: #######################################################
8204: sub store_course_settings {
1.496 albertel 8205: return &store_settings($env{'request.course.id'},@_);
8206: }
8207:
8208: sub store_settings {
1.153 matthew 8209: # save to the environment
8210: # appenv the same items, just to be safe
1.300 albertel 8211: my $udom = $env{'user.domain'};
8212: my $uname = $env{'user.name'};
1.496 albertel 8213: my ($context,$prefix,$Settings) = @_;
1.153 matthew 8214: my %SaveHash;
8215: my %AppHash;
8216: while (my ($setting,$type) = each(%$Settings)) {
1.496 albertel 8217: my $basename = join('.','internal',$context,$prefix,$setting);
1.300 albertel 8218: my $envname = 'environment.'.$basename;
1.258 albertel 8219: if (exists($env{'form.'.$setting})) {
1.153 matthew 8220: # Save this value away
8221: if ($type eq 'scalar' &&
1.258 albertel 8222: (! exists($env{$envname}) ||
8223: $env{$envname} ne $env{'form.'.$setting})) {
8224: $SaveHash{$basename} = $env{'form.'.$setting};
8225: $AppHash{$envname} = $env{'form.'.$setting};
1.153 matthew 8226: } elsif ($type eq 'array') {
8227: my $stored_form;
1.258 albertel 8228: if (ref($env{'form.'.$setting})) {
1.153 matthew 8229: $stored_form = join(',',
8230: map {
1.369 www 8231: &escape($_);
1.258 albertel 8232: } sort(@{$env{'form.'.$setting}}));
1.153 matthew 8233: } else {
8234: $stored_form =
1.369 www 8235: &escape($env{'form.'.$setting});
1.153 matthew 8236: }
8237: # Determine if the array contents are the same.
1.258 albertel 8238: if ($stored_form ne $env{$envname}) {
1.153 matthew 8239: $SaveHash{$basename} = $stored_form;
8240: $AppHash{$envname} = $stored_form;
8241: }
8242: }
8243: }
8244: }
8245: my $put_result = &Apache::lonnet::put('environment',\%SaveHash,
1.300 albertel 8246: $udom,$uname);
1.153 matthew 8247: if ($put_result !~ /^(ok|delayed)/) {
8248: &Apache::lonnet::logthis('unable to save form parameters, '.
8249: 'got error:'.$put_result);
8250: }
8251: # Make sure these settings stick around in this session, too
1.646 raeburn 8252: &Apache::lonnet::appenv(\%AppHash);
1.153 matthew 8253: return;
8254: }
8255:
8256: sub restore_course_settings {
1.499 albertel 8257: return &restore_settings($env{'request.course.id'},@_);
1.496 albertel 8258: }
8259:
8260: sub restore_settings {
8261: my ($context,$prefix,$Settings) = @_;
1.153 matthew 8262: while (my ($setting,$type) = each(%$Settings)) {
1.258 albertel 8263: next if (exists($env{'form.'.$setting}));
1.496 albertel 8264: my $envname = 'environment.internal.'.$context.'.'.$prefix.
1.153 matthew 8265: '.'.$setting;
1.258 albertel 8266: if (exists($env{$envname})) {
1.153 matthew 8267: if ($type eq 'scalar') {
1.258 albertel 8268: $env{'form.'.$setting} = $env{$envname};
1.153 matthew 8269: } elsif ($type eq 'array') {
1.258 albertel 8270: $env{'form.'.$setting} = [
1.153 matthew 8271: map {
1.369 www 8272: &unescape($_);
1.258 albertel 8273: } split(',',$env{$envname})
1.153 matthew 8274: ];
8275: }
8276: }
8277: }
1.127 matthew 8278: }
8279:
1.618 raeburn 8280: #######################################################
8281: #######################################################
8282:
8283: =pod
8284:
8285: =head1 Domain E-mail Routines
8286:
8287: =over 4
8288:
1.648 raeburn 8289: =item * &build_recipient_list()
1.618 raeburn 8290:
8291: Build recipient lists for three types of e-mail:
8292: (a) Error Reports, (b) Package Updates, (c) Help requests, generated by
1.619 raeburn 8293: lonerrorhandler.pm, CHECKRPMS and lonsupportreq.pm respectively.
1.618 raeburn 8294:
8295: Inputs:
1.619 raeburn 8296: defmail (scalar - email address of default recipient),
1.618 raeburn 8297: mailing type (scalar - errormail, packagesmail, or helpdeskmail),
1.619 raeburn 8298: defdom (domain for which to retrieve configuration settings),
8299: origmail (scalar - email address of recipient from loncapa.conf,
8300: i.e., predates configuration by DC via domainprefs.pm
1.618 raeburn 8301:
1.655 raeburn 8302: Returns: comma separated list of addresses to which to send e-mail.
8303:
8304: =back
1.618 raeburn 8305:
8306: =cut
8307:
8308: ############################################################
8309: ############################################################
8310: sub build_recipient_list {
1.619 raeburn 8311: my ($defmail,$mailing,$defdom,$origmail) = @_;
1.618 raeburn 8312: my @recipients;
8313: my $otheremails;
8314: my %domconfig =
8315: &Apache::lonnet::get_dom('configuration',['contacts'],$defdom);
8316: if (ref($domconfig{'contacts'}) eq 'HASH') {
8317: if (ref($domconfig{'contacts'}{$mailing}) eq 'HASH') {
8318: my @contacts = ('adminemail','supportemail');
8319: foreach my $item (@contacts) {
8320: if ($domconfig{'contacts'}{$mailing}{$item}) {
1.619 raeburn 8321: my $addr = $domconfig{'contacts'}{$item};
8322: if (!grep(/^\Q$addr\E$/,@recipients)) {
8323: push(@recipients,$addr);
8324: }
1.618 raeburn 8325: }
8326: $otheremails = $domconfig{'contacts'}{$mailing}{'others'};
8327: }
8328: }
1.619 raeburn 8329: } elsif ($origmail ne '') {
8330: push(@recipients,$origmail);
1.618 raeburn 8331: }
8332: if ($defmail ne '') {
8333: push(@recipients,$defmail);
8334: }
8335: if ($otheremails) {
1.619 raeburn 8336: my @others;
8337: if ($otheremails =~ /,/) {
8338: @others = split(/,/,$otheremails);
1.618 raeburn 8339: } else {
1.619 raeburn 8340: push(@others,$otheremails);
8341: }
8342: foreach my $addr (@others) {
8343: if (!grep(/^\Q$addr\E$/,@recipients)) {
8344: push(@recipients,$addr);
8345: }
1.618 raeburn 8346: }
8347: }
1.619 raeburn 8348: my $recipientlist = join(',',@recipients);
1.618 raeburn 8349: return $recipientlist;
8350: }
8351:
1.127 matthew 8352: ############################################################
8353: ############################################################
1.154 albertel 8354:
1.655 raeburn 8355: =pod
8356:
8357: =head1 Course Catalog Routines
8358:
8359: =over 4
8360:
8361: =item * &gather_categories()
8362:
8363: Converts category definitions - keys of categories hash stored in
8364: coursecategories in configuration.db on the primary library server in a
8365: domain - to an array. Also generates javascript and idx hash used to
8366: generate Domain Coordinator interface for editing Course Categories.
8367:
8368: Inputs:
1.663 raeburn 8369:
1.655 raeburn 8370: categories (reference to hash of category definitions).
1.663 raeburn 8371:
1.655 raeburn 8372: cats (reference to array of arrays/hashes which encapsulates hierarchy of
8373: categories and subcategories).
1.663 raeburn 8374:
1.655 raeburn 8375: idx (reference to hash of counters used in Domain Coordinator interface for
8376: editing Course Categories).
1.663 raeburn 8377:
1.655 raeburn 8378: jsarray (reference to array of categories used to create Javascript arrays for
8379: Domain Coordinator interface for editing Course Categories).
8380:
8381: Returns: nothing
8382:
8383: Side effects: populates cats, idx and jsarray.
8384:
8385: =cut
8386:
8387: sub gather_categories {
8388: my ($categories,$cats,$idx,$jsarray) = @_;
8389: my %counters;
8390: my $num = 0;
8391: foreach my $item (keys(%{$categories})) {
8392: my ($cat,$container,$depth) = map { &unescape($_); } split(/:/,$item);
8393: if ($container eq '' && $depth == 0) {
8394: $cats->[$depth][$categories->{$item}] = $cat;
8395: } else {
8396: $cats->[$depth]{$container}[$categories->{$item}] = $cat;
8397: }
8398: my ($escitem,$tail) = split(/:/,$item,2);
8399: if ($counters{$tail} eq '') {
8400: $counters{$tail} = $num;
8401: $num ++;
8402: }
8403: if (ref($idx) eq 'HASH') {
8404: $idx->{$item} = $counters{$tail};
8405: }
8406: if (ref($jsarray) eq 'ARRAY') {
8407: push(@{$jsarray->[$counters{$tail}]},$item);
8408: }
8409: }
8410: return;
8411: }
8412:
8413: =pod
8414:
8415: =item * &extract_categories()
8416:
8417: Used to generate breadcrumb trails for course categories.
8418:
8419: Inputs:
1.663 raeburn 8420:
1.655 raeburn 8421: categories (reference to hash of category definitions).
1.663 raeburn 8422:
1.655 raeburn 8423: cats (reference to array of arrays/hashes which encapsulates hierarchy of
8424: categories and subcategories).
1.663 raeburn 8425:
1.655 raeburn 8426: trails (reference to array of breacrumb trails for each category).
1.663 raeburn 8427:
1.655 raeburn 8428: allitems (reference to hash - key is category key
8429: (format: escaped(name):escaped(parent category):depth in hierarchy).
1.663 raeburn 8430:
1.655 raeburn 8431: idx (reference to hash of counters used in Domain Coordinator interface for
8432: editing Course Categories).
1.663 raeburn 8433:
1.655 raeburn 8434: jsarray (reference to array of categories used to create Javascript arrays for
8435: Domain Coordinator interface for editing Course Categories).
8436:
1.665 raeburn 8437: subcats (reference to hash of arrays containing all subcategories within each
8438: category, -recursive)
8439:
1.655 raeburn 8440: Returns: nothing
8441:
8442: Side effects: populates trails and allitems hash references.
8443:
8444: =cut
8445:
8446: sub extract_categories {
1.665 raeburn 8447: my ($categories,$cats,$trails,$allitems,$idx,$jsarray,$subcats) = @_;
1.655 raeburn 8448: if (ref($categories) eq 'HASH') {
8449: &gather_categories($categories,$cats,$idx,$jsarray);
8450: if (ref($cats->[0]) eq 'ARRAY') {
8451: for (my $i=0; $i<@{$cats->[0]}; $i++) {
8452: my $name = $cats->[0][$i];
8453: my $item = &escape($name).'::0';
8454: my $trailstr;
8455: if ($name eq 'instcode') {
8456: $trailstr = &mt('Official courses (with institutional codes)');
8457: } else {
8458: $trailstr = $name;
8459: }
8460: if ($allitems->{$item} eq '') {
8461: push(@{$trails},$trailstr);
8462: $allitems->{$item} = scalar(@{$trails})-1;
8463: }
8464: my @parents = ($name);
8465: if (ref($cats->[1]{$name}) eq 'ARRAY') {
8466: for (my $j=0; $j<@{$cats->[1]{$name}}; $j++) {
8467: my $category = $cats->[1]{$name}[$j];
1.665 raeburn 8468: if (ref($subcats) eq 'HASH') {
8469: push(@{$subcats->{$item}},&escape($category).':'.&escape($name).':1');
8470: }
8471: &recurse_categories($cats,2,$category,$trails,$allitems,\@parents,$subcats);
8472: }
8473: } else {
8474: if (ref($subcats) eq 'HASH') {
8475: $subcats->{$item} = [];
1.655 raeburn 8476: }
8477: }
8478: }
8479: }
8480: }
8481: return;
8482: }
8483:
8484: =pod
8485:
8486: =item *&recurse_categories()
8487:
8488: Recursively used to generate breadcrumb trails for course categories.
8489:
8490: Inputs:
1.663 raeburn 8491:
1.655 raeburn 8492: cats (reference to array of arrays/hashes which encapsulates hierarchy of
8493: categories and subcategories).
1.663 raeburn 8494:
1.655 raeburn 8495: depth (current depth in hierarchy of categories and sub-categories - 0 indexed).
1.663 raeburn 8496:
8497: category (current course category, for which breadcrumb trail is being generated).
8498:
8499: trails (reference to array of breadcrumb trails for each category).
8500:
1.655 raeburn 8501: allitems (reference to hash - key is category key
8502: (format: escaped(name):escaped(parent category):depth in hierarchy).
1.663 raeburn 8503:
1.655 raeburn 8504: parents (array containing containers directories for current category,
8505: back to top level).
8506:
8507: Returns: nothing
8508:
8509: Side effects: populates trails and allitems hash references
8510:
8511: =cut
8512:
8513: sub recurse_categories {
1.665 raeburn 8514: my ($cats,$depth,$category,$trails,$allitems,$parents,$subcats) = @_;
1.655 raeburn 8515: my $shallower = $depth - 1;
8516: if (ref($cats->[$depth]{$category}) eq 'ARRAY') {
8517: for (my $k=0; $k<@{$cats->[$depth]{$category}}; $k++) {
8518: my $name = $cats->[$depth]{$category}[$k];
8519: my $item = &escape($category).':'.&escape($parents->[-1]).':'.$shallower;
8520: my $trailstr = join(' -> ',(@{$parents},$category));
8521: if ($allitems->{$item} eq '') {
8522: push(@{$trails},$trailstr);
8523: $allitems->{$item} = scalar(@{$trails})-1;
8524: }
8525: my $deeper = $depth+1;
8526: push(@{$parents},$category);
1.665 raeburn 8527: if (ref($subcats) eq 'HASH') {
8528: my $subcat = &escape($name).':'.$category.':'.$depth;
8529: for (my $j=@{$parents}; $j>=0; $j--) {
8530: my $higher;
8531: if ($j > 0) {
8532: $higher = &escape($parents->[$j]).':'.
8533: &escape($parents->[$j-1]).':'.$j;
8534: } else {
8535: $higher = &escape($parents->[$j]).'::'.$j;
8536: }
8537: push(@{$subcats->{$higher}},$subcat);
8538: }
8539: }
8540: &recurse_categories($cats,$deeper,$name,$trails,$allitems,$parents,
8541: $subcats);
1.655 raeburn 8542: pop(@{$parents});
8543: }
8544: } else {
8545: my $item = &escape($category).':'.&escape($parents->[-1]).':'.$shallower;
8546: my $trailstr = join(' -> ',(@{$parents},$category));
8547: if ($allitems->{$item} eq '') {
8548: push(@{$trails},$trailstr);
8549: $allitems->{$item} = scalar(@{$trails})-1;
8550: }
8551: }
8552: return;
8553: }
8554:
1.663 raeburn 8555: =pod
8556:
8557: =item *&assign_categories_table()
8558:
8559: Create a datatable for display of hierarchical categories in a domain,
8560: with checkboxes to allow a course to be categorized.
8561:
8562: Inputs:
8563:
8564: cathash - reference to hash of categories defined for the domain (from
8565: configuration.db)
8566:
8567: currcat - scalar with an & separated list of categories assigned to a course.
8568:
8569: Returns: $output (markup to be displayed)
8570:
8571: =cut
8572:
8573: sub assign_categories_table {
8574: my ($cathash,$currcat) = @_;
8575: my $output;
8576: if (ref($cathash) eq 'HASH') {
8577: my (@cats,@trails,%allitems,%idx,@jsarray,@path,$maxdepth);
8578: &extract_categories($cathash,\@cats,\@trails,\%allitems,\%idx,\@jsarray);
8579: $maxdepth = scalar(@cats);
8580: if (@cats > 0) {
8581: my $itemcount = 0;
8582: if (ref($cats[0]) eq 'ARRAY') {
8583: $output = &Apache::loncommon::start_data_table();
8584: my @currcategories;
8585: if ($currcat ne '') {
8586: @currcategories = split('&',$currcat);
8587: }
8588: for (my $i=0; $i<@{$cats[0]}; $i++) {
8589: my $parent = $cats[0][$i];
8590: my $css_class = $itemcount%2?' class="LC_odd_row"':'';
8591: next if ($parent eq 'instcode');
8592: my $item = &escape($parent).'::0';
8593: my $checked = '';
8594: if (@currcategories > 0) {
8595: if (grep(/^\Q$item\E$/,@currcategories)) {
8596: $checked = ' checked="checked" ';
8597: }
8598: }
1.675 raeburn 8599: $output .= '<tr '.$css_class.'><td><span class="LC_nobreak">'.
8600: '<input type="checkbox" name="usecategory" value="'.
8601: $item.'"'.$checked.' />'.$parent.'</span>'.
8602: '<input type="hidden" name="catname" value="'.$parent.'" /></td>';
1.663 raeburn 8603: my $depth = 1;
8604: push(@path,$parent);
8605: $output .= &assign_category_rows($itemcount,\@cats,$depth,$parent,\@path,\@currcategories);
8606: pop(@path);
8607: $output .= '</tr><tr><td colspan="'.$maxdepth.'" class="LC_row_separator"></td></tr>';
8608: $itemcount ++;
8609: }
8610: $output .= &Apache::loncommon::end_data_table();
8611: }
8612: }
8613: }
8614: return $output;
8615: }
8616:
8617: =pod
8618:
8619: =item *&assign_category_rows()
8620:
8621: Create a datatable row for display of nested categories in a domain,
8622: with checkboxes to allow a course to be categorized,called recursively.
8623:
8624: Inputs:
8625:
8626: itemcount - track row number for alternating colors
8627:
8628: cats - reference to array of arrays/hashes which encapsulates hierarchy of
8629: categories and subcategories.
8630:
8631: depth - current depth in hierarchy of categories and sub-categories - 0 indexed.
8632:
8633: parent - parent of current category item
8634:
8635: path - Array containing all categories back up through the hierarchy from the
8636: current category to the top level.
8637:
8638: currcategories - reference to array of current categories assigned to the course
8639:
8640: Returns: $output (markup to be displayed).
8641:
8642: =cut
8643:
8644: sub assign_category_rows {
8645: my ($itemcount,$cats,$depth,$parent,$path,$currcategories) = @_;
8646: my ($text,$name,$item,$chgstr);
8647: if (ref($cats) eq 'ARRAY') {
8648: my $maxdepth = scalar(@{$cats});
8649: if (ref($cats->[$depth]) eq 'HASH') {
8650: if (ref($cats->[$depth]{$parent}) eq 'ARRAY') {
8651: my $numchildren = @{$cats->[$depth]{$parent}};
8652: my $css_class = $itemcount%2?' class="LC_odd_row"':'';
8653: $text .= '<td><table class="LC_datatable">';
8654: for (my $j=0; $j<$numchildren; $j++) {
8655: $name = $cats->[$depth]{$parent}[$j];
8656: $item = &escape($name).':'.&escape($parent).':'.$depth;
8657: my $deeper = $depth+1;
8658: my $checked = '';
8659: if (ref($currcategories) eq 'ARRAY') {
8660: if (@{$currcategories} > 0) {
8661: if (grep(/^\Q$item\E$/,@{$currcategories})) {
8662: $checked = ' checked="checked" ';
8663: }
8664: }
8665: }
1.664 raeburn 8666: $text .= '<tr><td><span class="LC_nobreak"><label>'.
8667: '<input type="checkbox" name="usecategory" value="'.
1.675 raeburn 8668: $item.'"'.$checked.' />'.$name.'</label></span>'.
8669: '<input type="hidden" name="catname" value="'.$name.'" />'.
8670: '</td><td>';
1.663 raeburn 8671: if (ref($path) eq 'ARRAY') {
8672: push(@{$path},$name);
8673: $text .= &assign_category_rows($itemcount,$cats,$deeper,$name,$path,$currcategories);
8674: pop(@{$path});
8675: }
8676: $text .= '</td></tr>';
8677: }
8678: $text .= '</table></td>';
8679: }
8680: }
8681: }
8682: return $text;
8683: }
8684:
1.655 raeburn 8685: ############################################################
8686: ############################################################
8687:
8688:
1.443 albertel 8689: sub commit_customrole {
1.664 raeburn 8690: my ($udom,$uname,$url,$three,$four,$five,$start,$end,$context) = @_;
1.630 raeburn 8691: my $output = &mt('Assigning custom role').' "'.$five.'" by '.$four.':'.$three.' in '.$url.
1.443 albertel 8692: ($start?', '.&mt('starting').' '.localtime($start):'').
8693: ($end?', ending '.localtime($end):'').': <b>'.
8694: &Apache::lonnet::assigncustomrole(
1.664 raeburn 8695: $udom,$uname,$url,$three,$four,$five,$end,$start,undef,undef,$context).
1.443 albertel 8696: '</b><br />';
8697: return $output;
8698: }
8699:
8700: sub commit_standardrole {
1.541 raeburn 8701: my ($udom,$uname,$url,$three,$start,$end,$one,$two,$sec,$context) = @_;
8702: my ($output,$logmsg,$linefeed);
8703: if ($context eq 'auto') {
8704: $linefeed = "\n";
8705: } else {
8706: $linefeed = "<br />\n";
8707: }
1.443 albertel 8708: if ($three eq 'st') {
1.541 raeburn 8709: my $result = &commit_studentrole(\$logmsg,$udom,$uname,$url,$three,$start,$end,
8710: $one,$two,$sec,$context);
8711: if (($result =~ /^error/) || ($result eq 'not_in_class') ||
1.626 raeburn 8712: ($result eq 'unknown_course') || ($result eq 'refused')) {
8713: $output = $logmsg.' '.&mt('Error: ').$result."\n";
1.443 albertel 8714: } else {
1.541 raeburn 8715: $output = $logmsg.$linefeed.&mt('Assigning').' '.$three.' in '.$url.
1.443 albertel 8716: ($start?', '.&mt('starting').' '.localtime($start):'').
1.541 raeburn 8717: ($end?', '.&mt('ending').' '.localtime($end):'').': ';
8718: if ($context eq 'auto') {
8719: $output .= $result.$linefeed.&mt('Add to classlist').': ok';
8720: } else {
8721: $output .= '<b>'.$result.'</b>'.$linefeed.
8722: &mt('Add to classlist').': <b>ok</b>';
8723: }
8724: $output .= $linefeed;
1.443 albertel 8725: }
8726: } else {
8727: $output = &mt('Assigning').' '.$three.' in '.$url.
8728: ($start?', '.&mt('starting').' '.localtime($start):'').
1.541 raeburn 8729: ($end?', '.&mt('ending').' '.localtime($end):'').': ';
1.652 raeburn 8730: my $result = &Apache::lonnet::assignrole($udom,$uname,$url,$three,$end,$start,'','',$context);
1.541 raeburn 8731: if ($context eq 'auto') {
8732: $output .= $result.$linefeed;
8733: } else {
8734: $output .= '<b>'.$result.'</b>'.$linefeed;
8735: }
1.443 albertel 8736: }
8737: return $output;
8738: }
8739:
8740: sub commit_studentrole {
1.541 raeburn 8741: my ($logmsg,$udom,$uname,$url,$three,$start,$end,$one,$two,$sec,$context) = @_;
1.626 raeburn 8742: my ($result,$linefeed,$oldsecurl,$newsecurl);
1.541 raeburn 8743: if ($context eq 'auto') {
8744: $linefeed = "\n";
8745: } else {
8746: $linefeed = '<br />'."\n";
8747: }
1.443 albertel 8748: if (defined($one) && defined($two)) {
8749: my $cid=$one.'_'.$two;
8750: my $oldsec=&Apache::lonnet::getsection($udom,$uname,$cid);
8751: my $secchange = 0;
8752: my $expire_role_result;
8753: my $modify_section_result;
1.628 raeburn 8754: if ($oldsec ne '-1') {
8755: if ($oldsec ne $sec) {
1.443 albertel 8756: $secchange = 1;
1.628 raeburn 8757: my $now = time;
1.443 albertel 8758: my $uurl='/'.$cid;
8759: $uurl=~s/\_/\//g;
8760: if ($oldsec) {
8761: $uurl.='/'.$oldsec;
8762: }
1.626 raeburn 8763: $oldsecurl = $uurl;
1.628 raeburn 8764: $expire_role_result =
1.652 raeburn 8765: &Apache::lonnet::assignrole($udom,$uname,$uurl,'st',$now,'','',$context);
1.628 raeburn 8766: if ($env{'request.course.sec'} ne '') {
8767: if ($expire_role_result eq 'refused') {
8768: my @roles = ('st');
8769: my @statuses = ('previous');
8770: my @roledoms = ($one);
8771: my $withsec = 1;
8772: my %roleshash =
8773: &Apache::lonnet::get_my_roles($uname,$udom,'userroles',
8774: \@statuses,\@roles,\@roledoms,$withsec);
8775: if (defined ($roleshash{$two.':'.$one.':st:'.$oldsec})) {
8776: my ($oldstart,$oldend) =
8777: split(':',$roleshash{$two.':'.$one.':st:'.$oldsec});
8778: if ($oldend > 0 && $oldend <= $now) {
8779: $expire_role_result = 'ok';
8780: }
8781: }
8782: }
8783: }
1.443 albertel 8784: $result = $expire_role_result;
8785: }
8786: }
8787: if (($expire_role_result eq 'ok') || ($secchange == 0)) {
1.652 raeburn 8788: $modify_section_result = &Apache::lonnet::modify_student_enrollment($udom,$uname,undef,undef,undef,undef,undef,$sec,$end,$start,'','',$cid,'',$context);
1.443 albertel 8789: if ($modify_section_result =~ /^ok/) {
8790: if ($secchange == 1) {
1.628 raeburn 8791: if ($sec eq '') {
8792: $$logmsg .= &mt('Section for [_1] switched from (possibly expired) old section: [_2] to student role without a section.',$uname,$oldsec).$linefeed;
8793: } else {
8794: $$logmsg .= &mt('Section for [_1] switched from (possibly expired) old section: [_2] to new section: [_3].',$uname,$oldsec,$sec).$linefeed;
8795: }
1.443 albertel 8796: } elsif ($oldsec eq '-1') {
1.628 raeburn 8797: if ($sec eq '') {
8798: $$logmsg .= &mt('New student role without a section for [_1] in course [_2].',$uname,$cid).$linefeed;
8799: } else {
8800: $$logmsg .= &mt('New student role for [_1] in section [_2] in course [_3].',$uname,$sec,$cid).$linefeed;
8801: }
1.443 albertel 8802: } else {
1.628 raeburn 8803: if ($sec eq '') {
8804: $$logmsg .= &mt('Student [_1] assigned to course [_2] without a section.',$uname,$cid).$linefeed;
8805: } else {
8806: $$logmsg .= &mt('Student [_1] assigned to section [_2] in course [_3].',$uname,$sec,$cid).$linefeed;
8807: }
1.443 albertel 8808: }
8809: } else {
1.628 raeburn 8810: if ($secchange) {
8811: $$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;
8812: } else {
8813: $$logmsg .= &mt('Error when attempting to modify role for [_1] for section: "[_2]" in course [_3] -error:',$uname,$sec,$cid).' '.$modify_section_result.$linefeed;
8814: }
1.443 albertel 8815: }
8816: $result = $modify_section_result;
8817: } elsif ($secchange == 1) {
1.628 raeburn 8818: if ($oldsec eq '') {
8819: $$logmsg .= &mt('Error when attempting to expire existing role without a section for [_1] in course [_3] -error: ',$uname,$cid).' '.$expire_role_result.$linefeed;
8820: } else {
8821: $$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;
8822: }
1.626 raeburn 8823: if ($expire_role_result eq 'refused') {
8824: my $newsecurl = '/'.$cid;
8825: $newsecurl =~ s/\_/\//g;
8826: if ($sec ne '') {
8827: $newsecurl.='/'.$sec;
8828: }
8829: if (&Apache::lonnet::allowed('cst',$newsecurl) && !(&Apache::lonnet::allowed('cst',$oldsecurl))) {
8830: if ($sec eq '') {
8831: $$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;
8832: } else {
8833: $$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;
8834: }
8835: }
8836: }
1.443 albertel 8837: }
8838: } else {
1.626 raeburn 8839: $$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 8840: $result = "error: incomplete course id\n";
8841: }
8842: return $result;
8843: }
8844:
8845: ############################################################
8846: ############################################################
8847:
1.566 albertel 8848: sub check_clone {
1.578 raeburn 8849: my ($args,$linefeed) = @_;
1.566 albertel 8850: my $cloneid='/'.$args->{'clonedomain'}.'/'.$args->{'clonecourse'};
8851: my ($clonecrsudom,$clonecrsunum)= &LONCAPA::split_courseid($cloneid);
8852: my $clonehome=&Apache::lonnet::homeserver($clonecrsunum,$clonecrsudom);
8853: my $clonemsg;
8854: my $can_clone = 0;
8855:
8856: if ($clonehome eq 'no_host') {
1.578 raeburn 8857: $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 8858: } else {
8859: my %clonedesc = &Apache::lonnet::coursedescription($cloneid,{'one_time' => 1});
1.568 albertel 8860: if ($env{'request.role.domain'} eq $args->{'clonedomain'}) {
1.566 albertel 8861: $can_clone = 1;
8862: } else {
8863: my %clonehash = &Apache::lonnet::get('environment',['cloners'],
8864: $args->{'clonedomain'},$args->{'clonecourse'});
8865: my @cloners = split(/,/,$clonehash{'cloners'});
1.578 raeburn 8866: if (grep(/^\*$/,@cloners)) {
8867: $can_clone = 1;
8868: } elsif (grep(/^\*\:\Q$args->{'ccdomain'}\E$/,@cloners)) {
8869: $can_clone = 1;
8870: } else {
8871: my %roleshash =
8872: &Apache::lonnet::get_my_roles($args->{'ccuname'},
8873: $args->{'ccdomain'},
8874: 'userroles',['active'],['cc'],
8875: [$args->{'clonedomain'}]);
8876: if (($roleshash{$args->{'clonecourse'}.':'.$args->{'clonedomain'}.':cc'}) || (grep(/^\Q$args->{'ccuname'}\E:\Q$args->{'ccdomain'}\E$/,@cloners))) {
8877: $can_clone = 1;
8878: } else {
8879: $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'});
8880: }
1.566 albertel 8881: }
1.578 raeburn 8882: }
1.566 albertel 8883: }
8884: return ($can_clone, $clonemsg, $cloneid, $clonehome);
8885: }
8886:
1.444 albertel 8887: sub construct_course {
1.541 raeburn 8888: my ($args,$logmsg,$courseid,$crsudom,$crsunum,$udom,$uname,$context) = @_;
1.444 albertel 8889: my $outcome;
1.541 raeburn 8890: my $linefeed = '<br />'."\n";
8891: if ($context eq 'auto') {
8892: $linefeed = "\n";
8893: }
1.566 albertel 8894:
8895: #
8896: # Are we cloning?
8897: #
8898: my ($can_clone, $clonemsg, $cloneid, $clonehome);
8899: if (($args->{'clonecourse'}) && ($args->{'clonedomain'})) {
1.578 raeburn 8900: ($can_clone, $clonemsg, $cloneid, $clonehome) = &check_clone($args,$linefeed);
1.566 albertel 8901: if ($context ne 'auto') {
1.578 raeburn 8902: if ($clonemsg ne '') {
8903: $clonemsg = '<span class="LC_error">'.$clonemsg.'</span>';
8904: }
1.566 albertel 8905: }
8906: $outcome .= $clonemsg.$linefeed;
8907:
8908: if (!$can_clone) {
8909: return (0,$outcome);
8910: }
8911: }
8912:
1.444 albertel 8913: #
8914: # Open course
8915: #
8916: my $crstype = lc($args->{'crstype'});
8917: my %cenv=();
8918: $$courseid=&Apache::lonnet::createcourse($args->{'course_domain'},
8919: $args->{'cdescr'},
8920: $args->{'curl'},
8921: $args->{'course_home'},
8922: $args->{'nonstandard'},
8923: $args->{'crscode'},
8924: $args->{'ccuname'}.':'.
8925: $args->{'ccdomain'},
8926: $args->{'crstype'});
8927:
8928: # Note: The testing routines depend on this being output; see
8929: # Utils::Course. This needs to at least be output as a comment
8930: # if anyone ever decides to not show this, and Utils::Course::new
8931: # will need to be suitably modified.
1.541 raeburn 8932: $outcome .= &mt('New LON-CAPA [_1] ID: [_2]',$crstype,$$courseid).$linefeed;
1.444 albertel 8933: #
8934: # Check if created correctly
8935: #
1.479 albertel 8936: ($$crsudom,$$crsunum)= &LONCAPA::split_courseid($$courseid);
1.444 albertel 8937: my $crsuhome=&Apache::lonnet::homeserver($$crsunum,$$crsudom);
1.541 raeburn 8938: $outcome .= &mt('Created on').': '.$crsuhome.$linefeed;
1.566 albertel 8939:
1.444 albertel 8940: #
1.566 albertel 8941: # Do the cloning
8942: #
8943: if ($can_clone && $cloneid) {
8944: $clonemsg = &mt('Cloning [_1] from [_2]',$crstype,$clonehome);
8945: if ($context ne 'auto') {
8946: $clonemsg = '<span class="LC_success">'.$clonemsg.'</span>';
8947: }
8948: $outcome .= $clonemsg.$linefeed;
8949: my %oldcenv=&Apache::lonnet::dump('environment',$$crsudom,$$crsunum);
1.444 albertel 8950: # Copy all files
1.637 www 8951: &Apache::lonclonecourse::copycoursefiles($cloneid,$$courseid,$args->{'datemode'},$args->{'dateshift'});
1.444 albertel 8952: # Restore URL
1.566 albertel 8953: $cenv{'url'}=$oldcenv{'url'};
1.444 albertel 8954: # Restore title
1.566 albertel 8955: $cenv{'description'}=$oldcenv{'description'};
1.444 albertel 8956: # Mark as cloned
1.566 albertel 8957: $cenv{'clonedfrom'}=$cloneid;
1.638 www 8958: # Need to clone grading mode
8959: my %newenv=&Apache::lonnet::get('environment',['grading'],$$crsudom,$$crsunum);
8960: $cenv{'grading'}=$newenv{'grading'};
8961: # Do not clone these environment entries
8962: &Apache::lonnet::del('environment',
8963: ['default_enrollment_start_date',
8964: 'default_enrollment_end_date',
8965: 'question.email',
8966: 'policy.email',
8967: 'comment.email',
8968: 'pch.users.denied',
8969: 'plc.users.denied'],
8970: $$crsudom,$$crsunum);
1.444 albertel 8971: }
1.566 albertel 8972:
1.444 albertel 8973: #
8974: # Set environment (will override cloned, if existing)
8975: #
8976: my @sections = ();
8977: my @xlists = ();
8978: if ($args->{'crstype'}) {
8979: $cenv{'type'}=$args->{'crstype'};
8980: }
8981: if ($args->{'crsid'}) {
8982: $cenv{'courseid'}=$args->{'crsid'};
8983: }
8984: if ($args->{'crscode'}) {
8985: $cenv{'internal.coursecode'}=$args->{'crscode'};
8986: }
8987: if ($args->{'crsquota'} ne '') {
8988: $cenv{'internal.coursequota'}=$args->{'crsquota'};
8989: } else {
8990: $cenv{'internal.coursequota'}=$args->{'crsquota'} = 20;
8991: }
8992: if ($args->{'ccuname'}) {
8993: $cenv{'internal.courseowner'} = $args->{'ccuname'}.
8994: ':'.$args->{'ccdomain'};
8995: } else {
8996: $cenv{'internal.courseowner'} = $args->{'curruser'};
8997: }
8998: my @badclasses = (); # Used to accumulate sections/crosslistings that did not pass classlist access check for course owner.
8999: if ($args->{'crssections'}) {
9000: $cenv{'internal.sectionnums'} = '';
9001: if ($args->{'crssections'} =~ m/,/) {
9002: @sections = split/,/,$args->{'crssections'};
9003: } else {
9004: $sections[0] = $args->{'crssections'};
9005: }
9006: if (@sections > 0) {
9007: foreach my $item (@sections) {
9008: my ($sec,$gp) = split/:/,$item;
9009: my $class = $args->{'crscode'}.$sec;
9010: my $addcheck = &Apache::lonnet::auto_new_course($$crsunum,$$crsudom,$class,$cenv{'internal.courseowner'});
9011: $cenv{'internal.sectionnums'} .= $item.',';
9012: unless ($addcheck eq 'ok') {
9013: push @badclasses, $class;
9014: }
9015: }
9016: $cenv{'internal.sectionnums'} =~ s/,$//;
9017: }
9018: }
9019: # do not hide course coordinator from staff listing,
9020: # even if privileged
9021: $cenv{'nothideprivileged'}=$args->{'ccuname'}.':'.$args->{'ccdomain'};
9022: # add crosslistings
9023: if ($args->{'crsxlist'}) {
9024: $cenv{'internal.crosslistings'}='';
9025: if ($args->{'crsxlist'} =~ m/,/) {
9026: @xlists = split/,/,$args->{'crsxlist'};
9027: } else {
9028: $xlists[0] = $args->{'crsxlist'};
9029: }
9030: if (@xlists > 0) {
9031: foreach my $item (@xlists) {
9032: my ($xl,$gp) = split/:/,$item;
9033: my $addcheck = &Apache::lonnet::auto_new_course($$crsunum,$$crsudom,$xl,$cenv{'internal.courseowner'});
9034: $cenv{'internal.crosslistings'} .= $item.',';
9035: unless ($addcheck eq 'ok') {
9036: push @badclasses, $xl;
9037: }
9038: }
9039: $cenv{'internal.crosslistings'} =~ s/,$//;
9040: }
9041: }
9042: if ($args->{'autoadds'}) {
9043: $cenv{'internal.autoadds'}=$args->{'autoadds'};
9044: }
9045: if ($args->{'autodrops'}) {
9046: $cenv{'internal.autodrops'}=$args->{'autodrops'};
9047: }
9048: # check for notification of enrollment changes
9049: my @notified = ();
9050: if ($args->{'notify_owner'}) {
9051: if ($args->{'ccuname'} ne '') {
9052: push(@notified,$args->{'ccuname'}.':'.$args->{'ccdomain'});
9053: }
9054: }
9055: if ($args->{'notify_dc'}) {
9056: if ($uname ne '') {
1.630 raeburn 9057: push(@notified,$uname.':'.$udom);
1.444 albertel 9058: }
9059: }
9060: if (@notified > 0) {
9061: my $notifylist;
9062: if (@notified > 1) {
9063: $notifylist = join(',',@notified);
9064: } else {
9065: $notifylist = $notified[0];
9066: }
9067: $cenv{'internal.notifylist'} = $notifylist;
9068: }
9069: if (@badclasses > 0) {
9070: my %lt=&Apache::lonlocal::texthash(
9071: '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',
9072: 'dnhr' => 'does not have rights to access enrollment in these classes',
9073: 'adby' => 'as determined by the policies of your institution on access to official classlists'
9074: );
1.541 raeburn 9075: my $badclass_msg = $cenv{'internal.courseowner'}.') - '.$lt{'dnhr'}.
9076: ' ('.$lt{'adby'}.')';
9077: if ($context eq 'auto') {
9078: $outcome .= $badclass_msg.$linefeed;
1.566 albertel 9079: $outcome .= '<div class="LC_warning">'.$badclass_msg.$linefeed.'<ul>'."\n";
1.541 raeburn 9080: foreach my $item (@badclasses) {
9081: if ($context eq 'auto') {
9082: $outcome .= " - $item\n";
9083: } else {
9084: $outcome .= "<li>$item</li>\n";
9085: }
9086: }
9087: if ($context eq 'auto') {
9088: $outcome .= $linefeed;
9089: } else {
1.566 albertel 9090: $outcome .= "</ul><br /><br /></div>\n";
1.541 raeburn 9091: }
9092: }
1.444 albertel 9093: }
9094: if ($args->{'no_end_date'}) {
9095: $args->{'endaccess'} = 0;
9096: }
9097: $cenv{'internal.autostart'}=$args->{'enrollstart'};
9098: $cenv{'internal.autoend'}=$args->{'enrollend'};
9099: $cenv{'default_enrollment_start_date'}=$args->{'startaccess'};
9100: $cenv{'default_enrollment_end_date'}=$args->{'endaccess'};
9101: if ($args->{'showphotos'}) {
9102: $cenv{'internal.showphotos'}=$args->{'showphotos'};
9103: }
9104: $cenv{'internal.authtype'} = $args->{'authtype'};
9105: $cenv{'internal.autharg'} = $args->{'autharg'};
9106: if ( ($cenv{'internal.authtype'} =~ /^krb/) && ($cenv{'internal.autoadds'} == 1)) {
9107: if (! defined($cenv{'internal.autharg'}) || $cenv{'internal.autharg'} eq '') {
1.541 raeburn 9108: 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');
9109: if ($context eq 'auto') {
9110: $outcome .= $krb_msg;
9111: } else {
1.566 albertel 9112: $outcome .= '<span class="LC_error">'.$krb_msg.'</span>';
1.541 raeburn 9113: }
9114: $outcome .= $linefeed;
1.444 albertel 9115: }
9116: }
9117: if (($args->{'ccdomain'}) && ($args->{'ccuname'})) {
9118: if ($args->{'setpolicy'}) {
9119: $cenv{'policy.email'}=$args->{'ccuname'}.':'.$args->{'ccdomain'};
9120: }
9121: if ($args->{'setcontent'}) {
9122: $cenv{'question.email'}=$args->{'ccuname'}.':'.$args->{'ccdomain'};
9123: }
9124: }
9125: if ($args->{'reshome'}) {
9126: $cenv{'reshome'}=$args->{'reshome'}.'/';
9127: $cenv{'reshome'}=~s/\/+$/\//;
9128: }
9129: #
9130: # course has keyed access
9131: #
9132: if ($args->{'setkeys'}) {
9133: $cenv{'keyaccess'}='yes';
9134: }
9135: # if specified, key authority is not course, but user
9136: # only active if keyaccess is yes
9137: if ($args->{'keyauth'}) {
1.487 albertel 9138: my ($user,$domain) = split(':',$args->{'keyauth'});
9139: $user = &LONCAPA::clean_username($user);
9140: $domain = &LONCAPA::clean_username($domain);
1.488 foxr 9141: if ($user ne '' && $domain ne '') {
1.487 albertel 9142: $cenv{'keyauth'}=$user.':'.$domain;
1.444 albertel 9143: }
9144: }
9145:
9146: if ($args->{'disresdis'}) {
9147: $cenv{'pch.roles.denied'}='st';
9148: }
9149: if ($args->{'disablechat'}) {
9150: $cenv{'plc.roles.denied'}='st';
9151: }
9152:
9153: # Record we've not yet viewed the Course Initialization Helper for this
9154: # course
9155: $cenv{'course.helper.not.run'} = 1;
9156: #
9157: # Use new Randomseed
9158: #
9159: $cenv{'rndseed'}=&Apache::lonnet::latest_rnd_algorithm_id();;
9160: $cenv{'receiptalg'}=&Apache::lonnet::latest_receipt_algorithm_id();;
9161: #
9162: # The encryption code and receipt prefix for this course
9163: #
9164: $cenv{'internal.encseed'}=$Apache::lonnet::perlvar{'lonReceipt'}.$$.time.int(rand(9999));
9165: $cenv{'internal.encpref'}=100+int(9*rand(99));
9166: #
9167: # By default, use standard grading
9168: if (!defined($cenv{'grading'})) { $cenv{'grading'} = 'standard'; }
9169:
1.541 raeburn 9170: $outcome .= $linefeed.&mt('Setting environment').': '.
9171: &Apache::lonnet::put('environment',\%cenv,$$crsudom,$$crsunum).$linefeed;
1.444 albertel 9172: #
9173: # Open all assignments
9174: #
9175: if ($args->{'openall'}) {
9176: my $storeunder=$$crsudom.'_'.$$crsunum.'.0.opendate';
9177: my %storecontent = ($storeunder => time,
9178: $storeunder.'.type' => 'date_start');
9179:
9180: $outcome .= &mt('Opening all assignments').': '.&Apache::lonnet::cput
1.541 raeburn 9181: ('resourcedata',\%storecontent,$$crsudom,$$crsunum).$linefeed;
1.444 albertel 9182: }
9183: #
9184: # Set first page
9185: #
9186: unless (($args->{'nonstandard'}) || ($args->{'firstres'} eq 'blank')
9187: || ($cloneid)) {
1.445 albertel 9188: use LONCAPA::map;
1.444 albertel 9189: $outcome .= &mt('Setting first resource').': ';
1.445 albertel 9190:
9191: my $map = '/uploaded/'.$$crsudom.'/'.$$crsunum.'/default.sequence';
9192: my ($errtext,$fatal)=&LONCAPA::map::mapread($map);
9193:
1.444 albertel 9194: $outcome .= ($fatal?$errtext:'read ok').' - ';
9195: my $title; my $url;
9196: if ($args->{'firstres'} eq 'syl') {
9197: $title='Syllabus';
9198: $url='/public/'.$$crsudom.'/'.$$crsunum.'/syllabus';
9199: } else {
9200: $title='Navigate Contents';
9201: $url='/adm/navmaps';
9202: }
1.445 albertel 9203:
9204: $LONCAPA::map::resources[1]=$title.':'.$url.':false:start:res';
9205: (my $outtext,$errtext) = &LONCAPA::map::storemap($map,1);
9206:
9207: if ($errtext) { $fatal=2; }
1.541 raeburn 9208: $outcome .= ($fatal?$errtext:'write ok').$linefeed;
1.444 albertel 9209: }
1.566 albertel 9210:
9211: return (1,$outcome);
1.444 albertel 9212: }
9213:
9214: ############################################################
9215: ############################################################
9216:
1.378 raeburn 9217: sub course_type {
9218: my ($cid) = @_;
9219: if (!defined($cid)) {
9220: $cid = $env{'request.course.id'};
9221: }
1.404 albertel 9222: if (defined($env{'course.'.$cid.'.type'})) {
9223: return $env{'course.'.$cid.'.type'};
1.378 raeburn 9224: } else {
9225: return 'Course';
1.377 raeburn 9226: }
9227: }
1.156 albertel 9228:
1.406 raeburn 9229: sub group_term {
9230: my $crstype = &course_type();
9231: my %names = (
9232: 'Course' => 'group',
9233: 'Group' => 'team',
9234: );
9235: return $names{$crstype};
9236: }
9237:
1.156 albertel 9238: sub icon {
9239: my ($file)=@_;
1.505 albertel 9240: my $curfext = lc((split(/\./,$file))[-1]);
1.168 albertel 9241: my $iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/unknown.gif';
1.156 albertel 9242: my $embstyle = &Apache::loncommon::fileembstyle($curfext);
1.168 albertel 9243: if (!(!defined($embstyle) || $embstyle eq 'unk' || $embstyle eq 'hdn')) {
9244: if (-e $Apache::lonnet::perlvar{'lonDocRoot'}.'/'.
9245: $Apache::lonnet::perlvar{'lonIconsURL'}.'/'.
9246: $curfext.".gif") {
9247: $iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/'.
9248: $curfext.".gif";
9249: }
9250: }
1.249 albertel 9251: return &lonhttpdurl($iconname);
1.154 albertel 9252: }
1.84 albertel 9253:
1.575 albertel 9254: sub lonhttpd_port {
1.215 albertel 9255: my $lonhttpd_port=$Apache::lonnet::perlvar{'lonhttpdPort'};
9256: if (!defined($lonhttpd_port)) { $lonhttpd_port='8080'; }
1.574 albertel 9257: # IE doesn't like a secure page getting images from a non-secure
9258: # port (when logging we haven't parsed the browser type so default
9259: # back to secure
9260: if ((!exists($env{'browser.type'}) || $env{'browser.type'} eq 'explorer')
9261: && $ENV{'SERVER_PORT'} == 443) {
1.575 albertel 9262: return 443;
9263: }
9264: return $lonhttpd_port;
9265:
9266: }
9267:
9268: sub lonhttpdurl {
9269: my ($url)=@_;
9270:
9271: my $lonhttpd_port = &lonhttpd_port();
9272: if ($lonhttpd_port == 443) {
1.574 albertel 9273: return 'https://'.$ENV{'SERVER_NAME'}.$url;
9274: }
1.215 albertel 9275: return 'http://'.$ENV{'SERVER_NAME'}.':'.$lonhttpd_port.$url;
9276: }
9277:
1.213 albertel 9278: sub connection_aborted {
9279: my ($r)=@_;
9280: $r->print(" ");$r->rflush();
9281: my $c = $r->connection;
9282: return $c->aborted();
9283: }
9284:
1.221 foxr 9285: # Escapes strings that may have embedded 's that will be put into
1.222 foxr 9286: # strings as 'strings'.
9287: sub escape_single {
1.221 foxr 9288: my ($input) = @_;
1.223 albertel 9289: $input =~ s/\\/\\\\/g; # Escape the \'s..(must be first)>
1.221 foxr 9290: $input =~ s/\'/\\\'/g; # Esacpe the 's....
9291: return $input;
9292: }
1.223 albertel 9293:
1.222 foxr 9294: # Same as escape_single, but escape's "'s This
9295: # can be used for "strings"
9296: sub escape_double {
9297: my ($input) = @_;
9298: $input =~ s/\\/\\\\/g; # Escape the /'s..(must be first)>
9299: $input =~ s/\"/\\\"/g; # Esacpe the "s....
9300: return $input;
9301: }
1.223 albertel 9302:
1.222 foxr 9303: # Escapes the last element of a full URL.
9304: sub escape_url {
9305: my ($url) = @_;
1.238 raeburn 9306: my @urlslices = split(/\//, $url,-1);
1.369 www 9307: my $lastitem = &escape(pop(@urlslices));
1.223 albertel 9308: return join('/',@urlslices).'/'.$lastitem;
1.222 foxr 9309: }
1.462 albertel 9310:
9311: # -------------------------------------------------------- Initliaze user login
9312: sub init_user_environment {
1.463 albertel 9313: my ($r, $username, $domain, $authhost, $form, $args) = @_;
1.462 albertel 9314: my $lonids=$Apache::lonnet::perlvar{'lonIDsDir'};
9315:
9316: my $public=($username eq 'public' && $domain eq 'public');
9317:
9318: # See if old ID present, if so, remove
9319:
9320: my ($filename,$cookie,$userroles);
9321: my $now=time;
9322:
9323: if ($public) {
9324: my $max_public=100;
9325: my $oldest;
9326: my $oldest_time=0;
9327: for(my $next=1;$next<=$max_public;$next++) {
9328: if (-e $lonids."/publicuser_$next.id") {
9329: my $mtime=(stat($lonids."/publicuser_$next.id"))[9];
9330: if ($mtime<$oldest_time || !$oldest_time) {
9331: $oldest_time=$mtime;
9332: $oldest=$next;
9333: }
9334: } else {
9335: $cookie="publicuser_$next";
9336: last;
9337: }
9338: }
9339: if (!$cookie) { $cookie="publicuser_$oldest"; }
9340: } else {
1.463 albertel 9341: # if this isn't a robot, kill any existing non-robot sessions
9342: if (!$args->{'robot'}) {
9343: opendir(DIR,$lonids);
9344: while ($filename=readdir(DIR)) {
9345: if ($filename=~/^$username\_\d+\_$domain\_$authhost\.id$/) {
9346: unlink($lonids.'/'.$filename);
9347: }
1.462 albertel 9348: }
1.463 albertel 9349: closedir(DIR);
1.462 albertel 9350: }
9351: # Give them a new cookie
1.463 albertel 9352: my $id = ($args->{'robot'} ? 'robot'.$args->{'robot'}
1.684 www 9353: : $now.$$.int(rand(10000)));
1.463 albertel 9354: $cookie="$username\_$id\_$domain\_$authhost";
1.462 albertel 9355:
9356: # Initialize roles
9357:
9358: $userroles=&Apache::lonnet::rolesinit($domain,$username,$authhost);
9359: }
9360: # ------------------------------------ Check browser type and MathML capability
9361:
9362: my ($httpbrowser,$clientbrowser,$clientversion,$clientmathml,
9363: $clientunicode,$clientos) = &decode_user_agent($r);
9364:
9365: # -------------------------------------- Any accessibility options to remember?
9366: if (($form->{'interface'}) && ($form->{'remember'} eq 'true')) {
9367: foreach my $option ('imagesuppress','appletsuppress',
9368: 'embedsuppress','fontenhance','blackwhite') {
9369: if ($form->{$option} eq 'true') {
9370: &Apache::lonnet::put('environment',{$option => 'on'},
9371: $domain,$username);
9372: } else {
9373: &Apache::lonnet::del('environment',[$option],
9374: $domain,$username);
9375: }
9376: }
9377: }
9378: # ------------------------------------------------------------- Get environment
9379:
9380: my %userenv = &Apache::lonnet::dump('environment',$domain,$username);
9381: my ($tmp) = keys(%userenv);
9382: if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
9383: # default remote control to off
9384: if ($userenv{'remote'} ne 'on') { $userenv{'remote'} = 'off'; }
9385: } else {
9386: undef(%userenv);
9387: }
9388: if (($userenv{'interface'}) && (!$form->{'interface'})) {
9389: $form->{'interface'}=$userenv{'interface'};
9390: }
9391: $env{'environment.remote'}=$userenv{'remote'};
9392: if ($userenv{'texengine'} eq 'ttm') { $clientmathml=1; }
9393:
9394: # --------------- Do not trust query string to be put directly into environment
9395: foreach my $option ('imagesuppress','appletsuppress',
9396: 'embedsuppress','fontenhance','blackwhite',
9397: 'interface','localpath','localres') {
9398: $form->{$option}=~s/[\n\r\=]//gs;
9399: }
9400: # --------------------------------------------------------- Write first profile
9401:
9402: {
9403: my %initial_env =
9404: ("user.name" => $username,
9405: "user.domain" => $domain,
9406: "user.home" => $authhost,
9407: "browser.type" => $clientbrowser,
9408: "browser.version" => $clientversion,
9409: "browser.mathml" => $clientmathml,
9410: "browser.unicode" => $clientunicode,
9411: "browser.os" => $clientos,
9412: "server.domain" => $Apache::lonnet::perlvar{'lonDefDomain'},
9413: "request.course.fn" => '',
9414: "request.course.uri" => '',
9415: "request.course.sec" => '',
9416: "request.role" => 'cm',
9417: "request.role.adv" => $env{'user.adv'},
9418: "request.host" => $ENV{'REMOTE_ADDR'},);
9419:
9420: if ($form->{'localpath'}) {
9421: $initial_env{"browser.localpath"} = $form->{'localpath'};
9422: $initial_env{"browser.localres"} = $form->{'localres'};
9423: }
9424:
9425: if ($public) {
9426: $initial_env{"environment.remote"} = "off";
9427: }
9428: if ($form->{'interface'}) {
9429: $form->{'interface'}=~s/\W//gs;
9430: $initial_env{"browser.interface"} = $form->{'interface'};
9431: $env{'browser.interface'}=$form->{'interface'};
9432: foreach my $option ('imagesuppress','appletsuppress',
9433: 'embedsuppress','fontenhance','blackwhite') {
9434: if (($form->{$option} eq 'true') ||
9435: ($userenv{$option} eq 'on')) {
9436: $initial_env{"browser.$option"} = "on";
9437: }
9438: }
9439: }
9440:
9441: $env{'user.environment'} = "$lonids/$cookie.id";
9442:
9443: if (tie(my %disk_env,'GDBM_File',"$lonids/$cookie.id",
9444: &GDBM_WRCREAT(),0640)) {
9445: &_add_to_env(\%disk_env,\%initial_env);
9446: &_add_to_env(\%disk_env,\%userenv,'environment.');
9447: &_add_to_env(\%disk_env,$userroles);
1.463 albertel 9448: if (ref($args->{'extra_env'})) {
9449: &_add_to_env(\%disk_env,$args->{'extra_env'});
9450: }
1.462 albertel 9451: untie(%disk_env);
9452: } else {
9453: &Apache::lonnet::logthis("<font color=\"blue\">WARNING: ".
9454: 'Could not create environment storage in lonauth: '.$!.'</font>');
9455: return 'error: '.$!;
9456: }
9457: }
9458: $env{'request.role'}='cm';
9459: $env{'request.role.adv'}=$env{'user.adv'};
9460: $env{'browser.type'}=$clientbrowser;
9461:
9462: return $cookie;
9463:
9464: }
9465:
9466: sub _add_to_env {
9467: my ($idf,$env_data,$prefix) = @_;
1.676 raeburn 9468: if (ref($env_data) eq 'HASH') {
9469: while (my ($key,$value) = each(%$env_data)) {
9470: $idf->{$prefix.$key} = $value;
9471: $env{$prefix.$key} = $value;
9472: }
1.462 albertel 9473: }
9474: }
9475:
1.685 tempelho 9476: # --- Get the symbolic name of a problem and the url
9477: sub get_symb {
9478: my ($request,$silent) = @_;
9479: (my $url=$env{'form.url'}) =~ s-^http://($ENV{'SERVER_NAME'}|$ENV{'HTTP_HOST'})--;
9480: my $symb=($env{'form.symb'} ne '' ? $env{'form.symb'} : (&Apache::lonnet::symbread($url)));
9481: if ($symb eq '') {
9482: if (!$silent) {
9483: $request->print("Unable to handle ambiguous references:$url:.");
9484: return ();
9485: }
9486: }
9487: &Apache::lonenc::check_decrypt(\$symb);
9488: return ($symb);
9489: }
9490:
9491: # --------------------------------------------------------------Get annotation
9492:
9493: sub get_annotation {
9494: my ($symb,$enc) = @_;
9495:
9496: my $key = $symb;
9497: if (!$enc) {
9498: $key =
9499: &Apache::lonnet::clutter((&Apache::lonnet::decode_symb($symb))[2]);
9500: }
9501: my %annotation=&Apache::lonnet::get('nohist_annotations',[$key]);
9502: return $annotation{$key};
9503: }
9504:
9505: sub clean_symb {
9506: my ($symb) = @_;
9507:
9508: &Apache::lonenc::check_decrypt(\$symb);
9509: my $enc = $env{'request.enc'};
9510: delete($env{'request.enc'});
9511:
9512: return ($symb,$enc);
9513: }
1.462 albertel 9514:
1.41 ng 9515: =pod
9516:
9517: =back
9518:
1.112 bowersj2 9519: =cut
1.41 ng 9520:
1.112 bowersj2 9521: 1;
9522: __END__;
1.41 ng 9523:
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