Annotation of loncom/interface/loncommon.pm, revision 1.653
1.10 albertel 1: # The LearningOnline Network with CAPA
1.1 albertel 2: # a pile of common routines
1.10 albertel 3: #
1.653 ! raeburn 4: # $Id: loncommon.pm,v 1.652 2008/04/30 23:36:56 raeburn Exp $
1.10 albertel 5: #
6: # Copyright Michigan State University Board of Trustees
7: #
8: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
9: #
10: # LON-CAPA is free software; you can redistribute it and/or modify
11: # it under the terms of the GNU General Public License as published by
12: # the Free Software Foundation; either version 2 of the License, or
13: # (at your option) any later version.
14: #
15: # LON-CAPA is distributed in the hope that it will be useful,
16: # but WITHOUT ANY WARRANTY; without even the implied warranty of
17: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18: # GNU General Public License for more details.
19: #
20: # You should have received a copy of the GNU General Public License
21: # along with LON-CAPA; if not, write to the Free Software
22: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
23: #
24: # /home/httpd/html/adm/gpl.txt
25: #
26: # http://www.lon-capa.org/
27: #
1.1 albertel 28:
29: # Makes a table out of the previous attempts
1.2 albertel 30: # Inputs result_from_symbread, user, domain, course_id
1.16 harris41 31: # Reads in non-network-related .tab files
1.1 albertel 32:
1.35 matthew 33: # POD header:
34:
1.45 matthew 35: =pod
36:
1.35 matthew 37: =head1 NAME
38:
39: Apache::loncommon - pile of common routines
40:
41: =head1 SYNOPSIS
42:
1.112 bowersj2 43: Common routines for manipulating connections, student answers,
44: domains, common Javascript fragments, etc.
1.35 matthew 45:
1.112 bowersj2 46: =head1 OVERVIEW
1.35 matthew 47:
1.112 bowersj2 48: A collection of commonly used subroutines that don't have a natural
49: home anywhere else. This collection helps remove
1.35 matthew 50: redundancy from other modules and increase efficiency of memory usage.
51:
52: =cut
53:
54: # End of POD header
1.1 albertel 55: package Apache::loncommon;
56:
57: use strict;
1.258 albertel 58: use Apache::lonnet;
1.46 matthew 59: use GDBM_File;
1.51 www 60: use POSIX qw(strftime mktime);
1.82 www 61: use Apache::lonmenu();
1.498 albertel 62: use Apache::lonenc();
1.117 www 63: use Apache::lonlocal;
1.139 matthew 64: use HTML::Entities;
1.334 albertel 65: use Apache::lonhtmlcommon();
66: use Apache::loncoursedata();
1.344 albertel 67: use Apache::lontexconvert();
1.444 albertel 68: use Apache::lonclonecourse();
1.479 albertel 69: use LONCAPA qw(:DEFAULT :match);
1.117 www 70:
1.517 raeburn 71: # ---------------------------------------------- Designs
72: use vars qw(%defaultdesign);
73:
1.22 www 74: my $readit;
75:
1.517 raeburn 76:
1.157 matthew 77: ##
78: ## Global Variables
79: ##
1.46 matthew 80:
1.643 foxr 81:
82: # ----------------------------------------------- SSI with retries:
83: #
84:
85: =pod
86:
1.648 raeburn 87: =head1 Server Side include with retries:
1.643 foxr 88:
89: =over 4
90:
1.648 raeburn 91: =item * &ssi_with_retries(resource,retries form)
1.643 foxr 92:
93: Performs an ssi with some number of retries. Retries continue either
94: until the result is ok or until the retry count supplied by the
95: caller is exhausted.
96:
97: Inputs:
1.648 raeburn 98:
99: =over 4
100:
1.643 foxr 101: resource - Identifies the resource to insert.
1.648 raeburn 102:
1.643 foxr 103: retries - Count of the number of retries allowed.
1.648 raeburn 104:
1.643 foxr 105: form - Hash that identifies the rendering options.
106:
1.648 raeburn 107: =back
108:
109: Returns:
110:
111: =over 4
112:
1.643 foxr 113: content - The content of the response. If retries were exhausted this is empty.
1.648 raeburn 114:
1.643 foxr 115: response - The response from the last attempt (which may or may not have been successful.
116:
1.648 raeburn 117: =back
118:
119: =back
120:
1.643 foxr 121: =cut
122:
123: sub ssi_with_retries {
124: my ($resource, $retries, %form) = @_;
125:
126:
127: my $ok = 0; # True if we got a good response.
128: my $content;
129: my $response;
130:
131: # Try to get the ssi done. within the retries count:
132:
133: do {
134: ($content, $response) = &Apache::lonnet::ssi($resource, %form);
135: $ok = $response->is_success;
1.650 www 136: if (!$ok) {
137: &Apache::lonnet::logthis("Failed ssi_with_retries on $resource: ".$response->is_success.', '.$response->code.', '.$response->message);
138: }
1.643 foxr 139: $retries--;
140: } while (!$ok && ($retries > 0));
141:
142: if (!$ok) {
143: $content = ''; # On error return an empty content.
144: }
145: return ($content, $response);
146:
147: }
148:
149:
150:
1.20 www 151: # ----------------------------------------------- Filetypes/Languages/Copyright
1.12 harris41 152: my %language;
1.124 www 153: my %supported_language;
1.12 harris41 154: my %cprtag;
1.192 taceyjo1 155: my %scprtag;
1.351 www 156: my %fe; my %fd; my %fm;
1.41 ng 157: my %category_extensions;
1.12 harris41 158:
1.46 matthew 159: # ---------------------------------------------- Thesaurus variables
1.144 matthew 160: #
161: # %Keywords:
162: # A hash used by &keyword to determine if a word is considered a keyword.
163: # $thesaurus_db_file
164: # Scalar containing the full path to the thesaurus database.
1.46 matthew 165:
166: my %Keywords;
167: my $thesaurus_db_file;
168:
1.144 matthew 169: #
170: # Initialize values from language.tab, copyright.tab, filetypes.tab,
171: # thesaurus.tab, and filecategories.tab.
172: #
1.18 www 173: BEGIN {
1.46 matthew 174: # Variable initialization
175: $thesaurus_db_file = $Apache::lonnet::perlvar{'lonTabDir'}."/thesaurus.db";
176: #
1.22 www 177: unless ($readit) {
1.12 harris41 178: # ------------------------------------------------------------------- languages
179: {
1.158 raeburn 180: my $langtabfile = $Apache::lonnet::perlvar{'lonTabDir'}.
181: '/language.tab';
182: if ( open(my $fh,"<$langtabfile") ) {
1.356 albertel 183: while (my $line = <$fh>) {
184: next if ($line=~/^\#/);
185: chomp($line);
186: my ($key,$two,$country,$three,$enc,$val,$sup)=(split(/\t/,$line));
1.158 raeburn 187: $language{$key}=$val.' - '.$enc;
188: if ($sup) {
189: $supported_language{$key}=$sup;
190: }
191: }
192: close($fh);
193: }
1.12 harris41 194: }
195: # ------------------------------------------------------------------ copyrights
196: {
1.158 raeburn 197: my $copyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.
198: '/copyright.tab';
199: if ( open (my $fh,"<$copyrightfile") ) {
1.356 albertel 200: while (my $line = <$fh>) {
201: next if ($line=~/^\#/);
202: chomp($line);
203: my ($key,$val)=(split(/\s+/,$line,2));
1.158 raeburn 204: $cprtag{$key}=$val;
205: }
206: close($fh);
207: }
1.12 harris41 208: }
1.351 www 209: # ----------------------------------------------------------- source copyrights
1.192 taceyjo1 210: {
211: my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}.
212: '/source_copyright.tab';
213: if ( open (my $fh,"<$sourcecopyrightfile") ) {
1.356 albertel 214: while (my $line = <$fh>) {
215: next if ($line =~ /^\#/);
216: chomp($line);
217: my ($key,$val)=(split(/\s+/,$line,2));
1.192 taceyjo1 218: $scprtag{$key}=$val;
219: }
220: close($fh);
221: }
222: }
1.63 www 223:
1.517 raeburn 224: # -------------------------------------------------------------- default domain designs
1.63 www 225: my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors';
1.517 raeburn 226: my $designfile = $designdir.'/default.tab';
227: if ( open (my $fh,"<$designfile") ) {
228: while (my $line = <$fh>) {
229: next if ($line =~ /^\#/);
230: chomp($line);
231: my ($key,$val)=(split(/\=/,$line));
232: if ($val) { $defaultdesign{$key}=$val; }
233: }
234: close($fh);
1.63 www 235: }
236:
1.15 harris41 237: # ------------------------------------------------------------- file categories
238: {
1.158 raeburn 239: my $categoryfile = $Apache::lonnet::perlvar{'lonTabDir'}.
240: '/filecategories.tab';
241: if ( open (my $fh,"<$categoryfile") ) {
1.356 albertel 242: while (my $line = <$fh>) {
243: next if ($line =~ /^\#/);
244: chomp($line);
245: my ($extension,$category)=(split(/\s+/,$line,2));
1.158 raeburn 246: push @{$category_extensions{lc($category)}},$extension;
247: }
248: close($fh);
249: }
250:
1.15 harris41 251: }
1.12 harris41 252: # ------------------------------------------------------------------ file types
253: {
1.158 raeburn 254: my $typesfile = $Apache::lonnet::perlvar{'lonTabDir'}.
255: '/filetypes.tab';
256: if ( open (my $fh,"<$typesfile") ) {
1.356 albertel 257: while (my $line = <$fh>) {
258: next if ($line =~ /^\#/);
259: chomp($line);
260: my ($ending,$emb,$mime,$descr)=split(/\s+/,$line,4);
1.158 raeburn 261: if ($descr ne '') {
262: $fe{$ending}=lc($emb);
263: $fd{$ending}=$descr;
1.351 www 264: if ($mime ne 'unk') { $fm{$ending}=$mime; }
1.158 raeburn 265: }
266: }
267: close($fh);
268: }
1.12 harris41 269: }
1.22 www 270: &Apache::lonnet::logthis(
1.46 matthew 271: "<font color=yellow>INFO: Read file types</font>");
1.22 www 272: $readit=1;
1.46 matthew 273: } # end of unless($readit)
1.32 matthew 274:
275: }
1.112 bowersj2 276:
1.42 matthew 277: ###############################################################
278: ## HTML and Javascript Helper Functions ##
279: ###############################################################
280:
281: =pod
282:
1.112 bowersj2 283: =head1 HTML and Javascript Functions
1.42 matthew 284:
1.112 bowersj2 285: =over 4
286:
1.648 raeburn 287: =item * &browser_and_searcher_javascript()
1.112 bowersj2 288:
289: X<browsing, javascript>X<searching, javascript>Returns a string
290: containing javascript with two functions, C<openbrowser> and
291: C<opensearcher>. Returned string does not contain E<lt>scriptE<gt>
292: tags.
1.42 matthew 293:
1.648 raeburn 294: =item * &openbrowser(formname,elementname,only,omit) [javascript]
1.42 matthew 295:
296: inputs: formname, elementname, only, omit
297:
298: formname and elementname indicate the name of the html form and name of
299: the element that the results of the browsing selection are to be placed in.
300:
301: Specifying 'only' will restrict the browser to displaying only files
1.185 www 302: with the given extension. Can be a comma separated list.
1.42 matthew 303:
304: Specifying 'omit' will restrict the browser to NOT displaying files
1.185 www 305: with the given extension. Can be a comma separated list.
1.42 matthew 306:
1.648 raeburn 307: =item * &opensearcher(formname,elementname) [javascript]
1.42 matthew 308:
309: Inputs: formname, elementname
310:
311: formname and elementname specify the name of the html form and the name
312: of the element the selection from the search results will be placed in.
1.542 raeburn 313:
1.42 matthew 314: =cut
315:
316: sub browser_and_searcher_javascript {
1.199 albertel 317: my ($mode)=@_;
318: if (!defined($mode)) { $mode='edit'; }
1.453 albertel 319: my $resurl=&escape_single(&lastresurl());
1.42 matthew 320: return <<END;
1.219 albertel 321: // <!-- BEGIN LON-CAPA Internal
1.50 matthew 322: var editbrowser = null;
1.135 albertel 323: function openbrowser(formname,elementname,only,omit,titleelement) {
1.170 www 324: var url = '$resurl/?';
1.42 matthew 325: if (editbrowser == null) {
326: url += 'launch=1&';
327: }
328: url += 'catalogmode=interactive&';
1.199 albertel 329: url += 'mode=$mode&';
1.611 albertel 330: url += 'inhibitmenu=yes&';
1.42 matthew 331: url += 'form=' + formname + '&';
332: if (only != null) {
333: url += 'only=' + only + '&';
1.217 albertel 334: } else {
335: url += 'only=&';
336: }
1.42 matthew 337: if (omit != null) {
338: url += 'omit=' + omit + '&';
1.217 albertel 339: } else {
340: url += 'omit=&';
341: }
1.135 albertel 342: if (titleelement != null) {
343: url += 'titleelement=' + titleelement + '&';
1.217 albertel 344: } else {
345: url += 'titleelement=&';
346: }
1.42 matthew 347: url += 'element=' + elementname + '';
348: var title = 'Browser';
1.435 albertel 349: var options = 'scrollbars=1,resizable=1,menubar=0,toolbar=1,location=1';
1.42 matthew 350: options += ',width=700,height=600';
351: editbrowser = open(url,title,options,'1');
352: editbrowser.focus();
353: }
354: var editsearcher;
1.135 albertel 355: function opensearcher(formname,elementname,titleelement) {
1.42 matthew 356: var url = '/adm/searchcat?';
357: if (editsearcher == null) {
358: url += 'launch=1&';
359: }
360: url += 'catalogmode=interactive&';
1.199 albertel 361: url += 'mode=$mode&';
1.42 matthew 362: url += 'form=' + formname + '&';
1.135 albertel 363: if (titleelement != null) {
364: url += 'titleelement=' + titleelement + '&';
1.217 albertel 365: } else {
366: url += 'titleelement=&';
367: }
1.42 matthew 368: url += 'element=' + elementname + '';
369: var title = 'Search';
1.435 albertel 370: var options = 'scrollbars=1,resizable=1,menubar=0,toolbar=1,location=1';
1.42 matthew 371: options += ',width=700,height=600';
372: editsearcher = open(url,title,options,'1');
373: editsearcher.focus();
374: }
1.219 albertel 375: // END LON-CAPA Internal -->
1.42 matthew 376: END
1.170 www 377: }
378:
379: sub lastresurl {
1.258 albertel 380: if ($env{'environment.lastresurl'}) {
381: return $env{'environment.lastresurl'}
1.170 www 382: } else {
383: return '/res';
384: }
385: }
386:
387: sub storeresurl {
388: my $resurl=&Apache::lonnet::clutter(shift);
389: unless ($resurl=~/^\/res/) { return 0; }
390: $resurl=~s/\/$//;
391: &Apache::lonnet::put('environment',{'lastresurl' => $resurl});
1.646 raeburn 392: &Apache::lonnet::appenv({'environment.lastresurl' => $resurl});
1.170 www 393: return 1;
1.42 matthew 394: }
395:
1.74 www 396: sub studentbrowser_javascript {
1.111 www 397: unless (
1.258 albertel 398: (($env{'request.course.id'}) &&
1.302 albertel 399: (&Apache::lonnet::allowed('srm',$env{'request.course.id'})
400: || &Apache::lonnet::allowed('srm',$env{'request.course.id'}.
401: '/'.$env{'request.course.sec'})
402: ))
1.258 albertel 403: || ($env{'request.role'}=~/^(au|dc|su)/)
1.111 www 404: ) { return ''; }
1.74 www 405: return (<<'ENDSTDBRW');
406: <script type="text/javascript" language="Javascript" >
407: var stdeditbrowser;
1.558 albertel 408: function openstdbrowser(formname,uname,udom,roleflag,ignorefilter) {
1.74 www 409: var url = '/adm/pickstudent?';
410: var filter;
1.558 albertel 411: if (!ignorefilter) {
412: eval('filter=document.'+formname+'.'+uname+'.value;');
413: }
1.74 www 414: if (filter != null) {
415: if (filter != '') {
416: url += 'filter='+filter+'&';
417: }
418: }
419: url += 'form=' + formname + '&unameelement='+uname+
420: '&udomelement='+udom;
1.111 www 421: if (roleflag) { url+="&roles=1"; }
1.102 www 422: var title = 'Student_Browser';
1.74 www 423: var options = 'scrollbars=1,resizable=1,menubar=0';
424: options += ',width=700,height=600';
425: stdeditbrowser = open(url,title,options,'1');
426: stdeditbrowser.focus();
427: }
428: </script>
429: ENDSTDBRW
430: }
1.42 matthew 431:
1.74 www 432: sub selectstudent_link {
1.111 www 433: my ($form,$unameele,$udomele)=@_;
1.258 albertel 434: if ($env{'request.course.id'}) {
1.302 albertel 435: if (!&Apache::lonnet::allowed('srm',$env{'request.course.id'})
436: && !&Apache::lonnet::allowed('srm',$env{'request.course.id'}.
437: '/'.$env{'request.course.sec'})) {
1.111 www 438: return '';
439: }
440: return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele.
1.607 albertel 441: '","'.$udomele.'");'."'>".&mt('Select User')."</a>";
1.74 www 442: }
1.258 albertel 443: if ($env{'request.role'}=~/^(au|dc|su)/) {
1.111 www 444: return "<a href='".'javascript:openstdbrowser("'.$form.'","'.$unameele.
1.119 www 445: '","'.$udomele.'",1);'."'>".&mt('Select User')."</a>";
1.111 www 446: }
447: return '';
1.91 www 448: }
449:
1.653 ! raeburn 450: sub authorbrowser_javascript {
! 451: return <<"ENDAUTHORBRW";
! 452: <script type="text/javascript">
! 453: var stdeditbrowser;
! 454:
! 455: function openauthorbrowser(formname,udom) {
! 456: var url = '/adm/pickauthor?';
! 457: url += 'form='+formname+'&roledom='+udom;
! 458: var title = 'Author_Browser';
! 459: var options = 'scrollbars=1,resizable=1,menubar=0';
! 460: options += ',width=700,height=600';
! 461: stdeditbrowser = open(url,title,options,'1');
! 462: stdeditbrowser.focus();
! 463: }
! 464:
! 465: </script>
! 466: ENDAUTHORBRW
! 467: }
! 468:
1.91 www 469: sub coursebrowser_javascript {
1.468 raeburn 470: my ($domainfilter,$sec_element,$formname)=@_;
1.377 raeburn 471: my $crs_or_grp_alert = &mt('Please select the type of LON-CAPA entity - Course or Group - for which you wish to add/modify a user role');
1.468 raeburn 472: my $output = '
1.538 albertel 473: <script type="text/javascript">
1.468 raeburn 474: var stdeditbrowser;'."\n";
475: $output .= <<"ENDSTDBRW";
1.377 raeburn 476: function opencrsbrowser(formname,uname,udom,desc,extra_element,multflag,crstype) {
1.91 www 477: var url = '/adm/pickcourse?';
1.468 raeburn 478: var domainfilter = '';
479: var formid = getFormIdByName(formname);
480: if (formid > -1) {
481: var domid = getIndexByName(formid,udom);
482: if (domid > -1) {
483: if (document.forms[formid].elements[domid].type == 'select-one') {
484: domainfilter=document.forms[formid].elements[domid].options[document.forms[formid].elements[domid].selectedIndex].value;
485: }
486: if (document.forms[formid].elements[domid].type == 'hidden') {
487: domainfilter=document.forms[formid].elements[domid].value;
488: }
489: }
1.91 www 490: }
1.128 albertel 491: if (domainfilter != null) {
492: if (domainfilter != '') {
493: url += 'domainfilter='+domainfilter+'&';
494: }
495: }
1.91 www 496: url += 'form=' + formname + '&cnumelement='+uname+
1.187 albertel 497: '&cdomelement='+udom+
498: '&cnameelement='+desc;
1.468 raeburn 499: if (extra_element !=null && extra_element != '') {
1.594 raeburn 500: if (formname == 'rolechoice' || formname == 'studentform') {
1.468 raeburn 501: url += '&roleelement='+extra_element;
502: if (domainfilter == null || domainfilter == '') {
503: url += '&domainfilter='+extra_element;
504: }
1.234 raeburn 505: }
1.468 raeburn 506: else {
507: if (formname == 'portform') {
508: url += '&setroles='+extra_element;
509: }
510: }
1.230 raeburn 511: }
1.293 raeburn 512: if (multflag !=null && multflag != '') {
513: url += '&multiple='+multflag;
514: }
1.377 raeburn 515: if (crstype == 'Course/Group') {
516: if (formname == 'cu') {
517: crstype = document.cu.crstype.options[document.cu.crstype.selectedIndex].value;
518: if (crstype == "") {
519: alert("$crs_or_grp_alert");
520: return;
521: }
522: }
523: }
524: if (crstype !=null && crstype != '') {
525: url += '&type='+crstype;
526: }
1.102 www 527: var title = 'Course_Browser';
1.91 www 528: var options = 'scrollbars=1,resizable=1,menubar=0';
529: options += ',width=700,height=600';
530: stdeditbrowser = open(url,title,options,'1');
531: stdeditbrowser.focus();
532: }
1.468 raeburn 533:
534: function getFormIdByName(formname) {
535: for (var i=0;i<document.forms.length;i++) {
536: if (document.forms[i].name == formname) {
537: return i;
538: }
539: }
540: return -1;
541: }
542:
543: function getIndexByName(formid,item) {
544: for (var i=0;i<document.forms[formid].elements.length;i++) {
545: if (document.forms[formid].elements[i].name == item) {
546: return i;
547: }
548: }
549: return -1;
550: }
1.91 www 551: ENDSTDBRW
1.468 raeburn 552: if ($sec_element ne '') {
553: $output .= &setsec_javascript($sec_element,$formname);
554: }
555: $output .= '
556: </script>';
557: return $output;
558: }
559:
560: sub setsec_javascript {
561: my ($sec_element,$formname) = @_;
562: my $setsections = qq|
563: function setSect(sectionlist) {
1.629 raeburn 564: var sectionsArray = new Array();
565: if ((sectionlist != '') && (typeof sectionlist != "undefined")) {
566: sectionsArray = sectionlist.split(",");
567: }
1.468 raeburn 568: var numSections = sectionsArray.length;
569: document.$formname.$sec_element.length = 0;
570: if (numSections == 0) {
571: document.$formname.$sec_element.multiple=false;
572: document.$formname.$sec_element.size=1;
573: document.$formname.$sec_element.options[0] = new Option('No existing sections','',false,false)
574: } else {
575: if (numSections == 1) {
576: document.$formname.$sec_element.multiple=false;
577: document.$formname.$sec_element.size=1;
578: document.$formname.$sec_element.options[0] = new Option('Select','',true,true);
579: document.$formname.$sec_element.options[1] = new Option('No section','',false,false)
580: document.$formname.$sec_element.options[2] = new Option(sectionsArray[0],sectionsArray[0],false,false);
581: } else {
582: for (var i=0; i<numSections; i++) {
583: document.$formname.$sec_element.options[i] = new Option(sectionsArray[i],sectionsArray[i],false,false)
584: }
585: document.$formname.$sec_element.multiple=true
586: if (numSections < 3) {
587: document.$formname.$sec_element.size=numSections;
588: } else {
589: document.$formname.$sec_element.size=3;
590: }
591: document.$formname.$sec_element.options[0].selected = false
592: }
593: }
1.91 www 594: }
1.468 raeburn 595: |;
596: return $setsections;
597: }
598:
1.91 www 599:
600: sub selectcourse_link {
1.377 raeburn 601: my ($form,$unameele,$udomele,$desc,$extra_element,$multflag,$selecttype)=@_;
1.492 albertel 602: return "<a href='".'javascript:opencrsbrowser("'.$form.'","'.$unameele.
603: '","'.$udomele.'","'.$desc.'","'.$extra_element.'","'.$multflag.'","'.$selecttype.'");'."'>".&mt('Select Course')."</a>";
1.74 www 604: }
1.42 matthew 605:
1.653 ! raeburn 606: sub selectauthor_link {
! 607: my ($form,$udom)=@_;
! 608: return '<a href="javascript:openauthorbrowser('."'$form','$udom'".');">'.
! 609: &mt('Select Author').'</a>';
! 610: }
! 611:
1.273 raeburn 612: sub check_uncheck_jscript {
613: my $jscript = <<"ENDSCRT";
614: function checkAll(field) {
615: if (field.length > 0) {
616: for (i = 0; i < field.length; i++) {
617: field[i].checked = true ;
618: }
619: } else {
620: field.checked = true
621: }
622: }
623:
624: function uncheckAll(field) {
625: if (field.length > 0) {
626: for (i = 0; i < field.length; i++) {
627: field[i].checked = false ;
1.543 albertel 628: }
629: } else {
1.273 raeburn 630: field.checked = false ;
631: }
632: }
633: ENDSCRT
634: return $jscript;
635: }
636:
637:
1.42 matthew 638: =pod
1.36 matthew 639:
1.648 raeburn 640: =item * &linked_select_forms(...)
1.36 matthew 641:
642: linked_select_forms returns a string containing a <script></script> block
643: and html for two <select> menus. The select menus will be linked in that
644: changing the value of the first menu will result in new values being placed
645: in the second menu. The values in the select menu will appear in alphabetical
1.609 raeburn 646: order unless a defined order is provided.
1.36 matthew 647:
648: linked_select_forms takes the following ordered inputs:
649:
650: =over 4
651:
1.112 bowersj2 652: =item * $formname, the name of the <form> tag
1.36 matthew 653:
1.112 bowersj2 654: =item * $middletext, the text which appears between the <select> tags
1.36 matthew 655:
1.112 bowersj2 656: =item * $firstdefault, the default value for the first menu
1.36 matthew 657:
1.112 bowersj2 658: =item * $firstselectname, the name of the first <select> tag
1.36 matthew 659:
1.112 bowersj2 660: =item * $secondselectname, the name of the second <select> tag
1.36 matthew 661:
1.112 bowersj2 662: =item * $hashref, a reference to a hash containing the data for the menus.
1.36 matthew 663:
1.609 raeburn 664: =item * $menuorder, the order of values in the first menu
665:
1.41 ng 666: =back
667:
1.36 matthew 668: Below is an example of such a hash. Only the 'text', 'default', and
669: 'select2' keys must appear as stated. keys(%menu) are the possible
670: values for the first select menu. The text that coincides with the
1.41 ng 671: first menu value is given in $menu{$choice1}->{'text'}. The values
1.36 matthew 672: and text for the second menu are given in the hash pointed to by
673: $menu{$choice1}->{'select2'}.
674:
1.112 bowersj2 675: my %menu = ( A1 => { text =>"Choice A1" ,
676: default => "B3",
677: select2 => {
678: B1 => "Choice B1",
679: B2 => "Choice B2",
680: B3 => "Choice B3",
681: B4 => "Choice B4"
1.609 raeburn 682: },
683: order => ['B4','B3','B1','B2'],
1.112 bowersj2 684: },
685: A2 => { text =>"Choice A2" ,
686: default => "C2",
687: select2 => {
688: C1 => "Choice C1",
689: C2 => "Choice C2",
690: C3 => "Choice C3"
1.609 raeburn 691: },
692: order => ['C2','C1','C3'],
1.112 bowersj2 693: },
694: A3 => { text =>"Choice A3" ,
695: default => "D6",
696: select2 => {
697: D1 => "Choice D1",
698: D2 => "Choice D2",
699: D3 => "Choice D3",
700: D4 => "Choice D4",
701: D5 => "Choice D5",
702: D6 => "Choice D6",
703: D7 => "Choice D7"
1.609 raeburn 704: },
705: order => ['D4','D3','D2','D1','D7','D6','D5'],
1.112 bowersj2 706: }
707: );
1.36 matthew 708:
709: =cut
710:
711: sub linked_select_forms {
712: my ($formname,
713: $middletext,
714: $firstdefault,
715: $firstselectname,
716: $secondselectname,
1.609 raeburn 717: $hashref,
718: $menuorder,
1.36 matthew 719: ) = @_;
720: my $second = "document.$formname.$secondselectname";
721: my $first = "document.$formname.$firstselectname";
722: # output the javascript to do the changing
723: my $result = '';
1.219 albertel 724: $result.="<script type=\"text/javascript\">\n";
1.36 matthew 725: $result.="var select2data = new Object();\n";
726: $" = '","';
727: my $debug = '';
728: foreach my $s1 (sort(keys(%$hashref))) {
729: $result.="select2data.d_$s1 = new Object();\n";
730: $result.="select2data.d_$s1.def = new String('".
731: $hashref->{$s1}->{'default'}."');\n";
1.609 raeburn 732: $result.="select2data.d_$s1.values = new Array(";
1.36 matthew 733: my @s2values = sort(keys( %{ $hashref->{$s1}->{'select2'} } ));
1.609 raeburn 734: if (ref($hashref->{$s1}->{'order'}) eq 'ARRAY') {
735: @s2values = @{$hashref->{$s1}->{'order'}};
736: }
1.36 matthew 737: $result.="\"@s2values\");\n";
738: $result.="select2data.d_$s1.texts = new Array(";
739: my @s2texts;
740: foreach my $value (@s2values) {
741: push @s2texts, $hashref->{$s1}->{'select2'}->{$value};
742: }
743: $result.="\"@s2texts\");\n";
744: }
745: $"=' ';
746: $result.= <<"END";
747:
748: function select1_changed() {
749: // Determine new choice
750: var newvalue = "d_" + $first.value;
751: // update select2
752: var values = select2data[newvalue].values;
753: var texts = select2data[newvalue].texts;
754: var select2def = select2data[newvalue].def;
755: var i;
756: // out with the old
757: for (i = 0; i < $second.options.length; i++) {
758: $second.options[i] = null;
759: }
760: // in with the nuclear
761: for (i=0;i<values.length; i++) {
762: $second.options[i] = new Option(values[i]);
1.143 matthew 763: $second.options[i].value = values[i];
1.36 matthew 764: $second.options[i].text = texts[i];
765: if (values[i] == select2def) {
766: $second.options[i].selected = true;
767: }
768: }
769: }
770: </script>
771: END
772: # output the initial values for the selection lists
773: $result .= "<select size=\"1\" name=\"$firstselectname\" onchange=\"select1_changed()\">\n";
1.609 raeburn 774: my @order = sort(keys(%{$hashref}));
775: if (ref($menuorder) eq 'ARRAY') {
776: @order = @{$menuorder};
777: }
778: foreach my $value (@order) {
1.36 matthew 779: $result.=" <option value=\"$value\" ";
1.253 albertel 780: $result.=" selected=\"selected\" " if ($value eq $firstdefault);
1.119 www 781: $result.=">".&mt($hashref->{$value}->{'text'})."</option>\n";
1.36 matthew 782: }
783: $result .= "</select>\n";
784: my %select2 = %{$hashref->{$firstdefault}->{'select2'}};
785: $result .= $middletext;
786: $result .= "<select size=\"1\" name=\"$secondselectname\">\n";
787: my $seconddefault = $hashref->{$firstdefault}->{'default'};
1.609 raeburn 788:
789: my @secondorder = sort(keys(%select2));
790: if (ref($hashref->{$firstdefault}->{'order'}) eq 'ARRAY') {
791: @secondorder = @{$hashref->{$firstdefault}->{'order'}};
792: }
793: foreach my $value (@secondorder) {
1.36 matthew 794: $result.=" <option value=\"$value\" ";
1.253 albertel 795: $result.=" selected=\"selected\" " if ($value eq $seconddefault);
1.119 www 796: $result.=">".&mt($select2{$value})."</option>\n";
1.36 matthew 797: }
798: $result .= "</select>\n";
799: # return $debug;
800: return $result;
801: } # end of sub linked_select_forms {
802:
1.45 matthew 803: =pod
1.44 bowersj2 804:
1.648 raeburn 805: =item * &help_open_topic($topic,$text,$stayOnPage,$width,$height)
1.44 bowersj2 806:
1.112 bowersj2 807: Returns a string corresponding to an HTML link to the given help
808: $topic, where $topic corresponds to the name of a .tex file in
809: /home/httpd/html/adm/help/tex, with underscores replaced by
810: spaces.
811:
812: $text will optionally be linked to the same topic, allowing you to
813: link text in addition to the graphic. If you do not want to link
814: text, but wish to specify one of the later parameters, pass an
815: empty string.
816:
817: $stayOnPage is a value that will be interpreted as a boolean. If true,
818: the link will not open a new window. If false, the link will open
819: a new window using Javascript. (Default is false.)
820:
821: $width and $height are optional numerical parameters that will
822: override the width and height of the popped up window, which may
823: be useful for certain help topics with big pictures included.
1.44 bowersj2 824:
825: =cut
826:
827: sub help_open_topic {
1.48 bowersj2 828: my ($topic, $text, $stayOnPage, $width, $height) = @_;
829: $text = "" if (not defined $text);
1.44 bowersj2 830: $stayOnPage = 0 if (not defined $stayOnPage);
1.552 banghart 831: if ($env{'browser.interface'} eq 'textual') {
1.79 www 832: $stayOnPage=1;
833: }
1.44 bowersj2 834: $width = 350 if (not defined $width);
835: $height = 400 if (not defined $height);
836: my $filename = $topic;
837: $filename =~ s/ /_/g;
838:
1.48 bowersj2 839: my $template = "";
840: my $link;
1.572 banghart 841:
1.159 www 842: $topic=~s/\W/\_/g;
1.44 bowersj2 843:
1.572 banghart 844: if (!$stayOnPage) {
1.72 bowersj2 845: $link = "javascript:void(open('/adm/help/${filename}.hlp', 'Help_for_$topic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))";
1.572 banghart 846: } else {
1.48 bowersj2 847: $link = "/adm/help/${filename}.hlp";
848: }
849:
850: # Add the text
1.572 banghart 851: if ($text ne "") {
1.77 www 852: $template .=
1.572 banghart 853: "<table bgcolor='#3333AA' cellspacing='1' cellpadding='1' border='0'><tr>".
854: "<td bgcolor='#5555FF'><a target=\"_top\" href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";
1.48 bowersj2 855: }
856:
857: # Add the graphic
1.179 matthew 858: my $title = &mt('Online Help');
1.649 www 859: my $helpicon=&lonhttpdurl("/res/adm/pages/help.png");
1.48 bowersj2 860: $template .= <<"ENDTEMPLATE";
1.436 albertel 861: <a target="_top" href="$link" title="$title"><img src="$helpicon" border="0" alt="(Help: $topic)" /></a>
1.44 bowersj2 862: ENDTEMPLATE
1.78 www 863: if ($text ne '') { $template.='</td></tr></table>' };
1.44 bowersj2 864: return $template;
865:
1.106 bowersj2 866: }
867:
868: # This is a quicky function for Latex cheatsheet editing, since it
869: # appears in at least four places
870: sub helpLatexCheatsheet {
871: my $other = shift;
872: my $addOther = '';
873: if ($other) {
874: $addOther = Apache::loncommon::help_open_topic($other, shift,
875: undef, undef, 600) .
876: '</td><td>';
877: }
878: return '<table><tr><td>'.
879: $addOther .
1.636 raeburn 880: &Apache::loncommon::help_open_topic("Greek_Symbols",&mt('Greek Symbols'),
1.106 bowersj2 881: undef,undef,600)
882: .'</td><td>'.
1.636 raeburn 883: &Apache::loncommon::help_open_topic("Other_Symbols",&mt('Other Symbols'),
1.106 bowersj2 884: undef,undef,600)
885: .'</td></tr></table>';
1.172 www 886: }
887:
1.430 albertel 888: sub general_help {
889: my $helptopic='Student_Intro';
890: if ($env{'request.role'}=~/^(ca|au)/) {
891: $helptopic='Authoring_Intro';
892: } elsif ($env{'request.role'}=~/^cc/) {
893: $helptopic='Course_Coordination_Intro';
894: }
895: return $helptopic;
896: }
897:
898: sub update_help_link {
899: my ($topic,$component_help,$faq,$bug,$stayOnPage) = @_;
900: my $origurl = $ENV{'REQUEST_URI'};
901: $origurl=~s|^/~|/priv/|;
902: my $timestamp = time;
903: foreach my $datum (\$topic,\$component_help,\$faq,\$bug,\$origurl) {
904: $$datum = &escape($$datum);
905: }
906:
907: my $banner_link = "/adm/helpmenu?page=banner&topic=$topic&component_help=$component_help&faq=$faq&bug=$bug&origurl=$origurl&stamp=$timestamp&stayonpage=$stayOnPage";
908: my $output .= <<"ENDOUTPUT";
909: <script type="text/javascript">
910: banner_link = '$banner_link';
911: </script>
912: ENDOUTPUT
913: return $output;
914: }
915:
916: # now just updates the help link and generates a blue icon
1.193 raeburn 917: sub help_open_menu {
1.430 albertel 918: my ($topic,$component_help,$faq,$bug,$stayOnPage,$width,$height,$text)
1.552 banghart 919: = @_;
1.430 albertel 920: $stayOnPage = 0 if (not defined $stayOnPage);
1.572 banghart 921: # only use pop-up help (stayOnPage == 0)
1.552 banghart 922: # if environment.remote is on (using remote control UI)
1.572 banghart 923: if ($env{'browser.interface'} eq 'textual' ||
924: $env{'environment.remote'} eq 'off' ) {
1.552 banghart 925: $stayOnPage=1;
1.430 albertel 926: }
927: my $output;
928: if ($component_help) {
929: if (!$text) {
930: $output=&help_open_topic($component_help,undef,$stayOnPage,
931: $width,$height);
932: } else {
933: my $help_text;
934: $help_text=&unescape($topic);
935: $output='<table><tr><td>'.
936: &help_open_topic($component_help,$help_text,$stayOnPage,
937: $width,$height).'</td></tr></table>';
938: }
939: }
940: my $banner_link = &update_help_link($topic,$component_help,$faq,$bug,$stayOnPage);
941: return $output.$banner_link;
942: }
943:
944: sub top_nav_help {
945: my ($text) = @_;
1.436 albertel 946: $text = &mt($text);
1.572 banghart 947: my $stay_on_page =
1.436 albertel 948: ($env{'browser.interface'} eq 'textual' ||
949: $env{'environment.remote'} eq 'off' );
1.572 banghart 950: my $link = ($stay_on_page) ? "javascript:helpMenu('display')"
1.436 albertel 951: : "javascript:helpMenu('open')";
1.572 banghart 952: my $banner_link = &update_help_link(undef,undef,undef,undef,$stay_on_page);
1.436 albertel 953:
1.201 raeburn 954: my $title = &mt('Get help');
1.436 albertel 955:
956: return <<"END";
957: $banner_link
958: <a href="$link" title="$title">$text</a>
959: END
960: }
961:
962: sub help_menu_js {
963: my ($text) = @_;
964:
965: my $stayOnPage =
966: ($env{'browser.interface'} eq 'textual' ||
967: $env{'environment.remote'} eq 'off' );
968:
969: my $width = 620;
970: my $height = 600;
1.430 albertel 971: my $helptopic=&general_help();
972: my $details_link = '/adm/help/'.$helptopic.'.hlp';
1.261 albertel 973: my $nothing=&Apache::lonhtmlcommon::javascript_nothing();
1.331 albertel 974: my $start_page =
975: &Apache::loncommon::start_page('Help Menu', undef,
976: {'frameset' => 1,
977: 'js_ready' => 1,
978: 'add_entries' => {
979: 'border' => '0',
1.579 raeburn 980: 'rows' => "110,*",},});
1.331 albertel 981: my $end_page =
982: &Apache::loncommon::end_page({'frameset' => 1,
983: 'js_ready' => 1,});
984:
1.436 albertel 985: my $template .= <<"ENDTEMPLATE";
986: <script type="text/javascript">
1.253 albertel 987: // <!-- BEGIN LON-CAPA Internal
988: // <![CDATA[
1.430 albertel 989: var banner_link = '';
1.243 raeburn 990: function helpMenu(target) {
991: var caller = this;
992: if (target == 'open') {
993: var newWindow = null;
994: try {
1.262 albertel 995: newWindow = window.open($nothing,"helpmenu","HEIGHT=$height,WIDTH=$width,resizable=yes,scrollbars=yes" )
1.243 raeburn 996: }
997: catch(error) {
998: writeHelp(caller);
999: return;
1000: }
1001: if (newWindow) {
1002: caller = newWindow;
1003: }
1.193 raeburn 1004: }
1.243 raeburn 1005: writeHelp(caller);
1006: return;
1007: }
1008: function writeHelp(caller) {
1.430 albertel 1009: caller.document.writeln('$start_page<frame name="bannerframe" src="'+banner_link+'" /><frame name="bodyframe" src="$details_link" /> $end_page')
1.243 raeburn 1010: caller.document.close()
1011: caller.focus()
1.193 raeburn 1012: }
1.253 albertel 1013: // ]]>
1.219 albertel 1014: // END LON-CAPA Internal -->
1.436 albertel 1015: </script>
1.193 raeburn 1016: ENDTEMPLATE
1017: return $template;
1018: }
1019:
1.172 www 1020: sub help_open_bug {
1021: my ($topic, $text, $stayOnPage, $width, $height) = @_;
1.258 albertel 1022: unless ($env{'user.adv'}) { return ''; }
1.172 www 1023: unless ($Apache::lonnet::perlvar{'BugzillaHost'}) { return ''; }
1024: $text = "" if (not defined $text);
1025: $stayOnPage = 0 if (not defined $stayOnPage);
1.258 albertel 1026: if ($env{'browser.interface'} eq 'textual' ||
1027: $env{'environment.remote'} eq 'off' ) {
1.172 www 1028: $stayOnPage=1;
1029: }
1.184 albertel 1030: $width = 600 if (not defined $width);
1031: $height = 600 if (not defined $height);
1.172 www 1032:
1033: $topic=~s/\W+/\+/g;
1034: my $link='';
1035: my $template='';
1.379 albertel 1036: my $url=$Apache::lonnet::perlvar{'BugzillaHost'}.'enter_bug.cgi?product=LON-CAPA&bug_file_loc='.
1037: &escape($ENV{'REQUEST_URI'}).'&component='.$topic;
1.172 www 1038: if (!$stayOnPage)
1039: {
1040: $link = "javascript:void(open('$url', 'Bugzilla', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))";
1041: }
1042: else
1043: {
1044: $link = $url;
1045: }
1046: # Add the text
1047: if ($text ne "")
1048: {
1049: $template .=
1050: "<table bgcolor='#AA3333' cellspacing='1' cellpadding='1' border='0'><tr>".
1.436 albertel 1051: "<td bgcolor='#FF5555'><a target=\"_top\" href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";
1.172 www 1052: }
1053:
1054: # Add the graphic
1.179 matthew 1055: my $title = &mt('Report a Bug');
1.215 albertel 1056: my $bugicon=&lonhttpdurl("/adm/lonMisc/smallBug.gif");
1.172 www 1057: $template .= <<"ENDTEMPLATE";
1.436 albertel 1058: <a target="_top" href="$link" title="$title"><img src="$bugicon" border="0" alt="(Bug: $topic)" /></a>
1.172 www 1059: ENDTEMPLATE
1060: if ($text ne '') { $template.='</td></tr></table>' };
1061: return $template;
1062:
1063: }
1064:
1065: sub help_open_faq {
1066: my ($topic, $text, $stayOnPage, $width, $height) = @_;
1.258 albertel 1067: unless ($env{'user.adv'}) { return ''; }
1.172 www 1068: unless ($Apache::lonnet::perlvar{'FAQHost'}) { return ''; }
1069: $text = "" if (not defined $text);
1070: $stayOnPage = 0 if (not defined $stayOnPage);
1.258 albertel 1071: if ($env{'browser.interface'} eq 'textual' ||
1072: $env{'environment.remote'} eq 'off' ) {
1.172 www 1073: $stayOnPage=1;
1074: }
1075: $width = 350 if (not defined $width);
1076: $height = 400 if (not defined $height);
1077:
1078: $topic=~s/\W+/\+/g;
1079: my $link='';
1080: my $template='';
1081: my $url=$Apache::lonnet::perlvar{'FAQHost'}.'/fom/cache/'.$topic.'.html';
1082: if (!$stayOnPage)
1083: {
1084: $link = "javascript:void(open('$url', 'FAQ-O-Matic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))";
1085: }
1086: else
1087: {
1088: $link = $url;
1089: }
1090:
1091: # Add the text
1092: if ($text ne "")
1093: {
1094: $template .=
1.173 www 1095: "<table bgcolor='#337733' cellspacing='1' cellpadding='1' border='0'><tr>".
1.436 albertel 1096: "<td bgcolor='#448844'><a target=\"_top\" href=\"$link\"><font color='#FFFFFF' size='2'>$text</font></a>";
1.172 www 1097: }
1098:
1099: # Add the graphic
1.179 matthew 1100: my $title = &mt('View the FAQ');
1.215 albertel 1101: my $faqicon=&lonhttpdurl("/adm/lonMisc/smallFAQ.gif");
1.172 www 1102: $template .= <<"ENDTEMPLATE";
1.436 albertel 1103: <a target="_top" href="$link" title="$title"><img src="$faqicon" border="0" alt="(FAQ: $topic)" /></a>
1.172 www 1104: ENDTEMPLATE
1105: if ($text ne '') { $template.='</td></tr></table>' };
1106: return $template;
1107:
1.44 bowersj2 1108: }
1.37 matthew 1109:
1.180 matthew 1110: ###############################################################
1111: ###############################################################
1112:
1.45 matthew 1113: =pod
1114:
1.648 raeburn 1115: =item * &change_content_javascript():
1.256 matthew 1116:
1117: This and the next function allow you to create small sections of an
1118: otherwise static HTML page that you can update on the fly with
1119: Javascript, even in Netscape 4.
1120:
1121: The Javascript fragment returned by this function (no E<lt>scriptE<gt> tag)
1122: must be written to the HTML page once. It will prove the Javascript
1123: function "change(name, content)". Calling the change function with the
1124: name of the section
1125: you want to update, matching the name passed to C<changable_area>, and
1126: the new content you want to put in there, will put the content into
1127: that area.
1128:
1129: B<Note>: Netscape 4 only reserves enough space for the changable area
1130: to contain room for the original contents. You need to "make space"
1131: for whatever changes you wish to make, and be B<sure> to check your
1132: code in Netscape 4. This feature in Netscape 4 is B<not> powerful;
1133: it's adequate for updating a one-line status display, but little more.
1134: This script will set the space to 100% width, so you only need to
1135: worry about height in Netscape 4.
1136:
1137: Modern browsers are much less limiting, and if you can commit to the
1138: user not using Netscape 4, this feature may be used freely with
1139: pretty much any HTML.
1140:
1141: =cut
1142:
1143: sub change_content_javascript {
1144: # If we're on Netscape 4, we need to use Layer-based code
1.258 albertel 1145: if ($env{'browser.type'} eq 'netscape' &&
1146: $env{'browser.version'} =~ /^4\./) {
1.256 matthew 1147: return (<<NETSCAPE4);
1148: function change(name, content) {
1149: doc = document.layers[name+"___escape"].layers[0].document;
1150: doc.open();
1151: doc.write(content);
1152: doc.close();
1153: }
1154: NETSCAPE4
1155: } else {
1156: # Otherwise, we need to use semi-standards-compliant code
1157: # (technically, "innerHTML" isn't standard but the equivalent
1158: # is really scary, and every useful browser supports it
1159: return (<<DOMBASED);
1160: function change(name, content) {
1161: element = document.getElementById(name);
1162: element.innerHTML = content;
1163: }
1164: DOMBASED
1165: }
1166: }
1167:
1168: =pod
1169:
1.648 raeburn 1170: =item * &changable_area($name,$origContent):
1.256 matthew 1171:
1172: This provides a "changable area" that can be modified on the fly via
1173: the Javascript code provided in C<change_content_javascript>. $name is
1174: the name you will use to reference the area later; do not repeat the
1175: same name on a given HTML page more then once. $origContent is what
1176: the area will originally contain, which can be left blank.
1177:
1178: =cut
1179:
1180: sub changable_area {
1181: my ($name, $origContent) = @_;
1182:
1.258 albertel 1183: if ($env{'browser.type'} eq 'netscape' &&
1184: $env{'browser.version'} =~ /^4\./) {
1.256 matthew 1185: # If this is netscape 4, we need to use the Layer tag
1186: return "<ilayer width='100%' id='${name}___escape' overflow='none'><layer width='100%' id='$name' overflow='none'>$origContent</layer></ilayer>";
1187: } else {
1188: return "<span id='$name'>$origContent</span>";
1189: }
1190: }
1191:
1192: =pod
1193:
1.648 raeburn 1194: =item * &viewport_geometry_js
1.590 raeburn 1195:
1196: Provides javascript object (Geometry) which can provide information about the viewport geometry for the client browser.
1197:
1198: =cut
1199:
1200:
1201: sub viewport_geometry_js {
1202: return <<"GEOMETRY";
1203: var Geometry = {};
1204: function init_geometry() {
1205: if (Geometry.init) { return };
1206: Geometry.init=1;
1207: if (window.innerHeight) {
1208: Geometry.getViewportHeight = function() { return window.innerHeight; };
1209: Geometry.getViewportWidth = function() { return window.innerWidth; };
1210: Geometry.getHorizontalScroll = function() { return window.pageXOffset; };
1211: Geometry.getVerticalScroll = function() { return window.pageYOffset; };
1212: }
1213: else if (document.documentElement && document.documentElement.clientHeight) {
1214: Geometry.getViewportHeight =
1215: function() { return document.documentElement.clientHeight; };
1216: Geometry.getViewportWidth =
1217: function() { return document.documentElement.clientWidth; };
1218:
1219: Geometry.getHorizontalScroll =
1220: function() { return document.documentElement.scrollLeft; };
1221: Geometry.getVerticalScroll =
1222: function() { return document.documentElement.scrollTop; };
1223: }
1224: else if (document.body.clientHeight) {
1225: Geometry.getViewportHeight =
1226: function() { return document.body.clientHeight; };
1227: Geometry.getViewportWidth =
1228: function() { return document.body.clientWidth; };
1229: Geometry.getHorizontalScroll =
1230: function() { return document.body.scrollLeft; };
1231: Geometry.getVerticalScroll =
1232: function() { return document.body.scrollTop; };
1233: }
1234: }
1235:
1236: GEOMETRY
1237: }
1238:
1239: =pod
1240:
1.648 raeburn 1241: =item * &viewport_size_js()
1.590 raeburn 1242:
1243: Provides a javascript function to set values of two form elements - width and height (elements are passed in as arguments to the javascript function) to the dimensions of the user's browser window.
1244:
1245: =cut
1246:
1247: sub viewport_size_js {
1248: my $geometry = &viewport_geometry_js();
1249: return <<"DIMS";
1250:
1251: $geometry
1252:
1253: function getViewportDims(width,height) {
1254: init_geometry();
1255: width.value = Geometry.getViewportWidth();
1256: height.value = Geometry.getViewportHeight();
1257: return;
1258: }
1259:
1260: DIMS
1261: }
1262:
1263: =pod
1264:
1.648 raeburn 1265: =item * &resize_textarea_js()
1.565 albertel 1266:
1267: emits the needed javascript to resize a textarea to be as big as possible
1268:
1269: creates a function resize_textrea that takes two IDs first should be
1270: the id of the element to resize, second should be the id of a div that
1271: surrounds everything that comes after the textarea, this routine needs
1272: to be attached to the <body> for the onload and onresize events.
1273:
1.648 raeburn 1274: =back
1.565 albertel 1275:
1276: =cut
1277:
1278: sub resize_textarea_js {
1.590 raeburn 1279: my $geometry = &viewport_geometry_js();
1.565 albertel 1280: return <<"RESIZE";
1281: <script type="text/javascript">
1.590 raeburn 1282: $geometry
1.565 albertel 1283:
1.588 albertel 1284: function getX(element) {
1285: var x = 0;
1286: while (element) {
1287: x += element.offsetLeft;
1288: element = element.offsetParent;
1289: }
1290: return x;
1291: }
1292: function getY(element) {
1293: var y = 0;
1294: while (element) {
1295: y += element.offsetTop;
1296: element = element.offsetParent;
1297: }
1298: return y;
1299: }
1300:
1301:
1.565 albertel 1302: function resize_textarea(textarea_id,bottom_id) {
1303: init_geometry();
1304: var textarea = document.getElementById(textarea_id);
1305: //alert(textarea);
1306:
1.588 albertel 1307: var textarea_top = getY(textarea);
1.565 albertel 1308: var textarea_height = textarea.offsetHeight;
1309: var bottom = document.getElementById(bottom_id);
1.588 albertel 1310: var bottom_top = getY(bottom);
1.565 albertel 1311: var bottom_height = bottom.offsetHeight;
1312: var window_height = Geometry.getViewportHeight();
1.588 albertel 1313: var fudge = 23;
1.565 albertel 1314: var new_height = window_height-fudge-textarea_top-bottom_height;
1315: if (new_height < 300) {
1316: new_height = 300;
1317: }
1318: textarea.style.height=new_height+'px';
1319: }
1320: </script>
1321: RESIZE
1322:
1323: }
1324:
1325: =pod
1326:
1.256 matthew 1327: =head1 Excel and CSV file utility routines
1328:
1329: =over 4
1330:
1331: =cut
1332:
1333: ###############################################################
1334: ###############################################################
1335:
1336: =pod
1337:
1.648 raeburn 1338: =item * &csv_translate($text)
1.37 matthew 1339:
1.185 www 1340: Translate $text to allow it to be output as a 'comma separated values'
1.37 matthew 1341: format.
1342:
1343: =cut
1344:
1.180 matthew 1345: ###############################################################
1346: ###############################################################
1.37 matthew 1347: sub csv_translate {
1348: my $text = shift;
1349: $text =~ s/\"/\"\"/g;
1.209 albertel 1350: $text =~ s/\n/ /g;
1.37 matthew 1351: return $text;
1352: }
1.180 matthew 1353:
1354: ###############################################################
1355: ###############################################################
1356:
1357: =pod
1358:
1.648 raeburn 1359: =item * &define_excel_formats()
1.180 matthew 1360:
1361: Define some commonly used Excel cell formats.
1362:
1363: Currently supported formats:
1364:
1365: =over 4
1366:
1367: =item header
1368:
1369: =item bold
1370:
1371: =item h1
1372:
1373: =item h2
1374:
1375: =item h3
1376:
1.256 matthew 1377: =item h4
1378:
1379: =item i
1380:
1.180 matthew 1381: =item date
1382:
1383: =back
1384:
1385: Inputs: $workbook
1386:
1387: Returns: $format, a hash reference.
1388:
1389: =cut
1390:
1391: ###############################################################
1392: ###############################################################
1393: sub define_excel_formats {
1394: my ($workbook) = @_;
1395: my $format;
1396: $format->{'header'} = $workbook->add_format(bold => 1,
1397: bottom => 1,
1398: align => 'center');
1399: $format->{'bold'} = $workbook->add_format(bold=>1);
1400: $format->{'h1'} = $workbook->add_format(bold=>1, size=>18);
1401: $format->{'h2'} = $workbook->add_format(bold=>1, size=>16);
1402: $format->{'h3'} = $workbook->add_format(bold=>1, size=>14);
1.255 matthew 1403: $format->{'h4'} = $workbook->add_format(bold=>1, size=>12);
1.246 matthew 1404: $format->{'i'} = $workbook->add_format(italic=>1);
1.180 matthew 1405: $format->{'date'} = $workbook->add_format(num_format=>
1.207 matthew 1406: 'mm/dd/yyyy hh:mm:ss');
1.180 matthew 1407: return $format;
1408: }
1409:
1410: ###############################################################
1411: ###############################################################
1.113 bowersj2 1412:
1413: =pod
1414:
1.648 raeburn 1415: =item * &create_workbook()
1.255 matthew 1416:
1417: Create an Excel worksheet. If it fails, output message on the
1418: request object and return undefs.
1419:
1420: Inputs: Apache request object
1421:
1422: Returns (undef) on failure,
1423: Excel worksheet object, scalar with filename, and formats
1424: from &Apache::loncommon::define_excel_formats on success
1425:
1426: =cut
1427:
1428: ###############################################################
1429: ###############################################################
1430: sub create_workbook {
1431: my ($r) = @_;
1432: #
1433: # Create the excel spreadsheet
1434: my $filename = '/prtspool/'.
1.258 albertel 1435: $env{'user.name'}.'_'.$env{'user.domain'}.'_'.
1.255 matthew 1436: time.'_'.rand(1000000000).'.xls';
1437: my $workbook = Spreadsheet::WriteExcel->new('/home/httpd'.$filename);
1438: if (! defined($workbook)) {
1439: $r->log_error("Error creating excel spreadsheet $filename: $!");
1440: $r->print('<p>'.&mt("Unable to create new Excel file. ".
1441: "This error has been logged. ".
1442: "Please alert your LON-CAPA administrator").
1443: '</p>');
1444: return (undef);
1445: }
1446: #
1447: $workbook->set_tempdir('/home/httpd/perl/tmp');
1448: #
1449: my $format = &Apache::loncommon::define_excel_formats($workbook);
1450: return ($workbook,$filename,$format);
1451: }
1452:
1453: ###############################################################
1454: ###############################################################
1455:
1456: =pod
1457:
1.648 raeburn 1458: =item * &create_text_file()
1.113 bowersj2 1459:
1.542 raeburn 1460: Create a file to write to and eventually make available to the user.
1.256 matthew 1461: If file creation fails, outputs an error message on the request object and
1462: return undefs.
1.113 bowersj2 1463:
1.256 matthew 1464: Inputs: Apache request object, and file suffix
1.113 bowersj2 1465:
1.256 matthew 1466: Returns (undef) on failure,
1467: Filehandle and filename on success.
1.113 bowersj2 1468:
1469: =cut
1470:
1.256 matthew 1471: ###############################################################
1472: ###############################################################
1473: sub create_text_file {
1474: my ($r,$suffix) = @_;
1475: if (! defined($suffix)) { $suffix = 'txt'; };
1476: my $fh;
1477: my $filename = '/prtspool/'.
1.258 albertel 1478: $env{'user.name'}.'_'.$env{'user.domain'}.'_'.
1.256 matthew 1479: time.'_'.rand(1000000000).'.'.$suffix;
1480: $fh = Apache::File->new('>/home/httpd'.$filename);
1481: if (! defined($fh)) {
1482: $r->log_error("Couldn't open $filename for output $!");
1483: $r->print("Problems occured in creating the output file. ".
1484: "This error has been logged. ".
1485: "Please alert your LON-CAPA administrator.");
1.113 bowersj2 1486: }
1.256 matthew 1487: return ($fh,$filename)
1.113 bowersj2 1488: }
1489:
1490:
1.256 matthew 1491: =pod
1.113 bowersj2 1492:
1493: =back
1494:
1495: =cut
1.37 matthew 1496:
1497: ###############################################################
1.33 matthew 1498: ## Home server <option> list generating code ##
1499: ###############################################################
1.35 matthew 1500:
1.169 www 1501: # ------------------------------------------
1502:
1503: sub domain_select {
1504: my ($name,$value,$multiple)=@_;
1505: my %domains=map {
1.514 albertel 1506: $_ => $_.' '. &Apache::lonnet::domain($_,'description')
1.512 albertel 1507: } &Apache::lonnet::all_domains();
1.169 www 1508: if ($multiple) {
1509: $domains{''}=&mt('Any domain');
1.550 albertel 1510: $domains{'select_form_order'} = [sort {lc($a) cmp lc($b) } (keys(%domains))];
1.287 albertel 1511: return &multiple_select_form($name,$value,4,\%domains);
1.169 www 1512: } else {
1.550 albertel 1513: $domains{'select_form_order'} = [sort {lc($a) cmp lc($b) } (keys(%domains))];
1.169 www 1514: return &select_form($name,$value,%domains);
1515: }
1516: }
1517:
1.282 albertel 1518: #-------------------------------------------
1519:
1520: =pod
1521:
1.519 raeburn 1522: =head1 Routines for form select boxes
1523:
1524: =over 4
1525:
1.648 raeburn 1526: =item * &multiple_select_form($name,$value,$size,$hash,$order)
1.282 albertel 1527:
1528: Returns a string containing a <select> element int multiple mode
1529:
1530:
1531: Args:
1532: $name - name of the <select> element
1.506 raeburn 1533: $value - scalar or array ref of values that should already be selected
1.282 albertel 1534: $size - number of rows long the select element is
1.283 albertel 1535: $hash - the elements should be 'option' => 'shown text'
1.282 albertel 1536: (shown text should already have been &mt())
1.506 raeburn 1537: $order - (optional) array ref of the order to show the elements in
1.283 albertel 1538:
1.282 albertel 1539: =cut
1540:
1541: #-------------------------------------------
1.169 www 1542: sub multiple_select_form {
1.284 albertel 1543: my ($name,$value,$size,$hash,$order)=@_;
1.169 www 1544: my %selected = map { $_ => 1 } ref($value)?@{$value}:($value);
1545: my $output='';
1.191 matthew 1546: if (! defined($size)) {
1547: $size = 4;
1.283 albertel 1548: if (scalar(keys(%$hash))<4) {
1549: $size = scalar(keys(%$hash));
1.191 matthew 1550: }
1551: }
1.169 www 1552: $output.="\n<select name='$name' size='$size' multiple='1'>";
1.501 banghart 1553: my @order;
1.506 raeburn 1554: if (ref($order) eq 'ARRAY') {
1555: @order = @{$order};
1556: } else {
1557: @order = sort(keys(%$hash));
1.501 banghart 1558: }
1559: if (exists($$hash{'select_form_order'})) {
1560: @order = @{$$hash{'select_form_order'}};
1561: }
1562:
1.284 albertel 1563: foreach my $key (@order) {
1.356 albertel 1564: $output.='<option value="'.&HTML::Entities::encode($key,'"<>&').'" ';
1.284 albertel 1565: $output.='selected="selected" ' if ($selected{$key});
1566: $output.='>'.$hash->{$key}."</option>\n";
1.169 www 1567: }
1568: $output.="</select>\n";
1569: return $output;
1570: }
1571:
1.88 www 1572: #-------------------------------------------
1573:
1574: =pod
1575:
1.648 raeburn 1576: =item * &select_form($defdom,$name,%hash)
1.88 www 1577:
1578: Returns a string containing a <select name='$name' size='1'> form to
1579: allow a user to select options from a hash option_name => displayed text.
1580: See lonrights.pm for an example invocation and use.
1581:
1582: =cut
1583:
1584: #-------------------------------------------
1585: sub select_form {
1586: my ($def,$name,%hash) = @_;
1587: my $selectform = "<select name=\"$name\" size=\"1\">\n";
1.128 albertel 1588: my @keys;
1589: if (exists($hash{'select_form_order'})) {
1590: @keys=@{$hash{'select_form_order'}};
1591: } else {
1592: @keys=sort(keys(%hash));
1593: }
1.356 albertel 1594: foreach my $key (@keys) {
1595: $selectform.=
1596: '<option value="'.&HTML::Entities::encode($key,'"<>&').'" '.
1597: ($key eq $def ? 'selected="selected" ' : '').
1598: ">".&mt($hash{$key})."</option>\n";
1.88 www 1599: }
1600: $selectform.="</select>";
1601: return $selectform;
1602: }
1603:
1.475 www 1604: # For display filters
1605:
1606: sub display_filter {
1607: if (!$env{'form.show'}) { $env{'form.show'}=10; }
1.477 www 1608: if (!$env{'form.displayfilter'}) { $env{'form.displayfilter'}='currentfolder'; }
1.475 www 1609: return '<nobr><label>'.&mt('Records [_1]',
1610: &Apache::lonmeta::selectbox('show',$env{'form.show'},undef,
1611: (&mt('all'),10,20,50,100,1000,10000))).
1.478 www 1612: '</label></nobr> <nobr>'.
1.475 www 1613: &mt('Filter [_1]',
1.477 www 1614: &select_form($env{'form.displayfilter'},
1615: 'displayfilter',
1616: ('currentfolder' => 'Current folder/page',
1617: 'containing' => 'Containing phrase',
1618: 'none' => 'None'))).
1.478 www 1619: '<input type="text" name="containingphrase" size="30" value="'.&HTML::Entities::encode($env{'form.containingphrase'}).'" /></nobr>';
1.475 www 1620: }
1621:
1.167 www 1622: sub gradeleveldescription {
1623: my $gradelevel=shift;
1624: my %gradelevels=(0 => 'Not specified',
1625: 1 => 'Grade 1',
1626: 2 => 'Grade 2',
1627: 3 => 'Grade 3',
1628: 4 => 'Grade 4',
1629: 5 => 'Grade 5',
1630: 6 => 'Grade 6',
1631: 7 => 'Grade 7',
1632: 8 => 'Grade 8',
1633: 9 => 'Grade 9',
1634: 10 => 'Grade 10',
1635: 11 => 'Grade 11',
1636: 12 => 'Grade 12',
1637: 13 => 'Grade 13',
1638: 14 => '100 Level',
1639: 15 => '200 Level',
1640: 16 => '300 Level',
1641: 17 => '400 Level',
1642: 18 => 'Graduate Level');
1643: return &mt($gradelevels{$gradelevel});
1644: }
1645:
1.163 www 1646: sub select_level_form {
1647: my ($deflevel,$name)=@_;
1648: unless ($deflevel) { $deflevel=0; }
1.167 www 1649: my $selectform = "<select name=\"$name\" size=\"1\">\n";
1650: for (my $i=0; $i<=18; $i++) {
1651: $selectform.="<option value=\"$i\" ".
1.253 albertel 1652: ($i==$deflevel ? 'selected="selected" ' : '').
1.167 www 1653: ">".&gradeleveldescription($i)."</option>\n";
1654: }
1655: $selectform.="</select>";
1656: return $selectform;
1.163 www 1657: }
1.167 www 1658:
1.35 matthew 1659: #-------------------------------------------
1660:
1.45 matthew 1661: =pod
1662:
1.648 raeburn 1663: =item * &select_dom_form($defdom,$name,$includeempty,$showdomdesc)
1.35 matthew 1664:
1665: Returns a string containing a <select name='$name' size='1'> form to
1666: allow a user to select the domain to preform an operation in.
1667: See loncreateuser.pm for an example invocation and use.
1668:
1.90 www 1669: If the $includeempty flag is set, it also includes an empty choice ("no domain
1670: selected");
1671:
1.563 raeburn 1672: If the $showdomdesc flag is set, the domain name is followed by the domain description.
1673:
1.35 matthew 1674: =cut
1675:
1676: #-------------------------------------------
1.34 matthew 1677: sub select_dom_form {
1.563 raeburn 1678: my ($defdom,$name,$includeempty,$showdomdesc) = @_;
1.550 albertel 1679: my @domains = sort {lc($a) cmp lc($b)} (&Apache::lonnet::all_domains());
1.90 www 1680: if ($includeempty) { @domains=('',@domains); }
1.34 matthew 1681: my $selectdomain = "<select name=\"$name\" size=\"1\">\n";
1.356 albertel 1682: foreach my $dom (@domains) {
1683: $selectdomain.="<option value=\"$dom\" ".
1.563 raeburn 1684: ($dom eq $defdom ? 'selected="selected" ' : '').'>'.$dom;
1685: if ($showdomdesc) {
1686: if ($dom ne '') {
1687: my $domdesc = &Apache::lonnet::domain($dom,'description');
1688: if ($domdesc ne '') {
1689: $selectdomain .= ' ('.$domdesc.')';
1690: }
1691: }
1692: }
1693: $selectdomain .= "</option>\n";
1.34 matthew 1694: }
1695: $selectdomain.="</select>";
1696: return $selectdomain;
1697: }
1698:
1.35 matthew 1699: #-------------------------------------------
1700:
1.45 matthew 1701: =pod
1702:
1.648 raeburn 1703: =item * &home_server_form_item($domain,$name,$defaultflag)
1.35 matthew 1704:
1.586 raeburn 1705: input: 4 arguments (two required, two optional) -
1706: $domain - domain of new user
1707: $name - name of form element
1708: $default - Value of 'default' causes a default item to be first
1709: option, and selected by default.
1710: $hide - Value of 'hide' causes hiding of the name of the server,
1711: if 1 server found, or default, if 0 found.
1.594 raeburn 1712: output: returns 2 items:
1.586 raeburn 1713: (a) form element which contains either:
1714: (i) <select name="$name">
1715: <option value="$hostid1">$hostid $servers{$hostid}</option>
1716: <option value="$hostid2">$hostid $servers{$hostid}</option>
1717: </select>
1718: form item if there are multiple library servers in $domain, or
1719: (ii) an <input type="hidden" name="$name" value="$hostid" /> form item
1720: if there is only one library server in $domain.
1721:
1722: (b) number of library servers found.
1723:
1724: See loncreateuser.pm for example of use.
1.35 matthew 1725:
1726: =cut
1727:
1728: #-------------------------------------------
1.586 raeburn 1729: sub home_server_form_item {
1730: my ($domain,$name,$default,$hide) = @_;
1.513 albertel 1731: my %servers = &Apache::lonnet::get_servers($domain,'library');
1.586 raeburn 1732: my $result;
1733: my $numlib = keys(%servers);
1734: if ($numlib > 1) {
1735: $result .= '<select name="'.$name.'" />'."\n";
1736: if ($default) {
1737: $result .= '<option value="default" selected>'.&mt('default').
1738: '</option>'."\n";
1739: }
1740: foreach my $hostid (sort(keys(%servers))) {
1741: $result.= '<option value="'.$hostid.'">'.
1742: $hostid.' '.$servers{$hostid}."</option>\n";
1743: }
1744: $result .= '</select>'."\n";
1745: } elsif ($numlib == 1) {
1746: my $hostid;
1747: foreach my $item (keys(%servers)) {
1748: $hostid = $item;
1749: }
1750: $result .= '<input type="hidden" name="'.$name.'" value="'.
1751: $hostid.'" />';
1752: if (!$hide) {
1753: $result .= $hostid.' '.$servers{$hostid};
1754: }
1755: $result .= "\n";
1756: } elsif ($default) {
1757: $result .= '<input type="hidden" name="'.$name.
1758: '" value="default" />';
1759: if (!$hide) {
1760: $result .= &mt('default');
1761: }
1762: $result .= "\n";
1.33 matthew 1763: }
1.586 raeburn 1764: return ($result,$numlib);
1.33 matthew 1765: }
1.112 bowersj2 1766:
1767: =pod
1768:
1.534 albertel 1769: =back
1770:
1.112 bowersj2 1771: =cut
1.87 matthew 1772:
1773: ###############################################################
1.112 bowersj2 1774: ## Decoding User Agent ##
1.87 matthew 1775: ###############################################################
1776:
1777: =pod
1778:
1.112 bowersj2 1779: =head1 Decoding the User Agent
1780:
1781: =over 4
1782:
1783: =item * &decode_user_agent()
1.87 matthew 1784:
1785: Inputs: $r
1786:
1787: Outputs:
1788:
1789: =over 4
1790:
1.112 bowersj2 1791: =item * $httpbrowser
1.87 matthew 1792:
1.112 bowersj2 1793: =item * $clientbrowser
1.87 matthew 1794:
1.112 bowersj2 1795: =item * $clientversion
1.87 matthew 1796:
1.112 bowersj2 1797: =item * $clientmathml
1.87 matthew 1798:
1.112 bowersj2 1799: =item * $clientunicode
1.87 matthew 1800:
1.112 bowersj2 1801: =item * $clientos
1.87 matthew 1802:
1803: =back
1804:
1.157 matthew 1805: =back
1806:
1.87 matthew 1807: =cut
1808:
1809: ###############################################################
1810: ###############################################################
1811: sub decode_user_agent {
1.247 albertel 1812: my ($r)=@_;
1.87 matthew 1813: my @browsertype=split(/\&/,$Apache::lonnet::perlvar{"lonBrowsDet"});
1814: my %mathcap=split(/\&/,$$Apache::lonnet::perlvar{"lonMathML"});
1815: my $httpbrowser=$ENV{"HTTP_USER_AGENT"};
1.247 albertel 1816: if (!$httpbrowser && $r) { $httpbrowser=$r->header_in('User-Agent'); }
1.87 matthew 1817: my $clientbrowser='unknown';
1818: my $clientversion='0';
1819: my $clientmathml='';
1820: my $clientunicode='0';
1821: for (my $i=0;$i<=$#browsertype;$i++) {
1822: my ($bname,$match,$notmatch,$vreg,$minv,$univ)=split(/\:/,$browsertype[$i]);
1823: if (($httpbrowser=~/$match/i) && ($httpbrowser!~/$notmatch/i)) {
1824: $clientbrowser=$bname;
1825: $httpbrowser=~/$vreg/i;
1826: $clientversion=$1;
1827: $clientmathml=($clientversion>=$minv);
1828: $clientunicode=($clientversion>=$univ);
1829: }
1830: }
1831: my $clientos='unknown';
1832: if (($httpbrowser=~/linux/i) ||
1833: ($httpbrowser=~/unix/i) ||
1834: ($httpbrowser=~/ux/i) ||
1835: ($httpbrowser=~/solaris/i)) { $clientos='unix'; }
1836: if (($httpbrowser=~/vax/i) ||
1837: ($httpbrowser=~/vms/i)) { $clientos='vms'; }
1838: if ($httpbrowser=~/next/i) { $clientos='next'; }
1839: if (($httpbrowser=~/mac/i) ||
1840: ($httpbrowser=~/powerpc/i)) { $clientos='mac'; }
1841: if ($httpbrowser=~/win/i) { $clientos='win'; }
1842: if ($httpbrowser=~/embed/i) { $clientos='pda'; }
1843: return ($httpbrowser,$clientbrowser,$clientversion,$clientmathml,
1844: $clientunicode,$clientos,);
1845: }
1846:
1.32 matthew 1847: ###############################################################
1848: ## Authentication changing form generation subroutines ##
1849: ###############################################################
1850: ##
1851: ## All of the authform_xxxxxxx subroutines take their inputs in a
1852: ## hash, and have reasonable default values.
1853: ##
1854: ## formname = the name given in the <form> tag.
1.35 matthew 1855: #-------------------------------------------
1856:
1.45 matthew 1857: =pod
1858:
1.112 bowersj2 1859: =head1 Authentication Routines
1860:
1861: =over 4
1862:
1.648 raeburn 1863: =item * &authform_xxxxxx()
1.35 matthew 1864:
1865: The authform_xxxxxx subroutines provide javascript and html forms which
1866: handle some of the conveniences required for authentication forms.
1867: This is not an optimal method, but it works.
1868:
1869: =over 4
1870:
1.112 bowersj2 1871: =item * authform_header
1.35 matthew 1872:
1.112 bowersj2 1873: =item * authform_authorwarning
1.35 matthew 1874:
1.112 bowersj2 1875: =item * authform_nochange
1.35 matthew 1876:
1.112 bowersj2 1877: =item * authform_kerberos
1.35 matthew 1878:
1.112 bowersj2 1879: =item * authform_internal
1.35 matthew 1880:
1.112 bowersj2 1881: =item * authform_filesystem
1.35 matthew 1882:
1883: =back
1884:
1.648 raeburn 1885: See loncreateuser.pm for invocation and use examples.
1.157 matthew 1886:
1.35 matthew 1887: =cut
1888:
1889: #-------------------------------------------
1.32 matthew 1890: sub authform_header{
1891: my %in = (
1892: formname => 'cu',
1.80 albertel 1893: kerb_def_dom => '',
1.32 matthew 1894: @_,
1895: );
1896: $in{'formname'} = 'document.' . $in{'formname'};
1897: my $result='';
1.80 albertel 1898:
1899: #---------------------------------------------- Code for upper case translation
1900: my $Javascript_toUpperCase;
1901: unless ($in{kerb_def_dom}) {
1902: $Javascript_toUpperCase =<<"END";
1903: switch (choice) {
1904: case 'krb': currentform.elements[choicearg].value =
1905: currentform.elements[choicearg].value.toUpperCase();
1906: break;
1907: default:
1908: }
1909: END
1910: } else {
1911: $Javascript_toUpperCase = "";
1912: }
1913:
1.165 raeburn 1914: my $radioval = "'nochange'";
1.591 raeburn 1915: if (defined($in{'curr_authtype'})) {
1916: if ($in{'curr_authtype'} ne '') {
1917: $radioval = "'".$in{'curr_authtype'}."arg'";
1918: }
1.174 matthew 1919: }
1.165 raeburn 1920: my $argfield = 'null';
1.591 raeburn 1921: if (defined($in{'mode'})) {
1.165 raeburn 1922: if ($in{'mode'} eq 'modifycourse') {
1.591 raeburn 1923: if (defined($in{'curr_autharg'})) {
1924: if ($in{'curr_autharg'} ne '') {
1.165 raeburn 1925: $argfield = "'$in{'curr_autharg'}'";
1926: }
1927: }
1928: }
1929: }
1930:
1.32 matthew 1931: $result.=<<"END";
1932: var current = new Object();
1.165 raeburn 1933: current.radiovalue = $radioval;
1934: current.argfield = $argfield;
1.32 matthew 1935:
1936: function changed_radio(choice,currentform) {
1937: var choicearg = choice + 'arg';
1938: // If a radio button in changed, we need to change the argfield
1939: if (current.radiovalue != choice) {
1940: current.radiovalue = choice;
1941: if (current.argfield != null) {
1942: currentform.elements[current.argfield].value = '';
1943: }
1944: if (choice == 'nochange') {
1945: current.argfield = null;
1946: } else {
1947: current.argfield = choicearg;
1948: switch(choice) {
1949: case 'krb':
1950: currentform.elements[current.argfield].value =
1951: "$in{'kerb_def_dom'}";
1952: break;
1953: default:
1954: break;
1955: }
1956: }
1957: }
1958: return;
1959: }
1.22 www 1960:
1.32 matthew 1961: function changed_text(choice,currentform) {
1962: var choicearg = choice + 'arg';
1963: if (currentform.elements[choicearg].value !='') {
1.80 albertel 1964: $Javascript_toUpperCase
1.32 matthew 1965: // clear old field
1966: if ((current.argfield != choicearg) && (current.argfield != null)) {
1967: currentform.elements[current.argfield].value = '';
1968: }
1969: current.argfield = choicearg;
1970: }
1971: set_auth_radio_buttons(choice,currentform);
1972: return;
1.20 www 1973: }
1.32 matthew 1974:
1975: function set_auth_radio_buttons(newvalue,currentform) {
1976: var i=0;
1977: while (i < currentform.login.length) {
1978: if (currentform.login[i].value == newvalue) { break; }
1979: i++;
1980: }
1981: if (i == currentform.login.length) {
1982: return;
1983: }
1984: current.radiovalue = newvalue;
1985: currentform.login[i].checked = true;
1986: return;
1987: }
1988: END
1989: return $result;
1990: }
1991:
1992: sub authform_authorwarning{
1993: my $result='';
1.144 matthew 1994: $result='<i>'.
1995: &mt('As a general rule, only authors or co-authors should be '.
1996: 'filesystem authenticated '.
1997: '(which allows access to the server filesystem).')."</i>\n";
1.32 matthew 1998: return $result;
1999: }
2000:
2001: sub authform_nochange{
2002: my %in = (
2003: formname => 'document.cu',
2004: kerb_def_dom => 'MSU.EDU',
2005: @_,
2006: );
1.586 raeburn 2007: my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'});
2008: my $result;
2009: if (keys(%can_assign) == 0) {
2010: $result = &mt('Under you current role you are not permitted to change login settings for this user');
2011: } else {
2012: $result = '<label>'.&mt('[_1] Do not change login data',
2013: '<input type="radio" name="login" value="nochange" '.
2014: 'checked="checked" onclick="'.
1.281 albertel 2015: "javascript:changed_radio('nochange',$in{'formname'});".'" />').
2016: '</label>';
1.586 raeburn 2017: }
1.32 matthew 2018: return $result;
2019: }
2020:
1.591 raeburn 2021: sub authform_kerberos {
1.32 matthew 2022: my %in = (
2023: formname => 'document.cu',
2024: kerb_def_dom => 'MSU.EDU',
1.80 albertel 2025: kerb_def_auth => 'krb4',
1.32 matthew 2026: @_,
2027: );
1.586 raeburn 2028: my ($check4,$check5,$krbcheck,$krbarg,$krbver,$result,$authtype,
2029: $autharg,$jscall);
2030: my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'});
1.80 albertel 2031: if ($in{'kerb_def_auth'} eq 'krb5') {
1.586 raeburn 2032: $check5 = ' checked="on"';
1.80 albertel 2033: } else {
1.586 raeburn 2034: $check4 = ' checked="on"';
1.80 albertel 2035: }
1.165 raeburn 2036: $krbarg = $in{'kerb_def_dom'};
1.591 raeburn 2037: if (defined($in{'curr_authtype'})) {
2038: if ($in{'curr_authtype'} eq 'krb') {
1.586 raeburn 2039: $krbcheck = ' checked="on"';
1.623 raeburn 2040: if (defined($in{'mode'})) {
2041: if ($in{'mode'} eq 'modifyuser') {
2042: $krbcheck = '';
2043: }
2044: }
1.591 raeburn 2045: if (defined($in{'curr_kerb_ver'})) {
2046: if ($in{'curr_krb_ver'} eq '5') {
2047: $check5 = ' checked="on"';
2048: $check4 = '';
2049: } else {
2050: $check4 = ' checked="on"';
2051: $check5 = '';
2052: }
1.586 raeburn 2053: }
1.591 raeburn 2054: if (defined($in{'curr_autharg'})) {
1.165 raeburn 2055: $krbarg = $in{'curr_autharg'};
2056: }
1.586 raeburn 2057: if (!$can_assign{'krb4'} && !$can_assign{'krb5'}) {
1.591 raeburn 2058: if (defined($in{'curr_autharg'})) {
1.586 raeburn 2059: $result =
2060: &mt('Currently Kerberos authenticated with domain [_1] Version [_2].',
2061: $in{'curr_autharg'},$krbver);
2062: } else {
2063: $result =
2064: &mt('Currently Kerberos authenticated, Version [_1].',$krbver);
2065: }
2066: return $result;
2067: }
2068: }
2069: } else {
2070: if ($authnum == 1) {
2071: $authtype = '<input type="hidden" name="login" value="krb">';
1.165 raeburn 2072: }
2073: }
1.586 raeburn 2074: if (!$can_assign{'krb4'} && !$can_assign{'krb5'}) {
2075: return;
1.587 raeburn 2076: } elsif ($authtype eq '') {
1.591 raeburn 2077: if (defined($in{'mode'})) {
1.587 raeburn 2078: if ($in{'mode'} eq 'modifycourse') {
2079: if ($authnum == 1) {
2080: $authtype = '<input type="hidden" name="login" value="krb">';
2081: }
2082: }
2083: }
1.586 raeburn 2084: }
2085: $jscall = "javascript:changed_radio('krb',$in{'formname'});";
2086: if ($authtype eq '') {
2087: $authtype = '<input type="radio" name="login" value="krb" '.
2088: 'onclick="'.$jscall.'" onchange="'.$jscall.'"'.
2089: $krbcheck.' />';
2090: }
2091: if (($can_assign{'krb4'} && $can_assign{'krb5'}) ||
2092: ($can_assign{'krb4'} && !$can_assign{'krb5'} &&
2093: $in{'curr_authtype'} eq 'krb5') ||
2094: (!$can_assign{'krb4'} && $can_assign{'krb5'} &&
2095: $in{'curr_authtype'} eq 'krb4')) {
2096: $result .= &mt
1.144 matthew 2097: ('[_1] Kerberos authenticated with domain [_2] '.
1.281 albertel 2098: '[_3] Version 4 [_4] Version 5 [_5]',
1.586 raeburn 2099: '<label>'.$authtype,
1.281 albertel 2100: '</label><input type="text" size="10" name="krbarg" '.
1.165 raeburn 2101: 'value="'.$krbarg.'" '.
1.144 matthew 2102: 'onchange="'.$jscall.'" />',
1.281 albertel 2103: '<label><input type="radio" name="krbver" value="4" '.$check4.' />',
2104: '</label><label><input type="radio" name="krbver" value="5" '.$check5.' />',
2105: '</label>');
1.586 raeburn 2106: } elsif ($can_assign{'krb4'}) {
2107: $result .= &mt
2108: ('[_1] Kerberos authenticated with domain [_2] '.
2109: '[_3] Version 4 [_4]',
2110: '<label>'.$authtype,
2111: '</label><input type="text" size="10" name="krbarg" '.
2112: 'value="'.$krbarg.'" '.
2113: 'onchange="'.$jscall.'" />',
2114: '<label><input type="hidden" name="krbver" value="4" />',
2115: '</label>');
2116: } elsif ($can_assign{'krb5'}) {
2117: $result .= &mt
2118: ('[_1] Kerberos authenticated with domain [_2] '.
2119: '[_3] Version 5 [_4]',
2120: '<label>'.$authtype,
2121: '</label><input type="text" size="10" name="krbarg" '.
2122: 'value="'.$krbarg.'" '.
2123: 'onchange="'.$jscall.'" />',
2124: '<label><input type="hidden" name="krbver" value="5" />',
2125: '</label>');
2126: }
1.32 matthew 2127: return $result;
2128: }
2129:
2130: sub authform_internal{
1.586 raeburn 2131: my %in = (
1.32 matthew 2132: formname => 'document.cu',
2133: kerb_def_dom => 'MSU.EDU',
2134: @_,
2135: );
1.586 raeburn 2136: my ($intcheck,$intarg,$result,$authtype,$autharg,$jscall);
2137: my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'});
1.591 raeburn 2138: if (defined($in{'curr_authtype'})) {
2139: if ($in{'curr_authtype'} eq 'int') {
1.586 raeburn 2140: if ($can_assign{'int'}) {
2141: $intcheck = 'checked="on" ';
1.623 raeburn 2142: if (defined($in{'mode'})) {
2143: if ($in{'mode'} eq 'modifyuser') {
2144: $intcheck = '';
2145: }
2146: }
1.591 raeburn 2147: if (defined($in{'curr_autharg'})) {
1.586 raeburn 2148: $intarg = $in{'curr_autharg'};
2149: }
2150: } else {
2151: $result = &mt('Currently internally authenticated.');
2152: return $result;
1.165 raeburn 2153: }
2154: }
1.586 raeburn 2155: } else {
2156: if ($authnum == 1) {
2157: $authtype = '<input type="hidden" name="login" value="int">';
2158: }
2159: }
2160: if (!$can_assign{'int'}) {
2161: return;
1.587 raeburn 2162: } elsif ($authtype eq '') {
1.591 raeburn 2163: if (defined($in{'mode'})) {
1.587 raeburn 2164: if ($in{'mode'} eq 'modifycourse') {
2165: if ($authnum == 1) {
2166: $authtype = '<input type="hidden" name="login" value="int">';
2167: }
2168: }
2169: }
1.165 raeburn 2170: }
1.586 raeburn 2171: $jscall = "javascript:changed_radio('int',$in{'formname'});";
2172: if ($authtype eq '') {
2173: $authtype = '<input type="radio" name="login" value="int" '.$intcheck.
2174: ' onchange="'.$jscall.'" onclick="'.$jscall.'" />';
2175: }
1.605 bisitz 2176: $autharg = '<input type="password" size="10" name="intarg" value="'.
1.586 raeburn 2177: $intarg.'" onchange="'.$jscall.'" />';
2178: $result = &mt
1.144 matthew 2179: ('[_1] Internally authenticated (with initial password [_2])',
1.586 raeburn 2180: '<label>'.$authtype,'</label>'.$autharg);
1.620 www 2181: $result.="<label><input type=\"checkbox\" name=\"visible\" onClick='if (this.checked) { this.form.intarg.type=\"text\" } else { this.form.intarg.type=\"password\" }' />".&mt('Visible input').'</label>';
1.32 matthew 2182: return $result;
2183: }
2184:
2185: sub authform_local{
2186: my %in = (
2187: formname => 'document.cu',
2188: kerb_def_dom => 'MSU.EDU',
2189: @_,
2190: );
1.586 raeburn 2191: my ($loccheck,$locarg,$result,$authtype,$autharg,$jscall);
2192: my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'});
1.591 raeburn 2193: if (defined($in{'curr_authtype'})) {
2194: if ($in{'curr_authtype'} eq 'loc') {
1.586 raeburn 2195: if ($can_assign{'loc'}) {
2196: $loccheck = 'checked="on" ';
1.623 raeburn 2197: if (defined($in{'mode'})) {
2198: if ($in{'mode'} eq 'modifyuser') {
2199: $loccheck = '';
2200: }
2201: }
1.591 raeburn 2202: if (defined($in{'curr_autharg'})) {
1.586 raeburn 2203: $locarg = $in{'curr_autharg'};
2204: }
2205: } else {
2206: $result = &mt('Currently using local (institutional) authentication.');
2207: return $result;
1.165 raeburn 2208: }
2209: }
1.586 raeburn 2210: } else {
2211: if ($authnum == 1) {
2212: $authtype = '<input type="hidden" name="login" value="loc">';
2213: }
2214: }
2215: if (!$can_assign{'loc'}) {
2216: return;
1.587 raeburn 2217: } elsif ($authtype eq '') {
1.591 raeburn 2218: if (defined($in{'mode'})) {
1.587 raeburn 2219: if ($in{'mode'} eq 'modifycourse') {
2220: if ($authnum == 1) {
2221: $authtype = '<input type="hidden" name="login" value="loc">';
2222: }
2223: }
2224: }
1.165 raeburn 2225: }
1.586 raeburn 2226: $jscall = "javascript:changed_radio('loc',$in{'formname'});";
2227: if ($authtype eq '') {
2228: $authtype = '<input type="radio" name="login" value="loc" '.
2229: $loccheck.' onchange="'.$jscall.'" onclick="'.
2230: $jscall.'" />';
2231: }
2232: $autharg = '<input type="text" size="10" name="locarg" value="'.
2233: $locarg.'" onchange="'.$jscall.'" />';
2234: $result = &mt('[_1] Local Authentication with argument [_2]',
2235: '<label>'.$authtype,'</label>'.$autharg);
1.32 matthew 2236: return $result;
2237: }
2238:
2239: sub authform_filesystem{
2240: my %in = (
2241: formname => 'document.cu',
2242: kerb_def_dom => 'MSU.EDU',
2243: @_,
2244: );
1.586 raeburn 2245: my ($fsyscheck,$result,$authtype,$autharg,$jscall);
2246: my ($authnum,%can_assign) = &get_assignable_auth($in{'domain'});
1.591 raeburn 2247: if (defined($in{'curr_authtype'})) {
2248: if ($in{'curr_authtype'} eq 'fsys') {
1.586 raeburn 2249: if ($can_assign{'fsys'}) {
2250: $fsyscheck = 'checked="on" ';
1.623 raeburn 2251: if (defined($in{'mode'})) {
2252: if ($in{'mode'} eq 'modifyuser') {
2253: $fsyscheck = '';
2254: }
2255: }
1.586 raeburn 2256: } else {
2257: $result = &mt('Currently Filesystem Authenticated.');
2258: return $result;
2259: }
2260: }
2261: } else {
2262: if ($authnum == 1) {
2263: $authtype = '<input type="hidden" name="login" value="fsys">';
2264: }
2265: }
2266: if (!$can_assign{'fsys'}) {
2267: return;
1.587 raeburn 2268: } elsif ($authtype eq '') {
1.591 raeburn 2269: if (defined($in{'mode'})) {
1.587 raeburn 2270: if ($in{'mode'} eq 'modifycourse') {
2271: if ($authnum == 1) {
2272: $authtype = '<input type="hidden" name="login" value="fsys">';
2273: }
2274: }
2275: }
1.586 raeburn 2276: }
2277: $jscall = "javascript:changed_radio('fsys',$in{'formname'});";
2278: if ($authtype eq '') {
2279: $authtype = '<input type="radio" name="login" value="fsys" '.
2280: $fsyscheck.' onchange="'.$jscall.'" onclick="'.
2281: $jscall.'" />';
2282: }
2283: $autharg = '<input type="text" size="10" name="fsysarg" value=""'.
2284: ' onchange="'.$jscall.'" />';
2285: $result = &mt
1.144 matthew 2286: ('[_1] Filesystem Authenticated (with initial password [_2])',
1.281 albertel 2287: '<label><input type="radio" name="login" value="fsys" '.
1.586 raeburn 2288: $fsyscheck.'onchange="'.$jscall.'" onclick="'.$jscall.'" />',
1.605 bisitz 2289: '</label><input type="password" size="10" name="fsysarg" value="" '.
1.144 matthew 2290: 'onchange="'.$jscall.'" />');
1.32 matthew 2291: return $result;
2292: }
2293:
1.586 raeburn 2294: sub get_assignable_auth {
2295: my ($dom) = @_;
2296: if ($dom eq '') {
2297: $dom = $env{'request.role.domain'};
2298: }
2299: my %can_assign = (
2300: krb4 => 1,
2301: krb5 => 1,
2302: int => 1,
2303: loc => 1,
2304: );
2305: my %domconfig = &Apache::lonnet::get_dom('configuration',['usercreation'],$dom);
2306: if (ref($domconfig{'usercreation'}) eq 'HASH') {
2307: if (ref($domconfig{'usercreation'}{'authtypes'}) eq 'HASH') {
2308: my $authhash = $domconfig{'usercreation'}{'authtypes'};
2309: my $context;
2310: if ($env{'request.role'} =~ /^au/) {
2311: $context = 'author';
2312: } elsif ($env{'request.role'} =~ /^dc/) {
2313: $context = 'domain';
2314: } elsif ($env{'request.course.id'}) {
2315: $context = 'course';
2316: }
2317: if ($context) {
2318: if (ref($authhash->{$context}) eq 'HASH') {
2319: %can_assign = %{$authhash->{$context}};
2320: }
2321: }
2322: }
2323: }
2324: my $authnum = 0;
2325: foreach my $key (keys(%can_assign)) {
2326: if ($can_assign{$key}) {
2327: $authnum ++;
2328: }
2329: }
2330: if ($can_assign{'krb4'} && $can_assign{'krb5'}) {
2331: $authnum --;
2332: }
2333: return ($authnum,%can_assign);
2334: }
2335:
1.80 albertel 2336: ###############################################################
2337: ## Get Kerberos Defaults for Domain ##
2338: ###############################################################
2339: ##
2340: ## Returns default kerberos version and an associated argument
2341: ## as listed in file domain.tab. If not listed, provides
2342: ## appropriate default domain and kerberos version.
2343: ##
2344: #-------------------------------------------
2345:
2346: =pod
2347:
1.648 raeburn 2348: =item * &get_kerberos_defaults()
1.80 albertel 2349:
2350: get_kerberos_defaults($target_domain) returns the default kerberos
1.641 raeburn 2351: version and domain. If not found, it defaults to version 4 and the
2352: domain of the server.
1.80 albertel 2353:
1.648 raeburn 2354: =over 4
2355:
1.80 albertel 2356: ($def_version, $def_krb_domain) = &get_kerberos_defaults($target_domain);
2357:
1.648 raeburn 2358: =back
2359:
2360: =back
2361:
1.80 albertel 2362: =cut
2363:
2364: #-------------------------------------------
2365: sub get_kerberos_defaults {
2366: my $domain=shift;
1.641 raeburn 2367: my ($krbdef,$krbdefdom);
2368: my %domdefaults = &Apache::lonnet::get_domain_defaults($domain);
2369: if (($domdefaults{'auth_def'} =~/^krb(4|5)$/) && ($domdefaults{'auth_arg_def'} ne '')) {
2370: $krbdef = $domdefaults{'auth_def'};
2371: $krbdefdom = $domdefaults{'auth_arg_def'};
2372: } else {
1.80 albertel 2373: $ENV{'SERVER_NAME'}=~/(\w+\.\w+)$/;
2374: my $krbdefdom=$1;
2375: $krbdefdom=~tr/a-z/A-Z/;
2376: $krbdef = "krb4";
2377: }
2378: return ($krbdef,$krbdefdom);
2379: }
1.112 bowersj2 2380:
1.32 matthew 2381:
1.46 matthew 2382: ###############################################################
2383: ## Thesaurus Functions ##
2384: ###############################################################
1.20 www 2385:
1.46 matthew 2386: =pod
1.20 www 2387:
1.112 bowersj2 2388: =head1 Thesaurus Functions
2389:
2390: =over 4
2391:
1.648 raeburn 2392: =item * &initialize_keywords()
1.46 matthew 2393:
2394: Initializes the package variable %Keywords if it is empty. Uses the
2395: package variable $thesaurus_db_file.
2396:
2397: =cut
2398:
2399: ###################################################
2400:
2401: sub initialize_keywords {
2402: return 1 if (scalar keys(%Keywords));
2403: # If we are here, %Keywords is empty, so fill it up
2404: # Make sure the file we need exists...
2405: if (! -e $thesaurus_db_file) {
2406: &Apache::lonnet::logthis("Attempt to access $thesaurus_db_file".
2407: " failed because it does not exist");
2408: return 0;
2409: }
2410: # Set up the hash as a database
2411: my %thesaurus_db;
2412: if (! tie(%thesaurus_db,'GDBM_File',
1.53 albertel 2413: $thesaurus_db_file,&GDBM_READER(),0640)){
1.46 matthew 2414: &Apache::lonnet::logthis("Could not tie \%thesaurus_db to ".
2415: $thesaurus_db_file);
2416: return 0;
2417: }
2418: # Get the average number of appearances of a word.
2419: my $avecount = $thesaurus_db{'average.count'};
2420: # Put keywords (those that appear > average) into %Keywords
2421: while (my ($word,$data)=each (%thesaurus_db)) {
2422: my ($count,undef) = split /:/,$data;
2423: $Keywords{$word}++ if ($count > $avecount);
2424: }
2425: untie %thesaurus_db;
2426: # Remove special values from %Keywords.
1.356 albertel 2427: foreach my $value ('total.count','average.count') {
2428: delete($Keywords{$value}) if (exists($Keywords{$value}));
1.586 raeburn 2429: }
1.46 matthew 2430: return 1;
2431: }
2432:
2433: ###################################################
2434:
2435: =pod
2436:
1.648 raeburn 2437: =item * &keyword($word)
1.46 matthew 2438:
2439: Returns true if $word is a keyword. A keyword is a word that appears more
2440: than the average number of times in the thesaurus database. Calls
2441: &initialize_keywords
2442:
2443: =cut
2444:
2445: ###################################################
1.20 www 2446:
2447: sub keyword {
1.46 matthew 2448: return if (!&initialize_keywords());
2449: my $word=lc(shift());
2450: $word=~s/\W//g;
2451: return exists($Keywords{$word});
1.20 www 2452: }
1.46 matthew 2453:
2454: ###############################################################
2455:
2456: =pod
1.20 www 2457:
1.648 raeburn 2458: =item * &get_related_words()
1.46 matthew 2459:
1.160 matthew 2460: Look up a word in the thesaurus. Takes a scalar argument and returns
1.46 matthew 2461: an array of words. If the keyword is not in the thesaurus, an empty array
2462: will be returned. The order of the words returned is determined by the
2463: database which holds them.
2464:
2465: Uses global $thesaurus_db_file.
2466:
2467: =cut
2468:
2469: ###############################################################
2470: sub get_related_words {
2471: my $keyword = shift;
2472: my %thesaurus_db;
2473: if (! -e $thesaurus_db_file) {
2474: &Apache::lonnet::logthis("Attempt to access $thesaurus_db_file ".
2475: "failed because the file does not exist");
2476: return ();
2477: }
2478: if (! tie(%thesaurus_db,'GDBM_File',
1.53 albertel 2479: $thesaurus_db_file,&GDBM_READER(),0640)){
1.46 matthew 2480: return ();
2481: }
2482: my @Words=();
1.429 www 2483: my $count=0;
1.46 matthew 2484: if (exists($thesaurus_db{$keyword})) {
1.356 albertel 2485: # The first element is the number of times
2486: # the word appears. We do not need it now.
1.429 www 2487: my (undef,@RelatedWords) = (split(/:/,$thesaurus_db{$keyword}));
2488: my (undef,$mostfrequentcount)=split(/\,/,$RelatedWords[0]);
2489: my $threshold=$mostfrequentcount/10;
2490: foreach my $possibleword (@RelatedWords) {
2491: my ($word,$wordcount)=split(/\,/,$possibleword);
2492: if ($wordcount>$threshold) {
2493: push(@Words,$word);
2494: $count++;
2495: if ($count>10) { last; }
2496: }
1.20 www 2497: }
2498: }
1.46 matthew 2499: untie %thesaurus_db;
2500: return @Words;
1.14 harris41 2501: }
1.46 matthew 2502:
1.112 bowersj2 2503: =pod
2504:
2505: =back
2506:
2507: =cut
1.61 www 2508:
2509: # -------------------------------------------------------------- Plaintext name
1.81 albertel 2510: =pod
2511:
1.112 bowersj2 2512: =head1 User Name Functions
2513:
2514: =over 4
2515:
1.648 raeburn 2516: =item * &plainname($uname,$udom,$first)
1.81 albertel 2517:
1.112 bowersj2 2518: Takes a users logon name and returns it as a string in
1.226 albertel 2519: "first middle last generation" form
2520: if $first is set to 'lastname' then it returns it as
2521: 'lastname generation, firstname middlename' if their is a lastname
1.81 albertel 2522:
2523: =cut
1.61 www 2524:
1.295 www 2525:
1.81 albertel 2526: ###############################################################
1.61 www 2527: sub plainname {
1.226 albertel 2528: my ($uname,$udom,$first)=@_;
1.537 albertel 2529: return if (!defined($uname) || !defined($udom));
1.295 www 2530: my %names=&getnames($uname,$udom);
1.226 albertel 2531: my $name=&Apache::lonnet::format_name($names{'firstname'},
2532: $names{'middlename'},
2533: $names{'lastname'},
2534: $names{'generation'},$first);
2535: $name=~s/^\s+//;
1.62 www 2536: $name=~s/\s+$//;
2537: $name=~s/\s+/ /g;
1.353 albertel 2538: if ($name !~ /\S/) { $name=$uname.':'.$udom; }
1.62 www 2539: return $name;
1.61 www 2540: }
1.66 www 2541:
2542: # -------------------------------------------------------------------- Nickname
1.81 albertel 2543: =pod
2544:
1.648 raeburn 2545: =item * &nickname($uname,$udom)
1.81 albertel 2546:
2547: Gets a users name and returns it as a string as
2548:
2549: ""nickname""
1.66 www 2550:
1.81 albertel 2551: if the user has a nickname or
2552:
2553: "first middle last generation"
2554:
2555: if the user does not
2556:
2557: =cut
1.66 www 2558:
2559: sub nickname {
2560: my ($uname,$udom)=@_;
1.537 albertel 2561: return if (!defined($uname) || !defined($udom));
1.295 www 2562: my %names=&getnames($uname,$udom);
1.68 albertel 2563: my $name=$names{'nickname'};
1.66 www 2564: if ($name) {
2565: $name='"'.$name.'"';
2566: } else {
2567: $name=$names{'firstname'}.' '.$names{'middlename'}.' '.
2568: $names{'lastname'}.' '.$names{'generation'};
2569: $name=~s/\s+$//;
2570: $name=~s/\s+/ /g;
2571: }
2572: return $name;
2573: }
2574:
1.295 www 2575: sub getnames {
2576: my ($uname,$udom)=@_;
1.537 albertel 2577: return if (!defined($uname) || !defined($udom));
1.433 albertel 2578: if ($udom eq 'public' && $uname eq 'public') {
2579: return ('lastname' => &mt('Public'));
2580: }
1.295 www 2581: my $id=$uname.':'.$udom;
2582: my ($names,$cached)=&Apache::lonnet::is_cached_new('namescache',$id);
2583: if ($cached) {
2584: return %{$names};
2585: } else {
2586: my %loadnames=&Apache::lonnet::get('environment',
2587: ['firstname','middlename','lastname','generation','nickname'],
2588: $udom,$uname);
2589: &Apache::lonnet::do_cache_new('namescache',$id,\%loadnames);
2590: return %loadnames;
2591: }
2592: }
1.61 www 2593:
1.542 raeburn 2594: # -------------------------------------------------------------------- getemails
1.648 raeburn 2595:
1.542 raeburn 2596: =pod
2597:
1.648 raeburn 2598: =item * &getemails($uname,$udom)
1.542 raeburn 2599:
2600: Gets a user's email information and returns it as a hash with keys:
2601: notification, critnotification, permanentemail
2602:
2603: For notification and critnotification, values are comma-separated lists
1.648 raeburn 2604: of e-mail addresses; for permanentemail, value is a single e-mail address.
1.542 raeburn 2605:
1.648 raeburn 2606:
1.542 raeburn 2607: =cut
2608:
1.648 raeburn 2609:
1.466 albertel 2610: sub getemails {
2611: my ($uname,$udom)=@_;
2612: if ($udom eq 'public' && $uname eq 'public') {
2613: return;
2614: }
1.467 www 2615: if (!$udom) { $udom=$env{'user.domain'}; }
2616: if (!$uname) { $uname=$env{'user.name'}; }
1.466 albertel 2617: my $id=$uname.':'.$udom;
2618: my ($names,$cached)=&Apache::lonnet::is_cached_new('emailscache',$id);
2619: if ($cached) {
2620: return %{$names};
2621: } else {
2622: my %loadnames=&Apache::lonnet::get('environment',
2623: ['notification','critnotification',
2624: 'permanentemail'],
2625: $udom,$uname);
2626: &Apache::lonnet::do_cache_new('emailscache',$id,\%loadnames);
2627: return %loadnames;
2628: }
2629: }
2630:
1.551 albertel 2631: sub flush_email_cache {
2632: my ($uname,$udom)=@_;
2633: if (!$udom) { $udom =$env{'user.domain'}; }
2634: if (!$uname) { $uname=$env{'user.name'}; }
2635: return if ($udom eq 'public' && $uname eq 'public');
2636: my $id=$uname.':'.$udom;
2637: &Apache::lonnet::devalidate_cache_new('emailscache',$id);
2638: }
2639:
1.61 www 2640: # ------------------------------------------------------------------ Screenname
1.81 albertel 2641:
2642: =pod
2643:
1.648 raeburn 2644: =item * &screenname($uname,$udom)
1.81 albertel 2645:
2646: Gets a users screenname and returns it as a string
2647:
2648: =cut
1.61 www 2649:
2650: sub screenname {
2651: my ($uname,$udom)=@_;
1.258 albertel 2652: if ($uname eq $env{'user.name'} &&
2653: $udom eq $env{'user.domain'}) {return $env{'environment.screenname'};}
1.212 albertel 2654: my %names=&Apache::lonnet::get('environment',['screenname'],$udom,$uname);
1.68 albertel 2655: return $names{'screenname'};
1.62 www 2656: }
2657:
1.212 albertel 2658:
1.62 www 2659: # ------------------------------------------------------------- Message Wrapper
2660:
2661: sub messagewrapper {
1.369 www 2662: my ($link,$username,$domain,$subject,$text)=@_;
1.62 www 2663: return
1.441 albertel 2664: '<a href="/adm/email?compose=individual&'.
2665: 'recname='.$username.'&recdom='.$domain.
2666: '&subject='.&escape($subject).'&text='.&escape($text).'" '.
1.200 matthew 2667: 'title="'.&mt('Send message').'">'.$link.'</a>';
1.74 www 2668: }
2669: # --------------------------------------------------------------- Notes Wrapper
2670:
2671: sub noteswrapper {
2672: my ($link,$un,$do)=@_;
2673: return
2674: "<a href='/adm/email?recordftf=retrieve&recname=$un&recdom=$do'>$link</a>";
1.62 www 2675: }
2676: # ------------------------------------------------------------- Aboutme Wrapper
2677:
2678: sub aboutmewrapper {
1.166 www 2679: my ($link,$username,$domain,$target)=@_;
1.447 raeburn 2680: if (!defined($username) && !defined($domain)) {
2681: return;
2682: }
1.205 www 2683: return '<a href="/adm/'.$domain.'/'.$username.'/aboutme"'.
1.454 banghart 2684: ($target?' target="$target"':'').' title="'.&mt("View this user's personal page").'">'.$link.'</a>';
1.62 www 2685: }
2686:
2687: # ------------------------------------------------------------ Syllabus Wrapper
2688:
2689:
2690: sub syllabuswrapper {
1.109 matthew 2691: my ($linktext,$coursedir,$domain,$fontcolor)=@_;
2692: if ($fontcolor) {
2693: $linktext='<font color="'.$fontcolor.'">'.$linktext.'</font>';
2694: }
1.208 matthew 2695: return qq{<a href="/public/$domain/$coursedir/syllabus">$linktext</a>};
1.61 www 2696: }
1.14 harris41 2697:
1.208 matthew 2698: sub track_student_link {
1.268 albertel 2699: my ($linktext,$sname,$sdom,$target,$start) = @_;
2700: my $link ="/adm/trackstudent?";
1.208 matthew 2701: my $title = 'View recent activity';
2702: if (defined($sname) && $sname !~ /^\s*$/ &&
2703: defined($sdom) && $sdom !~ /^\s*$/) {
1.268 albertel 2704: $link .= "selected_student=$sname:$sdom";
1.208 matthew 2705: $title .= ' of this student';
1.268 albertel 2706: }
1.208 matthew 2707: if (defined($target) && $target !~ /^\s*$/) {
2708: $target = qq{target="$target"};
2709: } else {
2710: $target = '';
2711: }
1.268 albertel 2712: if ($start) { $link.='&start='.$start; }
1.554 albertel 2713: $title = &mt($title);
2714: $linktext = &mt($linktext);
1.448 albertel 2715: return qq{<a href="$link" title="$title" $target>$linktext</a>}.
2716: &help_open_topic('View_recent_activity');
1.208 matthew 2717: }
2718:
1.508 www 2719: # ===================================================== Display a student photo
2720:
2721:
1.509 albertel 2722: sub student_image_tag {
1.508 www 2723: my ($domain,$user)=@_;
2724: my $imgsrc=&Apache::lonnet::studentphoto($domain,$user,'jpg');
2725: if (($imgsrc) && ($imgsrc ne '/adm/lonKaputt/lonlogo_broken.gif')) {
2726: return '<img src="'.$imgsrc.'" align="right" />';
2727: } else {
2728: return '';
2729: }
2730: }
2731:
1.112 bowersj2 2732: =pod
2733:
2734: =back
2735:
2736: =head1 Access .tab File Data
2737:
2738: =over 4
2739:
1.648 raeburn 2740: =item * &languageids()
1.112 bowersj2 2741:
2742: returns list of all language ids
2743:
2744: =cut
2745:
1.14 harris41 2746: sub languageids {
1.16 harris41 2747: return sort(keys(%language));
1.14 harris41 2748: }
2749:
1.112 bowersj2 2750: =pod
2751:
1.648 raeburn 2752: =item * &languagedescription()
1.112 bowersj2 2753:
2754: returns description of a specified language id
2755:
2756: =cut
2757:
1.14 harris41 2758: sub languagedescription {
1.125 www 2759: my $code=shift;
2760: return ($supported_language{$code}?'* ':'').
2761: $language{$code}.
1.126 www 2762: ($supported_language{$code}?' ('.&mt('interface available').')':'');
1.145 www 2763: }
2764:
2765: sub plainlanguagedescription {
2766: my $code=shift;
2767: return $language{$code};
2768: }
2769:
2770: sub supportedlanguagecode {
2771: my $code=shift;
2772: return $supported_language{$code};
1.97 www 2773: }
2774:
1.112 bowersj2 2775: =pod
2776:
1.648 raeburn 2777: =item * ©rightids()
1.112 bowersj2 2778:
2779: returns list of all copyrights
2780:
2781: =cut
2782:
2783: sub copyrightids {
2784: return sort(keys(%cprtag));
2785: }
2786:
2787: =pod
2788:
1.648 raeburn 2789: =item * ©rightdescription()
1.112 bowersj2 2790:
2791: returns description of a specified copyright id
2792:
2793: =cut
2794:
2795: sub copyrightdescription {
1.166 www 2796: return &mt($cprtag{shift(@_)});
1.112 bowersj2 2797: }
1.197 matthew 2798:
2799: =pod
2800:
1.648 raeburn 2801: =item * &source_copyrightids()
1.192 taceyjo1 2802:
2803: returns list of all source copyrights
2804:
2805: =cut
2806:
2807: sub source_copyrightids {
2808: return sort(keys(%scprtag));
2809: }
2810:
2811: =pod
2812:
1.648 raeburn 2813: =item * &source_copyrightdescription()
1.192 taceyjo1 2814:
2815: returns description of a specified source copyright id
2816:
2817: =cut
2818:
2819: sub source_copyrightdescription {
2820: return &mt($scprtag{shift(@_)});
2821: }
1.112 bowersj2 2822:
2823: =pod
2824:
1.648 raeburn 2825: =item * &filecategories()
1.112 bowersj2 2826:
2827: returns list of all file categories
2828:
2829: =cut
2830:
2831: sub filecategories {
2832: return sort(keys(%category_extensions));
2833: }
2834:
2835: =pod
2836:
1.648 raeburn 2837: =item * &filecategorytypes()
1.112 bowersj2 2838:
2839: returns list of file types belonging to a given file
2840: category
2841:
2842: =cut
2843:
2844: sub filecategorytypes {
1.356 albertel 2845: my ($cat) = @_;
2846: return @{$category_extensions{lc($cat)}};
1.112 bowersj2 2847: }
2848:
2849: =pod
2850:
1.648 raeburn 2851: =item * &fileembstyle()
1.112 bowersj2 2852:
2853: returns embedding style for a specified file type
2854:
2855: =cut
2856:
2857: sub fileembstyle {
2858: return $fe{lc(shift(@_))};
1.169 www 2859: }
2860:
1.351 www 2861: sub filemimetype {
2862: return $fm{lc(shift(@_))};
2863: }
2864:
1.169 www 2865:
2866: sub filecategoryselect {
2867: my ($name,$value)=@_;
1.189 matthew 2868: return &select_form($value,$name,
1.169 www 2869: '' => &mt('Any category'),
2870: map { $_,$_ } sort(keys(%category_extensions)));
1.112 bowersj2 2871: }
2872:
2873: =pod
2874:
1.648 raeburn 2875: =item * &filedescription()
1.112 bowersj2 2876:
2877: returns description for a specified file type
2878:
2879: =cut
2880:
2881: sub filedescription {
1.188 matthew 2882: my $file_description = $fd{lc(shift())};
2883: $file_description =~ s:([\[\]]):~$1:g;
2884: return &mt($file_description);
1.112 bowersj2 2885: }
2886:
2887: =pod
2888:
1.648 raeburn 2889: =item * &filedescriptionex()
1.112 bowersj2 2890:
2891: returns description for a specified file type with
2892: extra formatting
2893:
2894: =cut
2895:
2896: sub filedescriptionex {
2897: my $ex=shift;
1.188 matthew 2898: my $file_description = $fd{lc($ex)};
2899: $file_description =~ s:([\[\]]):~$1:g;
2900: return '.'.$ex.' '.&mt($file_description);
1.112 bowersj2 2901: }
2902:
2903: # End of .tab access
2904: =pod
2905:
2906: =back
2907:
2908: =cut
2909:
2910: # ------------------------------------------------------------------ File Types
2911: sub fileextensions {
2912: return sort(keys(%fe));
2913: }
2914:
1.97 www 2915: # ----------------------------------------------------------- Display Languages
2916: # returns a hash with all desired display languages
2917: #
2918:
2919: sub display_languages {
2920: my %languages=();
1.356 albertel 2921: foreach my $lang (&preferred_languages()) {
2922: $languages{$lang}=1;
1.97 www 2923: }
2924: &get_unprocessed_cgi($ENV{'QUERY_STRING'},['displaylanguage']);
1.258 albertel 2925: if ($env{'form.displaylanguage'}) {
1.356 albertel 2926: foreach my $lang (split(/\s*(\,|\;|\:)\s*/,$env{'form.displaylanguage'})) {
2927: $languages{$lang}=1;
1.97 www 2928: }
2929: }
2930: return %languages;
1.14 harris41 2931: }
2932:
1.117 www 2933: sub preferred_languages {
2934: my @languages=();
1.258 albertel 2935: if ($env{'course.'.$env{'request.course.id'}.'.languages'}) {
1.117 www 2936: @languages=(@languages,split(/\s*(\,|\;|\:)\s*/,
1.258 albertel 2937: $env{'course.'.$env{'request.course.id'}.'.languages'}));
1.177 www 2938: }
1.258 albertel 2939: if ($env{'environment.languages'}) {
1.459 albertel 2940: @languages=(@languages,
2941: split(/\s*(\,|\;|\:)\s*/,$env{'environment.languages'}));
1.118 www 2942: }
1.583 albertel 2943: my $browser=$ENV{'HTTP_ACCEPT_LANGUAGE'};
1.162 www 2944: if ($browser) {
1.583 albertel 2945: my @browser =
2946: map { (split(/\s*;\s*/,$_))[0] } (split(/\s*,\s*/,$browser));
2947: push(@languages,@browser);
1.162 www 2948: }
1.641 raeburn 2949:
2950: foreach my $domtype ($env{'user.domain'},$env{'request.role.domain'},
2951: $Apache::lonnet::perlvar{'lonDefDomain'}) {
2952: if ($domtype ne '') {
2953: my %domdefs = &Apache::lonnet::get_domain_defaults($domtype);
2954: if ($domdefs{'lang_def'} ne '') {
2955: push(@languages,$domdefs{'lang_def'});
2956: }
2957: }
1.118 www 2958: }
2959: # turn "en-ca" into "en-ca,en"
2960: my @genlanguages;
1.356 albertel 2961: foreach my $lang (@languages) {
2962: unless ($lang=~/\w/) { next; }
1.583 albertel 2963: push(@genlanguages,$lang);
1.356 albertel 2964: if ($lang=~/(\-|\_)/) {
2965: push(@genlanguages,(split(/(\-|\_)/,$lang))[0]);
1.118 www 2966: }
2967: }
1.583 albertel 2968: #uniqueify the languages list
2969: my %count;
2970: @genlanguages = map { $count{$_}++ == 0 ? $_ : () } @genlanguages;
1.118 www 2971: return @genlanguages;
1.117 www 2972: }
2973:
1.582 albertel 2974: sub languages {
2975: my ($possible_langs) = @_;
2976: my @preferred_langs = &preferred_languages();
2977: if (!ref($possible_langs)) {
2978: if( wantarray ) {
2979: return @preferred_langs;
2980: } else {
2981: return $preferred_langs[0];
2982: }
2983: }
2984: my %possibilities = map { $_ => 1 } (@$possible_langs);
2985: my @preferred_possibilities;
2986: foreach my $preferred_lang (@preferred_langs) {
2987: if (exists($possibilities{$preferred_lang})) {
2988: push(@preferred_possibilities, $preferred_lang);
2989: }
2990: }
2991: if( wantarray ) {
2992: return @preferred_possibilities;
2993: }
2994: return $preferred_possibilities[0];
2995: }
2996:
1.112 bowersj2 2997: ###############################################################
2998: ## Student Answer Attempts ##
2999: ###############################################################
3000:
3001: =pod
3002:
3003: =head1 Alternate Problem Views
3004:
3005: =over 4
3006:
1.648 raeburn 3007: =item * &get_previous_attempt($symb, $username, $domain, $course,
1.112 bowersj2 3008: $getattempt, $regexp, $gradesub)
3009:
3010: Return string with previous attempt on problem. Arguments:
3011:
3012: =over 4
3013:
3014: =item * $symb: Problem, including path
3015:
3016: =item * $username: username of the desired student
3017:
3018: =item * $domain: domain of the desired student
1.14 harris41 3019:
1.112 bowersj2 3020: =item * $course: Course ID
1.14 harris41 3021:
1.112 bowersj2 3022: =item * $getattempt: Leave blank for all attempts, otherwise put
3023: something
1.14 harris41 3024:
1.112 bowersj2 3025: =item * $regexp: if string matches this regexp, the string will be
3026: sent to $gradesub
1.14 harris41 3027:
1.112 bowersj2 3028: =item * $gradesub: routine that processes the string if it matches $regexp
1.14 harris41 3029:
1.112 bowersj2 3030: =back
1.14 harris41 3031:
1.112 bowersj2 3032: The output string is a table containing all desired attempts, if any.
1.16 harris41 3033:
1.112 bowersj2 3034: =cut
1.1 albertel 3035:
3036: sub get_previous_attempt {
1.43 ng 3037: my ($symb,$username,$domain,$course,$getattempt,$regexp,$gradesub)=@_;
1.1 albertel 3038: my $prevattempts='';
1.43 ng 3039: no strict 'refs';
1.1 albertel 3040: if ($symb) {
1.3 albertel 3041: my (%returnhash)=
3042: &Apache::lonnet::restore($symb,$course,$domain,$username);
1.1 albertel 3043: if ($returnhash{'version'}) {
3044: my %lasthash=();
3045: my $version;
3046: for ($version=1;$version<=$returnhash{'version'};$version++) {
1.356 albertel 3047: foreach my $key (sort(split(/\:/,$returnhash{$version.':keys'}))) {
3048: $lasthash{$key}=$returnhash{$version.':'.$key};
1.19 harris41 3049: }
1.1 albertel 3050: }
1.596 albertel 3051: $prevattempts=&start_data_table().&start_data_table_header_row();
3052: $prevattempts.='<th>'.&mt('History').'</th>';
1.356 albertel 3053: foreach my $key (sort(keys(%lasthash))) {
3054: my ($ign,@parts) = split(/\./,$key);
1.41 ng 3055: if ($#parts > 0) {
1.31 albertel 3056: my $data=$parts[-1];
3057: pop(@parts);
1.596 albertel 3058: $prevattempts.='<th>'.&mt('Part ').join('.',@parts).'<br />'.$data.' </th>';
1.31 albertel 3059: } else {
1.41 ng 3060: if ($#parts == 0) {
3061: $prevattempts.='<th>'.$parts[0].'</th>';
3062: } else {
3063: $prevattempts.='<th>'.$ign.'</th>';
3064: }
1.31 albertel 3065: }
1.16 harris41 3066: }
1.596 albertel 3067: $prevattempts.=&end_data_table_header_row();
1.40 ng 3068: if ($getattempt eq '') {
3069: for ($version=1;$version<=$returnhash{'version'};$version++) {
1.596 albertel 3070: $prevattempts.=&start_data_table_row().
3071: '<td>'.&mt('Transaction [_1]',$version).'</td>';
1.356 albertel 3072: foreach my $key (sort(keys(%lasthash))) {
1.581 albertel 3073: my $value = &format_previous_attempt_value($key,
3074: $returnhash{$version.':'.$key});
3075: $prevattempts.='<td>'.$value.' </td>';
1.40 ng 3076: }
1.596 albertel 3077: $prevattempts.=&end_data_table_row();
1.40 ng 3078: }
1.1 albertel 3079: }
1.596 albertel 3080: $prevattempts.=&start_data_table_row().'<td>'.&mt('Current').'</td>';
1.356 albertel 3081: foreach my $key (sort(keys(%lasthash))) {
1.581 albertel 3082: my $value = &format_previous_attempt_value($key,$lasthash{$key});
1.356 albertel 3083: if ($key =~/$regexp$/ && (defined &$gradesub)) {$value = &$gradesub($value)}
1.40 ng 3084: $prevattempts.='<td>'.$value.' </td>';
1.16 harris41 3085: }
1.596 albertel 3086: $prevattempts.= &end_data_table_row().&end_data_table();
1.1 albertel 3087: } else {
1.596 albertel 3088: $prevattempts=
3089: &start_data_table().&start_data_table_row().
3090: '<td>'.&mt('Nothing submitted - no attempts.').'</td>'.
3091: &end_data_table_row().&end_data_table();
1.1 albertel 3092: }
3093: } else {
1.596 albertel 3094: $prevattempts=
3095: &start_data_table().&start_data_table_row().
3096: '<td>'.&mt('No data.').'</td>'.
3097: &end_data_table_row().&end_data_table();
1.1 albertel 3098: }
1.10 albertel 3099: }
3100:
1.581 albertel 3101: sub format_previous_attempt_value {
3102: my ($key,$value) = @_;
3103: if ($key =~ /timestamp/) {
3104: $value = &Apache::lonlocal::locallocaltime($value);
3105: } elsif (ref($value) eq 'ARRAY') {
3106: $value = '('.join(', ', @{ $value }).')';
3107: } else {
3108: $value = &unescape($value);
3109: }
3110: return $value;
3111: }
3112:
3113:
1.107 albertel 3114: sub relative_to_absolute {
3115: my ($url,$output)=@_;
3116: my $parser=HTML::TokeParser->new(\$output);
3117: my $token;
3118: my $thisdir=$url;
3119: my @rlinks=();
3120: while ($token=$parser->get_token) {
3121: if ($token->[0] eq 'S') {
3122: if ($token->[1] eq 'a') {
3123: if ($token->[2]->{'href'}) {
3124: $rlinks[$#rlinks+1]=$token->[2]->{'href'};
3125: }
3126: } elsif ($token->[1] eq 'img' || $token->[1] eq 'embed' ) {
3127: $rlinks[$#rlinks+1]=$token->[2]->{'src'};
3128: } elsif ($token->[1] eq 'base') {
3129: $thisdir=$token->[2]->{'href'};
3130: }
3131: }
3132: }
3133: $thisdir=~s-/[^/]*$--;
1.356 albertel 3134: foreach my $link (@rlinks) {
3135: unless (($link=~/^http:\/\//i) ||
3136: ($link=~/^\//) ||
3137: ($link=~/^javascript:/i) ||
3138: ($link=~/^mailto:/i) ||
3139: ($link=~/^\#/)) {
3140: my $newlocation=&Apache::lonnet::hreflocation($thisdir,$link);
3141: $output=~s/(\"|\'|\=\s*)\Q$link\E(\"|\'|\s|\>)/$1$newlocation$2/;
1.107 albertel 3142: }
3143: }
3144: # -------------------------------------------------- Deal with Applet codebases
3145: $output=~s/(\<applet[^\>]+)(codebase\=[^\S\>]+)*([^\>]*)\>/$1.($2?$2:' codebase="'.$thisdir.'"').$3.'>'/gei;
3146: return $output;
3147: }
3148:
1.112 bowersj2 3149: =pod
3150:
1.648 raeburn 3151: =item * &get_student_view()
1.112 bowersj2 3152:
3153: show a snapshot of what student was looking at
3154:
3155: =cut
3156:
1.10 albertel 3157: sub get_student_view {
1.186 albertel 3158: my ($symb,$username,$domain,$courseid,$target,$moreenv) = @_;
1.114 www 3159: my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb);
1.186 albertel 3160: my (%form);
1.10 albertel 3161: my @elements=('symb','courseid','domain','username');
3162: foreach my $element (@elements) {
1.186 albertel 3163: $form{'grade_'.$element}=eval '$'.$element #'
1.10 albertel 3164: }
1.186 albertel 3165: if (defined($moreenv)) {
3166: %form=(%form,%{$moreenv});
3167: }
1.236 albertel 3168: if (defined($target)) { $form{'grade_target'} = $target; }
1.107 albertel 3169: $feedurl=&Apache::lonnet::clutter($feedurl);
1.650 www 3170: my ($userview,$response)=&Apache::lonnet::ssi_body($feedurl,%form);
1.11 albertel 3171: $userview=~s/\<body[^\>]*\>//gi;
3172: $userview=~s/\<\/body\>//gi;
3173: $userview=~s/\<html\>//gi;
3174: $userview=~s/\<\/html\>//gi;
3175: $userview=~s/\<head\>//gi;
3176: $userview=~s/\<\/head\>//gi;
3177: $userview=~s/action\s*\=/would_be_action\=/gi;
1.107 albertel 3178: $userview=&relative_to_absolute($feedurl,$userview);
1.650 www 3179: if (wantarray) {
3180: return ($userview,$response);
3181: } else {
3182: return $userview;
3183: }
3184: }
3185:
3186: sub get_student_view_with_retries {
3187: my ($symb,$retries,$username,$domain,$courseid,$target,$moreenv) = @_;
3188:
3189: my $ok = 0; # True if we got a good response.
3190: my $content;
3191: my $response;
3192:
3193: # Try to get the student_view done. within the retries count:
3194:
3195: do {
3196: ($content, $response) = &get_student_view($symb,$username,$domain,$courseid,$target,$moreenv);
3197: $ok = $response->is_success;
3198: if (!$ok) {
3199: &Apache::lonnet::logthis("Failed get_student_view_with_retries on $symb: ".$response->is_success.', '.$response->code.', '.$response->message);
3200: }
3201: $retries--;
3202: } while (!$ok && ($retries > 0));
3203:
3204: if (!$ok) {
3205: $content = ''; # On error return an empty content.
3206: }
1.651 www 3207: if (wantarray) {
3208: return ($content, $response);
3209: } else {
3210: return $content;
3211: }
1.11 albertel 3212: }
3213:
1.112 bowersj2 3214: =pod
3215:
1.648 raeburn 3216: =item * &get_student_answers()
1.112 bowersj2 3217:
3218: show a snapshot of how student was answering problem
3219:
3220: =cut
3221:
1.11 albertel 3222: sub get_student_answers {
1.100 sakharuk 3223: my ($symb,$username,$domain,$courseid,%form) = @_;
1.114 www 3224: my ($map,$id,$feedurl) = &Apache::lonnet::decode_symb($symb);
1.186 albertel 3225: my (%moreenv);
1.11 albertel 3226: my @elements=('symb','courseid','domain','username');
3227: foreach my $element (@elements) {
1.186 albertel 3228: $moreenv{'grade_'.$element}=eval '$'.$element #'
1.10 albertel 3229: }
1.186 albertel 3230: $moreenv{'grade_target'}='answer';
3231: %moreenv=(%form,%moreenv);
1.497 raeburn 3232: $feedurl = &Apache::lonnet::clutter($feedurl);
3233: my $userview=&Apache::lonnet::ssi($feedurl,%moreenv);
1.10 albertel 3234: return $userview;
1.1 albertel 3235: }
1.116 albertel 3236:
3237: =pod
3238:
3239: =item * &submlink()
3240:
1.242 albertel 3241: Inputs: $text $uname $udom $symb $target
1.116 albertel 3242:
3243: Returns: A link to grades.pm such as to see the SUBM view of a student
3244:
3245: =cut
3246:
3247: ###############################################
3248: sub submlink {
1.242 albertel 3249: my ($text,$uname,$udom,$symb,$target)=@_;
1.116 albertel 3250: if (!($uname && $udom)) {
3251: (my $cursymb, my $courseid,$udom,$uname)=
1.463 albertel 3252: &Apache::lonnet::whichuser($symb);
1.116 albertel 3253: if (!$symb) { $symb=$cursymb; }
3254: }
1.254 matthew 3255: if (!$symb) { $symb=&Apache::lonnet::symbread(); }
1.369 www 3256: $symb=&escape($symb);
1.242 albertel 3257: if ($target) { $target="target=\"$target\""; }
3258: return '<a href="/adm/grades?&command=submission&'.
3259: 'symb='.$symb.'&student='.$uname.
3260: '&userdom='.$udom.'" '.$target.'>'.$text.'</a>';
3261: }
3262: ##############################################
3263:
3264: =pod
3265:
3266: =item * &pgrdlink()
3267:
3268: Inputs: $text $uname $udom $symb $target
3269:
3270: Returns: A link to grades.pm such as to see the PGRD view of a student
3271:
3272: =cut
3273:
3274: ###############################################
3275: sub pgrdlink {
3276: my $link=&submlink(@_);
3277: $link=~s/(&command=submission)/$1&showgrading=yes/;
3278: return $link;
3279: }
3280: ##############################################
3281:
3282: =pod
3283:
3284: =item * &pprmlink()
3285:
3286: Inputs: $text $uname $udom $symb $target
3287:
3288: Returns: A link to parmset.pm such as to see the PPRM view of a
1.283 albertel 3289: student and a specific resource
1.242 albertel 3290:
3291: =cut
3292:
3293: ###############################################
3294: sub pprmlink {
3295: my ($text,$uname,$udom,$symb,$target)=@_;
3296: if (!($uname && $udom)) {
3297: (my $cursymb, my $courseid,$udom,$uname)=
1.463 albertel 3298: &Apache::lonnet::whichuser($symb);
1.242 albertel 3299: if (!$symb) { $symb=$cursymb; }
3300: }
1.254 matthew 3301: if (!$symb) { $symb=&Apache::lonnet::symbread(); }
1.369 www 3302: $symb=&escape($symb);
1.242 albertel 3303: if ($target) { $target="target=\"$target\""; }
1.595 albertel 3304: return '<a href="/adm/parmset?command=set&'.
3305: 'symb='.$symb.'&uname='.$uname.
3306: '&udom='.$udom.'" '.$target.'>'.$text.'</a>';
1.116 albertel 3307: }
3308: ##############################################
1.37 matthew 3309:
1.112 bowersj2 3310: =pod
3311:
3312: =back
3313:
3314: =cut
3315:
1.37 matthew 3316: ###############################################
1.51 www 3317:
3318:
3319: sub timehash {
3320: my @ltime=localtime(shift);
3321: return ( 'seconds' => $ltime[0],
3322: 'minutes' => $ltime[1],
3323: 'hours' => $ltime[2],
3324: 'day' => $ltime[3],
3325: 'month' => $ltime[4]+1,
3326: 'year' => $ltime[5]+1900,
3327: 'weekday' => $ltime[6],
3328: 'dayyear' => $ltime[7]+1,
3329: 'dlsav' => $ltime[8] );
3330: }
3331:
1.370 www 3332: sub utc_string {
3333: my ($date)=@_;
1.371 www 3334: return strftime("%Y%m%dT%H%M%SZ",gmtime($date));
1.370 www 3335: }
3336:
1.51 www 3337: sub maketime {
3338: my %th=@_;
3339: return POSIX::mktime(
3340: ($th{'seconds'},$th{'minutes'},$th{'hours'},
1.210 www 3341: $th{'day'},$th{'month'}-1,$th{'year'}-1900,0,0,-1));
1.70 www 3342: }
3343:
3344: #########################################
1.51 www 3345:
3346: sub findallcourses {
1.482 raeburn 3347: my ($roles,$uname,$udom) = @_;
1.355 albertel 3348: my %roles;
3349: if (ref($roles)) { %roles = map { $_ => 1 } @{$roles}; }
1.348 albertel 3350: my %courses;
1.51 www 3351: my $now=time;
1.482 raeburn 3352: if (!defined($uname)) {
3353: $uname = $env{'user.name'};
3354: }
3355: if (!defined($udom)) {
3356: $udom = $env{'user.domain'};
3357: }
3358: if (($uname ne $env{'user.name'}) || ($udom ne $env{'user.domain'})) {
3359: my %roleshash = &Apache::lonnet::dump('roles',$udom,$uname);
3360: if (!%roles) {
3361: %roles = (
3362: cc => 1,
3363: in => 1,
3364: ep => 1,
3365: ta => 1,
3366: cr => 1,
3367: st => 1,
3368: );
3369: }
3370: foreach my $entry (keys(%roleshash)) {
3371: my ($trole,$tend,$tstart) = split(/_/,$roleshash{$entry});
3372: if ($trole =~ /^cr/) {
3373: next if (!exists($roles{$trole}) && !exists($roles{'cr'}));
3374: } else {
3375: next if (!exists($roles{$trole}));
3376: }
3377: if ($tend) {
3378: next if ($tend < $now);
3379: }
3380: if ($tstart) {
3381: next if ($tstart > $now);
3382: }
3383: my ($cdom,$cnum,$sec,$cnumpart,$secpart,$role,$realsec);
3384: (undef,$cdom,$cnumpart,$secpart) = split(/\//,$entry);
3385: if ($secpart eq '') {
3386: ($cnum,$role) = split(/_/,$cnumpart);
3387: $sec = 'none';
3388: $realsec = '';
3389: } else {
3390: $cnum = $cnumpart;
3391: ($sec,$role) = split(/_/,$secpart);
3392: $realsec = $sec;
1.490 raeburn 3393: }
1.482 raeburn 3394: $courses{$cdom.'_'.$cnum}{$sec} = $trole.'/'.$cdom.'/'.$cnum.'/'.$realsec;
3395: }
3396: } else {
3397: foreach my $key (keys(%env)) {
1.483 albertel 3398: if ( $key=~m{^user\.role\.(\w+)\./($match_domain)/($match_courseid)/?(\w*)$} ||
3399: $key=~m{^user\.role\.(cr/$match_domain/$match_username/\w+)\./($match_domain)/($match_courseid)/?(\w*)$}) {
1.482 raeburn 3400: my ($role,$cdom,$cnum,$sec) = ($1,$2,$3,$4);
3401: next if ($role eq 'ca' || $role eq 'aa');
3402: next if (%roles && !exists($roles{$role}));
3403: my ($starttime,$endtime)=split(/\./,$env{$key});
3404: my $active=1;
3405: if ($starttime) {
3406: if ($now<$starttime) { $active=0; }
3407: }
3408: if ($endtime) {
3409: if ($now>$endtime) { $active=0; }
3410: }
3411: if ($active) {
3412: if ($sec eq '') {
3413: $sec = 'none';
3414: }
3415: $courses{$cdom.'_'.$cnum}{$sec} =
3416: $role.'/'.$cdom.'/'.$cnum.'/'.$sec;
1.474 raeburn 3417: }
3418: }
1.51 www 3419: }
3420: }
1.474 raeburn 3421: return %courses;
1.51 www 3422: }
1.37 matthew 3423:
1.54 www 3424: ###############################################
1.474 raeburn 3425:
3426: sub blockcheck {
1.482 raeburn 3427: my ($setters,$activity,$uname,$udom) = @_;
1.490 raeburn 3428:
3429: if (!defined($udom)) {
3430: $udom = $env{'user.domain'};
3431: }
3432: if (!defined($uname)) {
3433: $uname = $env{'user.name'};
3434: }
3435:
3436: # If uname and udom are for a course, check for blocks in the course.
3437:
3438: if (&Apache::lonnet::is_course($udom,$uname)) {
3439: my %records = &Apache::lonnet::dump('comm_block',$udom,$uname);
1.502 raeburn 3440: my ($startblock,$endblock)=&get_blocks($setters,$activity,$udom,$uname);
1.490 raeburn 3441: return ($startblock,$endblock);
3442: }
1.474 raeburn 3443:
1.502 raeburn 3444: my $startblock = 0;
3445: my $endblock = 0;
1.482 raeburn 3446: my %live_courses = &findallcourses(undef,$uname,$udom);
1.474 raeburn 3447:
1.490 raeburn 3448: # If uname is for a user, and activity is course-specific, i.e.,
3449: # boards, chat or groups, check for blocking in current course only.
1.474 raeburn 3450:
1.490 raeburn 3451: if (($activity eq 'boards' || $activity eq 'chat' ||
3452: $activity eq 'groups') && ($env{'request.course.id'})) {
3453: foreach my $key (keys(%live_courses)) {
3454: if ($key ne $env{'request.course.id'}) {
3455: delete($live_courses{$key});
3456: }
3457: }
3458: }
3459:
3460: my $otheruser = 0;
3461: my %own_courses;
3462: if ((($uname ne $env{'user.name'})) || ($udom ne $env{'user.domain'})) {
3463: # Resource belongs to user other than current user.
3464: $otheruser = 1;
3465: # Gather courses for current user
3466: %own_courses =
3467: &findallcourses(undef,$env{'user.name'},$env{'user.domain'});
3468: }
3469:
3470: # Gather active course roles - course coordinator, instructor,
3471: # exam proctor, ta, student, or custom role.
1.474 raeburn 3472:
3473: foreach my $course (keys(%live_courses)) {
1.482 raeburn 3474: my ($cdom,$cnum);
3475: if ((defined($env{'course.'.$course.'.domain'})) && (defined($env{'course.'.$course.'.num'}))) {
3476: $cdom = $env{'course.'.$course.'.domain'};
3477: $cnum = $env{'course.'.$course.'.num'};
3478: } else {
1.490 raeburn 3479: ($cdom,$cnum) = split(/_/,$course);
1.482 raeburn 3480: }
3481: my $no_ownblock = 0;
3482: my $no_userblock = 0;
1.533 raeburn 3483: if ($otheruser && $activity ne 'com') {
1.490 raeburn 3484: # Check if current user has 'evb' priv for this
3485: if (defined($own_courses{$course})) {
3486: foreach my $sec (keys(%{$own_courses{$course}})) {
3487: my $checkrole = 'cm./'.$cdom.'/'.$cnum;
3488: if ($sec ne 'none') {
3489: $checkrole .= '/'.$sec;
3490: }
3491: if (&Apache::lonnet::allowed('evb',undef,undef,$checkrole)) {
3492: $no_ownblock = 1;
3493: last;
3494: }
3495: }
3496: }
3497: # if they have 'evb' priv and are currently not playing student
3498: next if (($no_ownblock) &&
3499: ($env{'request.role'} !~ m{^st\./$cdom/$cnum}));
3500: }
1.474 raeburn 3501: foreach my $sec (keys(%{$live_courses{$course}})) {
1.482 raeburn 3502: my $checkrole = 'cm./'.$cdom.'/'.$cnum;
1.474 raeburn 3503: if ($sec ne 'none') {
1.482 raeburn 3504: $checkrole .= '/'.$sec;
1.474 raeburn 3505: }
1.490 raeburn 3506: if ($otheruser) {
3507: # Resource belongs to user other than current user.
3508: # Assemble privs for that user, and check for 'evb' priv.
1.482 raeburn 3509: my ($trole,$tdom,$tnum,$tsec);
3510: my $entry = $live_courses{$course}{$sec};
3511: if ($entry =~ /^cr/) {
3512: ($trole,$tdom,$tnum,$tsec) =
3513: ($entry =~ m|^(cr/$match_domain/$match_username/\w+)\./($match_domain)/($match_username)/?(\w*)$|);
3514: } else {
3515: ($trole,$tdom,$tnum,$tsec) = split(/\//,$entry);
3516: }
3517: my ($spec,$area,$trest,%allroles,%userroles);
3518: $area = '/'.$tdom.'/'.$tnum;
3519: $trest = $tnum;
3520: if ($tsec ne '') {
3521: $area .= '/'.$tsec;
3522: $trest .= '/'.$tsec;
3523: }
3524: $spec = $trole.'.'.$area;
3525: if ($trole =~ /^cr/) {
3526: &Apache::lonnet::custom_roleprivs(\%allroles,$trole,
3527: $tdom,$spec,$trest,$area);
3528: } else {
3529: &Apache::lonnet::standard_roleprivs(\%allroles,$trole,
3530: $tdom,$spec,$trest,$area);
3531: }
3532: my ($author,$adv) = &Apache::lonnet::set_userprivs(\%userroles,\%allroles);
1.486 raeburn 3533: if ($userroles{'user.priv.'.$checkrole} =~ /evb\&([^\:]*)/) {
3534: if ($1) {
3535: $no_userblock = 1;
3536: last;
3537: }
3538: }
1.490 raeburn 3539: } else {
3540: # Resource belongs to current user
3541: # Check for 'evb' priv via lonnet::allowed().
1.482 raeburn 3542: if (&Apache::lonnet::allowed('evb',undef,undef,$checkrole)) {
3543: $no_ownblock = 1;
3544: last;
3545: }
1.474 raeburn 3546: }
3547: }
3548: # if they have the evb priv and are currently not playing student
1.482 raeburn 3549: next if (($no_ownblock) &&
1.491 albertel 3550: ($env{'request.role'} !~ m{^st\./\Q$cdom\E/\Q$cnum\E}));
1.482 raeburn 3551: next if ($no_userblock);
1.474 raeburn 3552:
1.490 raeburn 3553: # Retrieve blocking times and identity of blocker for course
3554: # of specified user, unless user has 'evb' privilege.
1.502 raeburn 3555:
3556: my ($start,$end)=&get_blocks($setters,$activity,$cdom,$cnum);
3557: if (($start != 0) &&
3558: (($startblock == 0) || ($startblock > $start))) {
3559: $startblock = $start;
3560: }
3561: if (($end != 0) &&
3562: (($endblock == 0) || ($endblock < $end))) {
3563: $endblock = $end;
3564: }
1.490 raeburn 3565: }
3566: return ($startblock,$endblock);
3567: }
3568:
3569: sub get_blocks {
3570: my ($setters,$activity,$cdom,$cnum) = @_;
3571: my $startblock = 0;
3572: my $endblock = 0;
3573: my $course = $cdom.'_'.$cnum;
3574: $setters->{$course} = {};
3575: $setters->{$course}{'staff'} = [];
3576: $setters->{$course}{'times'} = [];
3577: my %records = &Apache::lonnet::dump('comm_block',$cdom,$cnum);
3578: foreach my $record (keys(%records)) {
3579: my ($start,$end) = ($record =~ m/^(\d+)____(\d+)$/);
3580: if ($start <= time && $end >= time) {
3581: my ($staff_name,$staff_dom,$title,$blocks) =
3582: &parse_block_record($records{$record});
3583: if ($blocks->{$activity} eq 'on') {
3584: push(@{$$setters{$course}{'staff'}},[$staff_name,$staff_dom]);
3585: push(@{$$setters{$course}{'times'}}, [$start,$end]);
1.491 albertel 3586: if ( ($startblock == 0) || ($startblock > $start) ) {
3587: $startblock = $start;
1.490 raeburn 3588: }
1.491 albertel 3589: if ( ($endblock == 0) || ($endblock < $end) ) {
3590: $endblock = $end;
1.474 raeburn 3591: }
3592: }
3593: }
3594: }
3595: return ($startblock,$endblock);
3596: }
3597:
3598: sub parse_block_record {
3599: my ($record) = @_;
3600: my ($setuname,$setudom,$title,$blocks);
3601: if (ref($record) eq 'HASH') {
3602: ($setuname,$setudom) = split(/:/,$record->{'setter'});
3603: $title = &unescape($record->{'event'});
3604: $blocks = $record->{'blocks'};
3605: } else {
3606: my @data = split(/:/,$record,3);
3607: if (scalar(@data) eq 2) {
3608: $title = $data[1];
3609: ($setuname,$setudom) = split(/@/,$data[0]);
3610: } else {
3611: ($setuname,$setudom,$title) = @data;
3612: }
3613: $blocks = { 'com' => 'on' };
3614: }
3615: return ($setuname,$setudom,$title,$blocks);
3616: }
3617:
3618: sub build_block_table {
3619: my ($startblock,$endblock,$setters) = @_;
3620: my %lt = &Apache::lonlocal::texthash(
3621: 'cacb' => 'Currently active communication blocks',
3622: 'cour' => 'Course',
3623: 'dura' => 'Duration',
3624: 'blse' => 'Block set by'
3625: );
3626: my $output;
1.476 raeburn 3627: $output = '<br />'.$lt{'cacb'}.':<br />';
1.474 raeburn 3628: $output .= &start_data_table();
3629: $output .= '
3630: <tr>
3631: <th>'.$lt{'cour'}.'</th>
3632: <th>'.$lt{'dura'}.'</th>
3633: <th>'.$lt{'blse'}.'</th>
3634: </tr>
3635: ';
3636: foreach my $course (keys(%{$setters})) {
3637: my %courseinfo=&Apache::lonnet::coursedescription($course);
3638: for (my $i=0; $i<@{$$setters{$course}{staff}}; $i++) {
3639: my ($uname,$udom) = @{$$setters{$course}{staff}[$i]};
1.490 raeburn 3640: my $fullname = &plainname($uname,$udom);
3641: if (defined($env{'user.name'}) && defined($env{'user.domain'})
3642: && $env{'user.name'} ne 'public'
3643: && $env{'user.domain'} ne 'public') {
3644: $fullname = &aboutmewrapper($fullname,$uname,$udom);
3645: }
1.474 raeburn 3646: my ($openblock,$closeblock) = @{$$setters{$course}{times}[$i]};
3647: $openblock = &Apache::lonlocal::locallocaltime($openblock);
3648: $closeblock= &Apache::lonlocal::locallocaltime($closeblock);
3649: $output .= &Apache::loncommon::start_data_table_row().
3650: '<td>'.$courseinfo{'description'}.'</td>'.
3651: '<td>'.$openblock.' to '.$closeblock.'</td>'.
1.490 raeburn 3652: '<td>'.$fullname.'</td>'.
1.474 raeburn 3653: &Apache::loncommon::end_data_table_row();
3654: }
3655: }
3656: $output .= &end_data_table();
3657: }
3658:
1.490 raeburn 3659: sub blocking_status {
3660: my ($activity,$uname,$udom) = @_;
3661: my %setters;
3662: my ($blocked,$output,$ownitem,$is_course);
3663: my ($startblock,$endblock)=&blockcheck(\%setters,$activity,$uname,$udom);
3664: if ($startblock && $endblock) {
3665: $blocked = 1;
3666: if (wantarray) {
3667: my $category;
3668: if ($activity eq 'boards') {
3669: $category = 'Discussion posts in this course';
3670: } elsif ($activity eq 'blogs') {
3671: $category = 'Blogs';
3672: } elsif ($activity eq 'port') {
3673: if (defined($uname) && defined($udom)) {
3674: if ($uname eq $env{'user.name'} &&
3675: $udom eq $env{'user.domain'}) {
3676: $ownitem = 1;
3677: }
3678: }
3679: $is_course = &Apache::lonnet::is_course($udom,$uname);
3680: if ($ownitem) {
3681: $category = 'Your portfolio files';
3682: } elsif ($is_course) {
3683: my $coursedesc;
3684: foreach my $course (keys(%setters)) {
3685: my %courseinfo =
3686: &Apache::lonnet::coursedescription($course);
3687: $coursedesc = $courseinfo{'description'};
3688: }
3689: $category = "Group files in the course '$coursedesc'";
3690: } else {
3691: $category = 'Portfolio files belonging to ';
3692: if ($env{'user.name'} eq 'public' &&
3693: $env{'user.domain'} eq 'public') {
3694: $category .= &plainname($uname,$udom);
3695: } else {
3696: $category .= &aboutmewrapper(&plainname($uname,$udom),$uname,$udom);
3697: }
3698: }
3699: } elsif ($activity eq 'groups') {
3700: $category = 'Groups in this course';
3701: }
3702: my $showstart = &Apache::lonlocal::locallocaltime($startblock);
3703: my $showend = &Apache::lonlocal::locallocaltime($endblock);
3704: $output = '<br />'.&mt('[_1] will be inaccessible between [_2] and [_3] because communication is being blocked.',$category,$showstart,$showend).'<br />';
3705: if (!($activity eq 'port' && !($ownitem) && !($is_course))) {
3706: $output .= &build_block_table($startblock,$endblock,\%setters);
3707: }
3708: }
3709: }
3710: if (wantarray) {
3711: return ($blocked,$output);
3712: } else {
3713: return $blocked;
3714: }
3715: }
3716:
1.60 matthew 3717: ###############################################
3718:
3719: =pod
3720:
1.112 bowersj2 3721: =head1 Domain Template Functions
3722:
3723: =over 4
3724:
3725: =item * &determinedomain()
1.60 matthew 3726:
3727: Inputs: $domain (usually will be undef)
3728:
1.63 www 3729: Returns: Determines which domain should be used for designs
1.60 matthew 3730:
3731: =cut
1.54 www 3732:
1.60 matthew 3733: ###############################################
1.63 www 3734: sub determinedomain {
3735: my $domain=shift;
1.531 albertel 3736: if (! $domain) {
1.60 matthew 3737: # Determine domain if we have not been given one
3738: $domain = $Apache::lonnet::perlvar{'lonDefDomain'};
1.258 albertel 3739: if ($env{'user.domain'}) { $domain=$env{'user.domain'}; }
3740: if ($env{'request.role.domain'}) {
3741: $domain=$env{'request.role.domain'};
1.60 matthew 3742: }
3743: }
1.63 www 3744: return $domain;
3745: }
3746: ###############################################
1.517 raeburn 3747:
1.518 albertel 3748: sub devalidate_domconfig_cache {
3749: my ($udom)=@_;
3750: &Apache::lonnet::devalidate_cache_new('domainconfig',$udom);
3751: }
3752:
3753: # ---------------------- Get domain configuration for a domain
3754: sub get_domainconf {
3755: my ($udom) = @_;
3756: my $cachetime=1800;
3757: my ($result,$cached)=&Apache::lonnet::is_cached_new('domainconfig',$udom);
3758: if (defined($cached)) { return %{$result}; }
3759:
3760: my %domconfig = &Apache::lonnet::get_dom('configuration',
3761: ['login','rolecolors'],$udom);
1.632 raeburn 3762: my (%designhash,%legacy);
1.518 albertel 3763: if (keys(%domconfig) > 0) {
3764: if (ref($domconfig{'login'}) eq 'HASH') {
1.632 raeburn 3765: if (keys(%{$domconfig{'login'}})) {
3766: foreach my $key (keys(%{$domconfig{'login'}})) {
3767: $designhash{$udom.'.login.'.$key}=$domconfig{'login'}{$key};
3768: }
3769: } else {
3770: $legacy{'login'} = 1;
1.518 albertel 3771: }
1.632 raeburn 3772: } else {
3773: $legacy{'login'} = 1;
1.518 albertel 3774: }
3775: if (ref($domconfig{'rolecolors'}) eq 'HASH') {
1.632 raeburn 3776: if (keys(%{$domconfig{'rolecolors'}})) {
3777: foreach my $role (keys(%{$domconfig{'rolecolors'}})) {
3778: if (ref($domconfig{'rolecolors'}{$role}) eq 'HASH') {
3779: foreach my $item (keys(%{$domconfig{'rolecolors'}{$role}})) {
3780: $designhash{$udom.'.'.$role.'.'.$item}=$domconfig{'rolecolors'}{$role}{$item};
3781: }
1.518 albertel 3782: }
3783: }
1.632 raeburn 3784: } else {
3785: $legacy{'rolecolors'} = 1;
1.518 albertel 3786: }
1.632 raeburn 3787: } else {
3788: $legacy{'rolecolors'} = 1;
1.518 albertel 3789: }
1.632 raeburn 3790: if (keys(%legacy) > 0) {
3791: my %legacyhash = &get_legacy_domconf($udom);
3792: foreach my $item (keys(%legacyhash)) {
3793: if ($item =~ /^\Q$udom\E\.login/) {
3794: if ($legacy{'login'}) {
3795: $designhash{$item} = $legacyhash{$item};
3796: }
3797: } else {
3798: if ($legacy{'rolecolors'}) {
3799: $designhash{$item} = $legacyhash{$item};
3800: }
1.518 albertel 3801: }
3802: }
3803: }
1.632 raeburn 3804: } else {
3805: %designhash = &get_legacy_domconf($udom);
1.518 albertel 3806: }
3807: &Apache::lonnet::do_cache_new('domainconfig',$udom,\%designhash,
3808: $cachetime);
3809: return %designhash;
3810: }
3811:
1.632 raeburn 3812: sub get_legacy_domconf {
3813: my ($udom) = @_;
3814: my %legacyhash;
3815: my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors';
3816: my $designfile = $designdir.'/'.$udom.'.tab';
3817: if (-e $designfile) {
3818: if ( open (my $fh,"<$designfile") ) {
3819: while (my $line = <$fh>) {
3820: next if ($line =~ /^\#/);
3821: chomp($line);
3822: my ($key,$val)=(split(/\=/,$line));
3823: if ($val) { $legacyhash{$udom.'.'.$key}=$val; }
3824: }
3825: close($fh);
3826: }
3827: }
3828: if (-e '/home/httpd/html/adm/lonDomLogos/'.$udom.'.gif') {
3829: $legacyhash{$udom.'.login.domlogo'} = "/adm/lonDomLogos/$udom.gif";
3830: }
3831: return %legacyhash;
3832: }
3833:
1.63 www 3834: =pod
3835:
1.112 bowersj2 3836: =item * &domainlogo()
1.63 www 3837:
3838: Inputs: $domain (usually will be undef)
3839:
3840: Returns: A link to a domain logo, if the domain logo exists.
3841: If the domain logo does not exist, a description of the domain.
3842:
3843: =cut
1.112 bowersj2 3844:
1.63 www 3845: ###############################################
3846: sub domainlogo {
1.517 raeburn 3847: my $domain = &determinedomain(shift);
1.518 albertel 3848: my %designhash = &get_domainconf($domain);
1.517 raeburn 3849: # See if there is a logo
3850: if ($designhash{$domain.'.login.domlogo'} ne '') {
1.519 raeburn 3851: my $imgsrc = $designhash{$domain.'.login.domlogo'};
1.538 albertel 3852: if ($imgsrc =~ m{^/(adm|res)/}) {
3853: if ($imgsrc =~ m{^/res/}) {
3854: my $local_name = &Apache::lonnet::filelocation('',$imgsrc);
3855: &Apache::lonnet::repcopy($local_name);
3856: }
3857: $imgsrc = &lonhttpdurl($imgsrc);
1.519 raeburn 3858: }
3859: return '<img src="'.$imgsrc.'" alt="'.$domain.'" />';
1.514 albertel 3860: } elsif (defined(&Apache::lonnet::domain($domain,'description'))) {
3861: return &Apache::lonnet::domain($domain,'description');
1.59 www 3862: } else {
1.60 matthew 3863: return '';
1.59 www 3864: }
3865: }
1.63 www 3866: ##############################################
3867:
3868: =pod
3869:
1.112 bowersj2 3870: =item * &designparm()
1.63 www 3871:
3872: Inputs: $which parameter; $domain (usually will be undef)
3873:
3874: Returns: value of designparamter $which
3875:
3876: =cut
1.112 bowersj2 3877:
1.397 albertel 3878:
1.400 albertel 3879: ##############################################
1.397 albertel 3880: sub designparm {
3881: my ($which,$domain)=@_;
1.258 albertel 3882: if ($env{'browser.blackwhite'} eq 'on') {
1.635 raeburn 3883: if ($which=~/\.(font|alink|vlink|link|textcol)$/) {
1.110 www 3884: return '#000000';
3885: }
1.635 raeburn 3886: if ($which=~/\.(pgbg|sidebg|bgcol)$/) {
1.110 www 3887: return '#FFFFFF';
3888: }
3889: if ($which=~/\.tabbg$/) {
3890: return '#CCCCCC';
3891: }
3892: }
1.397 albertel 3893: if (exists($env{'environment.color.'.$which})) {
1.258 albertel 3894: return $env{'environment.color.'.$which};
1.96 www 3895: }
1.63 www 3896: $domain=&determinedomain($domain);
1.518 albertel 3897: my %domdesign = &get_domainconf($domain);
1.520 raeburn 3898: my $output;
1.517 raeburn 3899: if ($domdesign{$domain.'.'.$which} ne '') {
1.520 raeburn 3900: $output = $domdesign{$domain.'.'.$which};
1.63 www 3901: } else {
1.520 raeburn 3902: $output = $defaultdesign{$which};
3903: }
3904: if (($which =~ /^(student|coordinator|author|admin)\.img$/) ||
1.635 raeburn 3905: ($which =~ /login\.(img|logo|domlogo|login)/)) {
1.538 albertel 3906: if ($output =~ m{^/(adm|res)/}) {
3907: if ($output =~ m{^/res/}) {
3908: my $local_name = &Apache::lonnet::filelocation('',$output);
3909: &Apache::lonnet::repcopy($local_name);
3910: }
1.520 raeburn 3911: $output = &lonhttpdurl($output);
3912: }
1.63 www 3913: }
1.520 raeburn 3914: return $output;
1.63 www 3915: }
1.59 www 3916:
1.60 matthew 3917: ###############################################
3918: ###############################################
3919:
3920: =pod
3921:
1.112 bowersj2 3922: =back
3923:
1.549 albertel 3924: =head1 HTML Helpers
1.112 bowersj2 3925:
3926: =over 4
3927:
3928: =item * &bodytag()
1.60 matthew 3929:
3930: Returns a uniform header for LON-CAPA web pages.
3931:
3932: Inputs:
3933:
1.112 bowersj2 3934: =over 4
3935:
3936: =item * $title, A title to be displayed on the page.
3937:
3938: =item * $function, the current role (can be undef).
3939:
3940: =item * $addentries, extra parameters for the <body> tag.
3941:
3942: =item * $bodyonly, if defined, only return the <body> tag.
3943:
3944: =item * $domain, if defined, force a given domain.
3945:
3946: =item * $forcereg, if page should register as content page (relevant for
1.86 www 3947: text interface only)
1.60 matthew 3948:
1.326 albertel 3949: =item * $customtitle, alternate text to use instead of $title
3950: in the title box that appears, this text
3951: is not auto translated like the $title is
1.309 albertel 3952:
3953: =item * $notopbar, if true, keep the 'what is this' info but remove the
3954: navigational links
1.317 albertel 3955:
1.338 albertel 3956: =item * $bgcolor, used to override the bgcolor on a webpage to a specific value
3957:
3958: =item * $notitle, if true keep the nav controls, but remove the title bar
3959:
1.361 albertel 3960: =item * $no_inline_link, if true and in remote mode, don't show the
3961: 'Switch To Inline Menu' link
3962:
1.460 albertel 3963: =item * $args, optional argument valid values are
3964: no_auto_mt_title -> prevents &mt()ing the title arg
1.562 albertel 3965: inherit_jsmath -> when creating popup window in a page,
3966: should it have jsmath forced on by the
3967: current page
1.460 albertel 3968:
1.112 bowersj2 3969: =back
3970:
1.60 matthew 3971: Returns: A uniform header for LON-CAPA web pages.
3972: If $bodyonly is nonzero, a string containing a <body> tag will be returned.
3973: If $bodyonly is undef or zero, an html string containing a <body> tag and
3974: other decorations will be returned.
3975:
3976: =cut
3977:
1.54 www 3978: sub bodytag {
1.309 albertel 3979: my ($title,$function,$addentries,$bodyonly,$domain,$forcereg,$customtitle,
1.460 albertel 3980: $notopbar,$bgcolor,$notitle,$no_inline_link,$args)=@_;
1.339 albertel 3981:
1.460 albertel 3982: if (!$args->{'no_auto_mt_title'}) { $title = &mt($title); }
1.339 albertel 3983:
1.183 matthew 3984: $function = &get_users_function() if (!$function);
1.339 albertel 3985: my $img = &designparm($function.'.img',$domain);
3986: my $font = &designparm($function.'.font',$domain);
3987: my $pgbg = $bgcolor || &designparm($function.'.pgbg',$domain);
3988:
3989: my %design = ( 'style' => 'margin-top: 0px',
1.535 albertel 3990: 'bgcolor' => $pgbg,
1.339 albertel 3991: 'text' => $font,
3992: 'alink' => &designparm($function.'.alink',$domain),
3993: 'vlink' => &designparm($function.'.vlink',$domain),
3994: 'link' => &designparm($function.'.link',$domain),);
1.438 albertel 3995: @design{keys(%$addentries)} = @$addentries{keys(%$addentries)};
1.339 albertel 3996:
1.63 www 3997: # role and realm
1.378 raeburn 3998: my ($role,$realm) = split(/\./,$env{'request.role'},2);
3999: if ($role eq 'ca') {
1.479 albertel 4000: my ($rdom,$rname) = ($realm =~ m{^/($match_domain)/($match_username)$});
1.500 albertel 4001: $realm = &plainname($rname,$rdom);
1.378 raeburn 4002: }
1.55 www 4003: # realm
1.258 albertel 4004: if ($env{'request.course.id'}) {
1.378 raeburn 4005: if ($env{'request.role'} !~ /^cr/) {
4006: $role = &Apache::lonnet::plaintext($role,&course_type());
4007: }
1.359 albertel 4008: $realm = $env{'course.'.$env{'request.course.id'}.'.description'};
1.378 raeburn 4009: } else {
4010: $role = &Apache::lonnet::plaintext($role);
1.54 www 4011: }
1.433 albertel 4012:
1.359 albertel 4013: if (!$realm) { $realm=' '; }
1.55 www 4014: # Set messages
1.60 matthew 4015: my $messages=&domainlogo($domain);
1.330 albertel 4016:
1.438 albertel 4017: my $extra_body_attr = &make_attr_string($forcereg,\%design);
1.329 albertel 4018:
1.101 www 4019: # construct main body tag
1.359 albertel 4020: my $bodytag = "<body $extra_body_attr>".
1.562 albertel 4021: &Apache::lontexconvert::init_math_support($args->{'inherit_jsmath'});
1.252 albertel 4022:
1.530 albertel 4023: if ($bodyonly) {
1.60 matthew 4024: return $bodytag;
1.258 albertel 4025: } elsif ($env{'browser.interface'} eq 'textual') {
1.95 www 4026: # Accessibility
1.224 raeburn 4027:
1.337 albertel 4028: $bodytag.=&Apache::lonmenu::menubuttons($forcereg,$forcereg);
1.338 albertel 4029: if (!$notitle) {
1.337 albertel 4030: $bodytag.='<h1>LON-CAPA: '.$title.'</h1>';
4031: }
4032: return $bodytag;
1.359 albertel 4033: }
4034:
1.410 albertel 4035: my $name = &plainname($env{'user.name'},$env{'user.domain'});
1.433 albertel 4036: if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') {
4037: undef($role);
1.434 albertel 4038: } else {
4039: $name = &aboutmewrapper($name,$env{'user.name'},$env{'user.domain'});
1.433 albertel 4040: }
1.359 albertel 4041:
4042: my $roleinfo=(<<ENDROLE);
4043: <td class="LC_title_bar_who">
4044: <div class="LC_title_bar_name">
1.410 albertel 4045: $name
1.361 albertel 4046:
1.359 albertel 4047: </div>
4048: <div class="LC_title_bar_role">
1.361 albertel 4049: $role
1.359 albertel 4050: </div>
4051: <div class="LC_title_bar_realm">
1.361 albertel 4052: $realm
1.359 albertel 4053: </div>
1.206 albertel 4054: </td>
4055: ENDROLE
1.235 raeburn 4056:
1.359 albertel 4057: my $titleinfo = '<span class="LC_title_bar_title">'.$title.'</span>';
4058: if ($customtitle) {
4059: $titleinfo = $customtitle;
4060: }
4061: #
4062: # Extra info if you are the DC
4063: my $dc_info = '';
4064: if ($env{'user.adv'} && exists($env{'user.role.dc./'.
4065: $env{'course.'.$env{'request.course.id'}.
4066: '.domain'}.'/'})) {
4067: my $cid = $env{'request.course.id'};
4068: $dc_info.= $cid.' '.$env{'course.'.$cid.'.internal.coursecode'};
1.380 www 4069: $dc_info =~ s/\s+$//;
1.359 albertel 4070: $dc_info = '('.$dc_info.')';
4071: }
4072:
1.644 www 4073: if (($env{'environment.remote'} eq 'off') || ($args->{'suppress_header_logos'})) {
1.359 albertel 4074: # No Remote
1.258 albertel 4075: if ($env{'request.state'} eq 'construct') {
1.359 albertel 4076: $forcereg=1;
4077: }
4078:
4079: if (!$customtitle && $env{'request.state'} eq 'construct') {
4080: # this is for resources; directories have customtitle, and crumbs
4081: # and select recent are created in lonpubdir.pm
1.229 albertel 4082: my ($uname,$thisdisfn)=
1.258 albertel 4083: ($env{'request.filename'} =~ m|^/home/([^/]+)/public_html/(.*)|);
1.229 albertel 4084: my $formaction='/priv/'.$uname.'/'.$thisdisfn;
4085: $formaction=~s/\/+/\//g;
4086:
1.359 albertel 4087: my $parentpath = '';
4088: my $lastitem = '';
4089: if ($thisdisfn =~ m-(.+/)([^/]*)$-) {
4090: $parentpath = $1;
4091: $lastitem = $2;
4092: } else {
4093: $lastitem = $thisdisfn;
4094: }
4095: $titleinfo =
1.640 bisitz 4096: &Apache::loncommon::help_open_menu('','',3,'Authoring')
4097: .'<b>'.&mt('Construction Space').'</b>: '
4098: .'<form name="dirs" method="post" action="'.$formaction
1.359 albertel 4099: .'" target="_top"><tt><b>'
4100: .&Apache::lonhtmlcommon::crumbs($uname.'/'.$parentpath,'_top','/priv','','+1',1)."<font size=\"+1\">$lastitem</font></b></tt><br />"
4101: .&Apache::lonhtmlcommon::select_recent('construct','recent','this.form.action=this.form.recent.value;this.form.submit()')
4102: .'</form>'
4103: .&Apache::lonmenu::constspaceform();
1.235 raeburn 4104: }
1.359 albertel 4105:
1.337 albertel 4106: my $titletable;
1.338 albertel 4107: if (!$notitle) {
1.337 albertel 4108: $titletable =
1.359 albertel 4109: '<table id="LC_title_bar">'.
4110: "<tr><td> $titleinfo $dc_info</td>".$roleinfo.
4111: '</tr></table>';
1.337 albertel 4112: }
1.359 albertel 4113: if ($notopbar) {
4114: $bodytag .= $titletable;
4115: } else {
4116: if ($env{'request.state'} eq 'construct') {
1.337 albertel 4117: $bodytag .= &Apache::lonmenu::menubuttons($forcereg,$forcereg,
4118: $titletable);
1.272 raeburn 4119: } else {
1.336 albertel 4120: $bodytag .= &Apache::lonmenu::menubuttons($forcereg,$forcereg).
1.359 albertel 4121: $titletable;
1.272 raeburn 4122: }
1.235 raeburn 4123: }
4124: return $bodytag;
1.94 www 4125: }
1.95 www 4126:
1.93 www 4127: #
1.95 www 4128: # Top frame rendering, Remote is up
1.93 www 4129: #
1.359 albertel 4130:
1.517 raeburn 4131: my $imgsrc = $img;
4132: if ($img =~ /^\/adm/) {
1.575 albertel 4133: $imgsrc = &lonhttpdurl($img);
1.517 raeburn 4134: }
4135: my $upperleft='<img src="'.$imgsrc.'" alt="'.$function.'" />';
1.359 albertel 4136:
1.305 www 4137: # Explicit link to get inline menu
1.361 albertel 4138: my $menu= ($no_inline_link?''
4139: :'<br /><a href="/adm/remote?action=collapse">'.&mt('Switch to Inline Menu Mode').'</a>');
1.245 matthew 4140: #
1.338 albertel 4141: if ($notitle) {
1.337 albertel 4142: return $bodytag;
4143: }
1.94 www 4144: return(<<ENDBODY);
1.60 matthew 4145: $bodytag
1.359 albertel 4146: <table id="LC_title_bar" class="LC_with_remote">
1.368 albertel 4147: <tr><td class="LC_title_bar_role_logo">$upperleft</td>
1.359 albertel 4148: <td class="LC_title_bar_domain_logo">$messages </td>
1.54 www 4149: </tr>
1.359 albertel 4150: <tr><td>$titleinfo $dc_info $menu</td>
4151: $roleinfo
1.368 albertel 4152: </tr>
1.356 albertel 4153: </table>
1.54 www 4154: ENDBODY
1.182 matthew 4155: }
4156:
1.330 albertel 4157: sub make_attr_string {
4158: my ($register,$attr_ref) = @_;
4159:
4160: if ($attr_ref && !ref($attr_ref)) {
4161: die("addentries Must be a hash ref ".
4162: join(':',caller(1))." ".
4163: join(':',caller(0))." ");
4164: }
4165:
4166: if ($register) {
1.339 albertel 4167: my ($on_load,$on_unload);
4168: foreach my $key (keys(%{$attr_ref})) {
4169: if (lc($key) eq 'onload') {
4170: $on_load.=$attr_ref->{$key}.';';
4171: delete($attr_ref->{$key});
4172:
4173: } elsif (lc($key) eq 'onunload') {
4174: $on_unload.=$attr_ref->{$key}.';';
4175: delete($attr_ref->{$key});
4176: }
4177: }
4178: $attr_ref->{'onload'} =
4179: &Apache::lonmenu::loadevents(). $on_load;
4180: $attr_ref->{'onunload'}=
4181: &Apache::lonmenu::unloadevents().$on_unload;
4182: }
4183:
4184: # Accessibility font enhance
4185: if ($env{'browser.fontenhance'} eq 'on') {
4186: my $style;
4187: foreach my $key (keys(%{$attr_ref})) {
4188: if (lc($key) eq 'style') {
4189: $style.=$attr_ref->{$key}.';';
4190: delete($attr_ref->{$key});
4191: }
4192: }
4193: $attr_ref->{'style'}=$style.'; font-size: x-large;';
1.330 albertel 4194: }
1.339 albertel 4195:
4196: if ($env{'browser.blackwhite'} eq 'on') {
4197: delete($attr_ref->{'font'});
4198: delete($attr_ref->{'link'});
4199: delete($attr_ref->{'alink'});
4200: delete($attr_ref->{'vlink'});
4201: delete($attr_ref->{'bgcolor'});
4202: delete($attr_ref->{'background'});
4203: }
4204:
1.330 albertel 4205: my $attr_string;
4206: foreach my $attr (keys(%$attr_ref)) {
4207: $attr_string .= " $attr=\"".$attr_ref->{$attr}.'" ';
4208: }
4209: return $attr_string;
4210: }
4211:
4212:
1.182 matthew 4213: ###############################################
1.251 albertel 4214: ###############################################
4215:
4216: =pod
4217:
4218: =item * &endbodytag()
4219:
4220: Returns a uniform footer for LON-CAPA web pages.
4221:
1.635 raeburn 4222: Inputs: 1 - optional reference to an args hash
4223: If in the hash, key for noredirectlink has a value which evaluates to true,
4224: a 'Continue' link is not displayed if the page contains an
4225: internal redirect in the <head></head> section,
4226: i.e., $env{'internal.head.redirect'} exists
1.251 albertel 4227:
4228: =cut
4229:
4230: sub endbodytag {
1.635 raeburn 4231: my ($args) = @_;
1.251 albertel 4232: my $endbodytag='</body>';
1.269 albertel 4233: $endbodytag=&Apache::lontexconvert::jsMath_process()."\n".$endbodytag;
1.315 albertel 4234: if ( exists( $env{'internal.head.redirect'} ) ) {
1.635 raeburn 4235: if (!(ref($args) eq 'HASH' && $args->{'noredirectlink'})) {
4236: $endbodytag=
4237: "<br /><a href=\"$env{'internal.head.redirect'}\">".
4238: &mt('Continue').'</a>'.
4239: $endbodytag;
4240: }
1.315 albertel 4241: }
1.251 albertel 4242: return $endbodytag;
4243: }
4244:
1.352 albertel 4245: =pod
4246:
4247: =item * &standard_css()
4248:
4249: Returns a style sheet
4250:
4251: Inputs: (all optional)
4252: domain -> force to color decorate a page for a specific
4253: domain
4254: function -> force usage of a specific rolish color scheme
4255: bgcolor -> override the default page bgcolor
4256:
4257: =cut
4258:
1.343 albertel 4259: sub standard_css {
1.345 albertel 4260: my ($function,$domain,$bgcolor) = @_;
1.352 albertel 4261: $function = &get_users_function() if (!$function);
4262: my $img = &designparm($function.'.img', $domain);
4263: my $tabbg = &designparm($function.'.tabbg', $domain);
4264: my $font = &designparm($function.'.font', $domain);
1.345 albertel 4265: my $sidebg = &designparm($function.'.sidebg',$domain);
1.382 albertel 4266: my $pgbg_or_bgcolor =
4267: $bgcolor ||
1.352 albertel 4268: &designparm($function.'.pgbg', $domain);
1.382 albertel 4269: my $pgbg = &designparm($function.'.pgbg', $domain);
1.352 albertel 4270: my $alink = &designparm($function.'.alink', $domain);
4271: my $vlink = &designparm($function.'.vlink', $domain);
4272: my $link = &designparm($function.'.link', $domain);
4273:
1.602 albertel 4274: my $sans = 'Verdana,Arial,Helvetica,sans-serif';
1.395 albertel 4275: my $mono = 'monospace';
1.352 albertel 4276: my $data_table_head = $tabbg;
4277: my $data_table_light = '#EEEEEE';
1.470 banghart 4278: my $data_table_dark = '#DDDDDD';
4279: my $data_table_darker = '#CCCCCC';
1.349 albertel 4280: my $data_table_highlight = '#FFFF00';
1.352 albertel 4281: my $mail_new = '#FFBB77';
4282: my $mail_new_hover = '#DD9955';
4283: my $mail_read = '#BBBB77';
4284: my $mail_read_hover = '#999944';
4285: my $mail_replied = '#AAAA88';
4286: my $mail_replied_hover = '#888855';
4287: my $mail_other = '#99BBBB';
4288: my $mail_other_hover = '#669999';
1.391 albertel 4289: my $table_header = '#DDDDDD';
1.489 raeburn 4290: my $feedback_link_bg = '#BBBBBB';
1.392 albertel 4291:
1.608 albertel 4292: my $border = ($env{'browser.type'} eq 'explorer' ||
4293: $env{'browser.type'} eq 'safari' ) ? '0px 2px 0px 2px'
4294: : '0px 3px 0px 4px';
1.448 albertel 4295:
1.523 albertel 4296:
1.343 albertel 4297: return <<END;
1.345 albertel 4298: h1, h2, h3, th { font-family: $sans }
1.343 albertel 4299: a:focus { color: red; background: yellow }
1.510 albertel 4300: table.thinborder,
1.523 albertel 4301:
1.510 albertel 4302: table.thinborder tr th {
4303: border-style: solid;
4304: border-width: 1px;
4305: background: $tabbg;
4306: }
1.523 albertel 4307: table.thinborder tr td {
1.510 albertel 4308: border-style: solid;
4309: border-width: 1px
4310: }
1.426 albertel 4311:
1.343 albertel 4312: form, .inline { display: inline; }
4313: .center { text-align: center; }
1.593 albertel 4314: .LC_filename {font-family: $mono; white-space:pre;}
1.350 albertel 4315: .LC_error {
4316: color: red;
4317: font-size: larger;
4318: }
1.457 albertel 4319: .LC_warning,
4320: .LC_diff_removed {
1.394 albertel 4321: color: red;
4322: }
1.532 albertel 4323:
4324: .LC_info,
1.457 albertel 4325: .LC_success,
4326: .LC_diff_added {
1.350 albertel 4327: color: green;
4328: }
1.543 albertel 4329: .LC_unknown {
4330: color: yellow;
4331: }
4332:
1.440 albertel 4333: .LC_icon {
4334: border: 0px;
4335: }
1.539 albertel 4336: .LC_indexer_icon {
4337: border: 0px;
4338: height: 22px;
4339: }
1.543 albertel 4340: .LC_docs_spacer {
4341: width: 25px;
4342: height: 1px;
4343: border: 0px;
4344: }
1.346 albertel 4345:
1.532 albertel 4346: .LC_internal_info {
4347: color: #999;
4348: }
4349:
1.458 albertel 4350: table.LC_pastsubmission {
4351: border: 1px solid black;
4352: margin: 2px;
4353: }
4354:
1.606 albertel 4355: table#LC_top_nav, table#LC_menubuttons,table#LC_nav_location {
1.345 albertel 4356: width: 100%;
4357: background: $pgbg;
1.392 albertel 4358: border: 2px;
1.402 albertel 4359: border-collapse: separate;
1.403 albertel 4360: padding: 0px;
1.345 albertel 4361: }
1.392 albertel 4362:
1.606 albertel 4363: table#LC_title_bar, table.LC_breadcrumbs,
1.393 albertel 4364: table#LC_title_bar.LC_with_remote {
1.359 albertel 4365: width: 100%;
1.392 albertel 4366: border-color: $pgbg;
4367: border-style: solid;
4368: border-width: $border;
4369:
1.379 albertel 4370: background: $pgbg;
4371: font-family: $sans;
1.392 albertel 4372: border-collapse: collapse;
1.403 albertel 4373: padding: 0px;
1.359 albertel 4374: }
1.392 albertel 4375:
1.409 albertel 4376: table.LC_docs_path {
4377: width: 100%;
4378: border: 0;
4379: background: $pgbg;
4380: font-family: $sans;
4381: border-collapse: collapse;
4382: padding: 0px;
4383: }
4384:
1.359 albertel 4385: table#LC_title_bar td {
4386: background: $tabbg;
4387: }
4388: table#LC_title_bar td.LC_title_bar_who {
4389: background: $tabbg;
4390: color: $font;
1.427 albertel 4391: font: small $sans;
1.359 albertel 4392: text-align: right;
4393: }
1.469 banghart 4394: span.LC_metadata {
4395: font-family: $sans;
4396: }
1.359 albertel 4397: span.LC_title_bar_title {
1.416 albertel 4398: font: bold x-large $sans;
1.359 albertel 4399: }
4400: table#LC_title_bar td.LC_title_bar_domain_logo {
4401: background: $sidebg;
4402: text-align: right;
1.368 albertel 4403: padding: 0px;
4404: }
4405: table#LC_title_bar td.LC_title_bar_role_logo {
4406: background: $sidebg;
4407: padding: 0px;
1.359 albertel 4408: }
4409:
1.346 albertel 4410: table#LC_menubuttons_mainmenu {
1.526 www 4411: width: 100%;
1.346 albertel 4412: border: 0px;
4413: border-spacing: 1px;
1.372 albertel 4414: padding: 0px 1px;
1.346 albertel 4415: margin: 0px;
4416: border-collapse: separate;
4417: }
4418: table#LC_menubuttons img, table#LC_menubuttons_mainmenu img {
4419: border: 0px;
4420: }
1.345 albertel 4421: table#LC_top_nav td {
4422: background: $tabbg;
1.392 albertel 4423: border: 0px;
1.407 albertel 4424: font-size: small;
1.345 albertel 4425: }
4426: table#LC_top_nav td a, div#LC_top_nav a {
4427: color: $font;
4428: font-family: $sans;
4429: }
1.364 albertel 4430: table#LC_top_nav td.LC_top_nav_logo {
4431: background: $tabbg;
1.432 albertel 4432: text-align: left;
1.408 albertel 4433: white-space: nowrap;
1.432 albertel 4434: width: 31px;
1.408 albertel 4435: }
4436: table#LC_top_nav td.LC_top_nav_logo img {
1.432 albertel 4437: border: 0px;
1.408 albertel 4438: vertical-align: bottom;
1.364 albertel 4439: }
1.432 albertel 4440: table#LC_top_nav td.LC_top_nav_exit,
4441: table#LC_top_nav td.LC_top_nav_help {
4442: width: 2.0em;
4443: }
1.442 albertel 4444: table#LC_top_nav td.LC_top_nav_login {
4445: width: 4.0em;
4446: text-align: center;
4447: }
1.409 albertel 4448: table.LC_breadcrumbs td, table.LC_docs_path td {
1.357 albertel 4449: background: $tabbg;
4450: color: $font;
4451: font-family: $sans;
1.358 albertel 4452: font-size: smaller;
1.357 albertel 4453: }
1.411 albertel 4454: table.LC_breadcrumbs td.LC_breadcrumbs_component,
1.409 albertel 4455: table.LC_docs_path td.LC_docs_path_component {
1.357 albertel 4456: background: $tabbg;
4457: color: $font;
4458: font-family: $sans;
4459: font-size: larger;
4460: text-align: right;
4461: }
1.383 albertel 4462: td.LC_table_cell_checkbox {
4463: text-align: center;
4464: }
4465:
1.522 albertel 4466: table#LC_mainmenu td.LC_mainmenu_column {
4467: vertical-align: top;
4468: }
4469:
1.346 albertel 4470: .LC_menubuttons_inline_text {
4471: color: $font;
4472: font-family: $sans;
4473: font-size: smaller;
4474: }
4475:
1.526 www 4476: .LC_menubuttons_link {
4477: text-decoration: none;
4478: }
4479:
1.522 albertel 4480: .LC_menubuttons_category {
1.521 www 4481: color: $font;
1.526 www 4482: background: $pgbg;
1.521 www 4483: font-family: $sans;
4484: font-size: larger;
4485: font-weight: bold;
4486: }
4487:
1.346 albertel 4488: td.LC_menubuttons_text {
1.526 www 4489: width: 90%;
1.346 albertel 4490: color: $font;
4491: font-family: $sans;
4492: }
1.526 www 4493:
1.346 albertel 4494: td.LC_menubuttons_img {
4495: }
1.526 www 4496:
1.346 albertel 4497: .LC_current_location {
4498: font-family: $sans;
4499: background: $tabbg;
4500: }
4501: .LC_new_mail {
4502: font-family: $sans;
1.634 www 4503: background: $tabbg;
1.346 albertel 4504: font-weight: bold;
4505: }
1.347 albertel 4506:
1.526 www 4507: .LC_rolesmenu_is {
4508: font-family: $sans;
4509: }
4510:
4511: .LC_rolesmenu_selected {
4512: font-family: $sans;
4513: }
4514:
4515: .LC_rolesmenu_future {
4516: font-family: $sans;
4517: }
4518:
4519:
4520: .LC_rolesmenu_will {
4521: font-family: $sans;
4522: }
4523:
4524: .LC_rolesmenu_will_not {
4525: font-family: $sans;
4526: }
4527:
4528: .LC_rolesmenu_expired {
4529: font-family: $sans;
4530: }
4531:
4532: .LC_rolesinfo {
4533: font-family: $sans;
4534: }
4535:
1.527 www 4536: .LC_dropadd_labeltext {
4537: font-family: $sans;
4538: text-align: right;
4539: }
4540:
4541: .LC_preferences_labeltext {
4542: font-family: $sans;
4543: text-align: right;
4544: }
4545:
1.440 albertel 4546: table.LC_aboutme_port {
4547: border: 0px;
4548: border-collapse: collapse;
4549: border-spacing: 0px;
4550: }
1.349 albertel 4551: table.LC_data_table, table.LC_mail_list {
1.347 albertel 4552: border: 1px solid #000000;
1.402 albertel 4553: border-collapse: separate;
1.426 albertel 4554: border-spacing: 1px;
1.610 albertel 4555: background: $pgbg;
1.347 albertel 4556: }
1.422 albertel 4557: .LC_data_table_dense {
4558: font-size: small;
4559: }
1.507 raeburn 4560: table.LC_nested_outer {
4561: border: 1px solid #000000;
1.589 raeburn 4562: border-collapse: collapse;
1.507 raeburn 4563: border-spacing: 0px;
4564: width: 100%;
4565: }
4566: table.LC_nested {
4567: border: 0px;
1.589 raeburn 4568: border-collapse: collapse;
1.507 raeburn 4569: border-spacing: 0px;
4570: width: 100%;
4571: }
1.523 albertel 4572: table.LC_data_table tr th, table.LC_calendar tr th, table.LC_mail_list tr th,
4573: table.LC_prior_tries tr th {
1.349 albertel 4574: font-weight: bold;
4575: background-color: $data_table_head;
1.421 albertel 4576: font-size: smaller;
1.347 albertel 4577: }
1.610 albertel 4578: table.LC_data_table tr.LC_odd_row > td,
1.440 albertel 4579: table.LC_aboutme_port tr td {
1.349 albertel 4580: background-color: $data_table_light;
1.425 albertel 4581: padding: 2px;
1.347 albertel 4582: }
1.610 albertel 4583: table.LC_data_table tr.LC_even_row > td,
1.440 albertel 4584: table.LC_aboutme_port tr.LC_even_row td {
1.349 albertel 4585: background-color: $data_table_dark;
1.347 albertel 4586: }
1.425 albertel 4587: table.LC_data_table tr.LC_data_table_highlight td {
4588: background-color: $data_table_darker;
4589: }
1.639 raeburn 4590: table.LC_data_table tr td.LC_leftcol_header {
4591: background-color: $data_table_head;
4592: font-weight: bold;
4593: }
1.451 albertel 4594: table.LC_data_table tr.LC_empty_row td,
1.507 raeburn 4595: table.LC_nested tr.LC_empty_row td {
1.347 albertel 4596: background-color: #FFFFFF;
1.421 albertel 4597: font-weight: bold;
4598: font-style: italic;
4599: text-align: center;
4600: padding: 8px;
1.347 albertel 4601: }
1.507 raeburn 4602: table.LC_nested tr.LC_empty_row td {
1.465 albertel 4603: padding: 4ex
4604: }
1.507 raeburn 4605: table.LC_nested_outer tr th {
4606: font-weight: bold;
4607: background-color: $data_table_head;
4608: font-size: smaller;
4609: border-bottom: 1px solid #000000;
4610: }
4611: table.LC_nested_outer tr td.LC_subheader {
4612: background-color: $data_table_head;
4613: font-weight: bold;
4614: font-size: small;
4615: border-bottom: 1px solid #000000;
4616: text-align: right;
1.451 albertel 4617: }
1.507 raeburn 4618: table.LC_nested tr.LC_info_row td {
1.451 albertel 4619: background-color: #CCC;
4620: font-weight: bold;
4621: font-size: small;
1.507 raeburn 4622: text-align: center;
4623: }
1.589 raeburn 4624: table.LC_nested tr.LC_info_row td.LC_left_item,
4625: table.LC_nested_outer tr th.LC_left_item {
1.507 raeburn 4626: text-align: left;
1.451 albertel 4627: }
1.507 raeburn 4628: table.LC_nested td {
1.451 albertel 4629: background-color: #FFF;
4630: font-size: small;
1.507 raeburn 4631: }
4632: table.LC_nested_outer tr th.LC_right_item,
4633: table.LC_nested tr.LC_info_row td.LC_right_item,
4634: table.LC_nested tr.LC_odd_row td.LC_right_item,
4635: table.LC_nested tr td.LC_right_item {
1.451 albertel 4636: text-align: right;
4637: }
4638:
1.507 raeburn 4639: table.LC_nested tr.LC_odd_row td {
1.451 albertel 4640: background-color: #EEE;
4641: }
4642:
1.473 raeburn 4643: table.LC_createuser {
4644: }
4645:
4646: table.LC_createuser tr.LC_section_row td {
4647: font-size: smaller;
4648: }
4649:
4650: table.LC_createuser tr.LC_info_row td {
4651: background-color: #CCC;
4652: font-weight: bold;
4653: text-align: center;
4654: }
4655:
1.349 albertel 4656: table.LC_calendar {
4657: border: 1px solid #000000;
4658: border-collapse: collapse;
4659: }
4660: table.LC_calendar_pickdate {
4661: font-size: xx-small;
4662: }
4663: table.LC_calendar tr td {
4664: border: 1px solid #000000;
4665: vertical-align: top;
4666: }
4667: table.LC_calendar tr td.LC_calendar_day_empty {
4668: background-color: $data_table_dark;
4669: }
4670: table.LC_calendar tr td.LC_calendar_day_current {
4671: background-color: $data_table_highlight;
4672: }
4673:
4674: table.LC_mail_list tr.LC_mail_new {
4675: background-color: $mail_new;
4676: }
4677: table.LC_mail_list tr.LC_mail_new:hover {
4678: background-color: $mail_new_hover;
4679: }
4680: table.LC_mail_list tr.LC_mail_read {
4681: background-color: $mail_read;
4682: }
4683: table.LC_mail_list tr.LC_mail_read:hover {
4684: background-color: $mail_read_hover;
4685: }
4686: table.LC_mail_list tr.LC_mail_replied {
4687: background-color: $mail_replied;
4688: }
4689: table.LC_mail_list tr.LC_mail_replied:hover {
4690: background-color: $mail_replied_hover;
4691: }
4692: table.LC_mail_list tr.LC_mail_other {
4693: background-color: $mail_other;
4694: }
4695: table.LC_mail_list tr.LC_mail_other:hover {
4696: background-color: $mail_other_hover;
4697: }
1.494 raeburn 4698: table.LC_mail_list tr.LC_mail_even {
4699: }
4700: table.LC_mail_list tr.LC_mail_odd {
4701: }
4702:
1.385 albertel 4703:
1.386 albertel 4704: table#LC_portfolio_actions {
4705: width: auto;
4706: background: $pgbg;
4707: border: 0px;
4708: border-spacing: 2px 2px;
4709: padding: 0px;
4710: margin: 0px;
4711: border-collapse: separate;
4712: }
4713: table#LC_portfolio_actions td.LC_label {
4714: background: $tabbg;
4715: text-align: right;
4716: }
4717: table#LC_portfolio_actions td.LC_value {
4718: background: $tabbg;
4719: }
1.385 albertel 4720:
1.391 albertel 4721: table#LC_cstr_controls {
4722: width: 100%;
4723: border-collapse: collapse;
4724: }
4725: table#LC_cstr_controls tr td {
4726: border: 4px solid $pgbg;
4727: padding: 4px;
4728: text-align: center;
4729: background: $tabbg;
4730: }
4731: table#LC_cstr_controls tr th {
4732: border: 4px solid $pgbg;
4733: background: $table_header;
4734: text-align: center;
4735: font-family: $sans;
4736: font-size: smaller;
4737: }
4738:
1.389 albertel 4739: table#LC_browser {
4740:
4741: }
4742: table#LC_browser tr th {
1.391 albertel 4743: background: $table_header;
1.389 albertel 4744: }
1.390 albertel 4745: table#LC_browser tr td {
4746: padding: 2px;
4747: }
1.389 albertel 4748: table#LC_browser tr.LC_browser_file,
4749: table#LC_browser tr.LC_browser_file_published {
4750: background: #CCFF88;
4751: }
4752: table#LC_browser tr.LC_browser_file_locked,
4753: table#LC_browser tr.LC_browser_file_unpublished {
4754: background: #FFAA99;
1.387 albertel 4755: }
1.389 albertel 4756: table#LC_browser tr.LC_browser_file_obsolete {
4757: background: #AAAAAA;
1.387 albertel 4758: }
1.455 albertel 4759: table#LC_browser tr.LC_browser_file_modified,
4760: table#LC_browser tr.LC_browser_file_metamodified {
1.389 albertel 4761: background: #FFFF77;
1.387 albertel 4762: }
1.389 albertel 4763: table#LC_browser tr.LC_browser_folder {
4764: background: #CCCCFF;
1.387 albertel 4765: }
1.388 albertel 4766: span.LC_current_location {
4767: font-size: x-large;
4768: background: $pgbg;
4769: }
1.387 albertel 4770:
1.395 albertel 4771: span.LC_parm_menu_item {
4772: font-size: larger;
4773: font-family: $sans;
4774: }
4775: span.LC_parm_scope_all {
4776: color: red;
4777: }
4778: span.LC_parm_scope_folder {
4779: color: green;
4780: }
4781: span.LC_parm_scope_resource {
4782: color: orange;
4783: }
4784: span.LC_parm_part {
4785: color: blue;
4786: }
4787: span.LC_parm_folder, span.LC_parm_symb {
4788: font-size: x-small;
4789: font-family: $mono;
4790: color: #AAAAAA;
4791: }
4792:
1.396 albertel 4793: td.LC_parm_overview_level_menu, td.LC_parm_overview_map_menu,
4794: td.LC_parm_overview_parm_selectors, td.LC_parm_overview_parm_restrictions {
4795: border: 1px solid black;
4796: border-collapse: collapse;
4797: }
4798: table.LC_parm_overview_restrictions td {
4799: border-width: 1px 4px 1px 4px;
4800: border-style: solid;
4801: border-color: $pgbg;
4802: text-align: center;
4803: }
4804: table.LC_parm_overview_restrictions th {
4805: background: $tabbg;
4806: border-width: 1px 4px 1px 4px;
4807: border-style: solid;
4808: border-color: $pgbg;
4809: }
1.398 albertel 4810: table#LC_helpmenu {
4811: border: 0px;
4812: height: 55px;
4813: border-spacing: 0px;
4814: }
4815:
4816: table#LC_helpmenu fieldset legend {
4817: font-size: larger;
4818: font-weight: bold;
4819: }
1.397 albertel 4820: table#LC_helpmenu_links {
4821: width: 100%;
4822: border: 1px solid black;
4823: background: $pgbg;
4824: padding: 0px;
4825: border-spacing: 1px;
4826: }
4827: table#LC_helpmenu_links tr td {
4828: padding: 1px;
4829: background: $tabbg;
1.399 albertel 4830: text-align: center;
4831: font-weight: bold;
1.397 albertel 4832: }
1.396 albertel 4833:
1.397 albertel 4834: table#LC_helpmenu_links a:link, table#LC_helpmenu_links a:visited,
4835: table#LC_helpmenu_links a:active {
4836: text-decoration: none;
4837: color: $font;
4838: }
4839: table#LC_helpmenu_links a:hover {
4840: text-decoration: underline;
4841: color: $vlink;
4842: }
1.396 albertel 4843:
1.417 albertel 4844: .LC_chrt_popup_exists {
4845: border: 1px solid #339933;
4846: margin: -1px;
4847: }
4848: .LC_chrt_popup_up {
4849: border: 1px solid yellow;
4850: margin: -1px;
4851: }
4852: .LC_chrt_popup {
4853: border: 1px solid #8888FF;
4854: background: #CCCCFF;
4855: }
1.421 albertel 4856: table.LC_pick_box {
4857: border-collapse: separate;
4858: background: white;
4859: border: 1px solid black;
4860: border-spacing: 1px;
4861: }
4862: table.LC_pick_box td.LC_pick_box_title {
4863: background: $tabbg;
4864: font-weight: bold;
4865: text-align: right;
4866: width: 184px;
4867: padding: 8px;
4868: }
1.645 raeburn 4869: table.LC_pick_box td.LC_selfenroll_pick_box_title {
4870: background: $tabbg;
4871: font-weight: bold;
4872: text-align: right;
4873: width: 350px;
4874: padding: 8px;
4875: }
4876:
1.579 raeburn 4877: table.LC_pick_box td.LC_pick_box_value {
4878: text-align: left;
4879: padding: 8px;
4880: }
4881: table.LC_pick_box td.LC_pick_box_select {
4882: text-align: left;
4883: padding: 8px;
4884: }
1.424 albertel 4885: table.LC_pick_box td.LC_pick_box_separator {
1.421 albertel 4886: padding: 0px;
4887: height: 1px;
4888: background: black;
4889: }
4890: table.LC_pick_box td.LC_pick_box_submit {
4891: text-align: right;
4892: }
1.579 raeburn 4893: table.LC_pick_box td.LC_evenrow_value {
4894: text-align: left;
4895: padding: 8px;
4896: background-color: $data_table_light;
4897: }
4898: table.LC_pick_box td.LC_oddrow_value {
4899: text-align: left;
4900: padding: 8px;
4901: background-color: $data_table_light;
4902: }
4903: table.LC_helpform_receipt {
4904: width: 620px;
4905: border-collapse: separate;
4906: background: white;
4907: border: 1px solid black;
4908: border-spacing: 1px;
4909: }
4910: table.LC_helpform_receipt td.LC_pick_box_title {
4911: background: $tabbg;
4912: font-weight: bold;
4913: text-align: right;
4914: width: 184px;
4915: padding: 8px;
4916: }
4917: table.LC_helpform_receipt td.LC_evenrow_value {
4918: text-align: left;
4919: padding: 8px;
4920: background-color: $data_table_light;
4921: }
4922: table.LC_helpform_receipt td.LC_oddrow_value {
4923: text-align: left;
4924: padding: 8px;
4925: background-color: $data_table_light;
4926: }
4927: table.LC_helpform_receipt td.LC_pick_box_separator {
4928: padding: 0px;
4929: height: 1px;
4930: background: black;
4931: }
4932: span.LC_helpform_receipt_cat {
4933: font-weight: bold;
4934: }
1.424 albertel 4935: table.LC_group_priv_box {
4936: background: white;
4937: border: 1px solid black;
4938: border-spacing: 1px;
4939: }
4940: table.LC_group_priv_box td.LC_pick_box_title {
4941: background: $tabbg;
4942: font-weight: bold;
4943: text-align: right;
4944: width: 184px;
4945: }
4946: table.LC_group_priv_box td.LC_groups_fixed {
4947: background: $data_table_light;
4948: text-align: center;
4949: }
4950: table.LC_group_priv_box td.LC_groups_optional {
4951: background: $data_table_dark;
4952: text-align: center;
4953: }
4954: table.LC_group_priv_box td.LC_groups_functionality {
4955: background: $data_table_darker;
4956: text-align: center;
4957: font-weight: bold;
4958: }
4959: table.LC_group_priv td {
4960: text-align: left;
4961: padding: 0px;
4962: }
4963:
1.421 albertel 4964: table.LC_notify_front_page {
4965: background: white;
4966: border: 1px solid black;
4967: padding: 8px;
4968: }
4969: table.LC_notify_front_page td {
4970: padding: 8px;
4971: }
1.424 albertel 4972: .LC_navbuttons {
4973: margin: 2ex 0ex 2ex 0ex;
4974: }
1.423 albertel 4975: .LC_topic_bar {
4976: font-family: $sans;
4977: font-weight: bold;
4978: width: 100%;
4979: background: $tabbg;
4980: vertical-align: middle;
4981: margin: 2ex 0ex 2ex 0ex;
4982: }
4983: .LC_topic_bar span {
4984: vertical-align: middle;
4985: }
4986: .LC_topic_bar img {
4987: vertical-align: bottom;
4988: }
4989: table.LC_course_group_status {
4990: margin: 20px;
4991: }
4992: table.LC_status_selector td {
4993: vertical-align: top;
4994: text-align: center;
1.424 albertel 4995: padding: 4px;
4996: }
4997: table.LC_descriptive_input td.LC_description {
4998: vertical-align: top;
4999: text-align: right;
5000: font-weight: bold;
1.423 albertel 5001: }
1.599 albertel 5002: div.LC_feedback_link {
1.616 albertel 5003: clear: both;
1.599 albertel 5004: background: white;
5005: width: 100%;
1.489 raeburn 5006: }
5007: span.LC_feedback_link {
1.599 albertel 5008: background: $feedback_link_bg;
5009: font-size: larger;
5010: }
5011: span.LC_message_link {
5012: background: $feedback_link_bg;
5013: font-size: larger;
5014: position: absolute;
5015: right: 1em;
1.489 raeburn 5016: }
1.421 albertel 5017:
1.515 albertel 5018: table.LC_prior_tries {
1.524 albertel 5019: border: 1px solid #000000;
5020: border-collapse: separate;
5021: border-spacing: 1px;
1.515 albertel 5022: }
1.523 albertel 5023:
1.515 albertel 5024: table.LC_prior_tries td {
1.524 albertel 5025: padding: 2px;
1.515 albertel 5026: }
1.523 albertel 5027:
5028: .LC_answer_correct {
5029: background: #AAFFAA;
5030: color: black;
5031: }
5032: .LC_answer_charged_try {
5033: background: #FFAAAA ! important;
5034: color: black;
5035: }
5036: .LC_answer_not_charged_try,
5037: .LC_answer_no_grade,
5038: .LC_answer_late {
5039: background: #FFFFAA;
5040: color: black;
5041: }
5042: .LC_answer_previous {
5043: background: #AAAAFF;
5044: color: black;
5045: }
5046: .LC_answer_no_message {
5047: background: #FFFFFF;
5048: color: black;
5049: }
5050: .LC_answer_unknown {
5051: background: orange;
5052: color: black;
5053: }
5054:
5055:
1.529 albertel 5056: span.LC_prior_numerical,
5057: span.LC_prior_string,
5058: span.LC_prior_custom,
5059: span.LC_prior_reaction,
5060: span.LC_prior_math {
1.523 albertel 5061: font-family: monospace;
5062: white-space: pre;
5063: }
5064:
1.525 albertel 5065: span.LC_prior_string {
5066: font-family: monospace;
5067: white-space: pre;
5068: }
5069:
1.523 albertel 5070: table.LC_prior_option {
5071: width: 100%;
5072: border-collapse: collapse;
5073: }
1.528 albertel 5074: table.LC_prior_rank, table.LC_prior_match {
5075: border-collapse: collapse;
5076: }
5077: table.LC_prior_option tr td,
5078: table.LC_prior_rank tr td,
5079: table.LC_prior_match tr td {
1.524 albertel 5080: border: 1px solid #000000;
1.515 albertel 5081: }
5082:
1.519 raeburn 5083: span.LC_nobreak {
1.544 albertel 5084: white-space: nowrap;
1.519 raeburn 5085: }
5086:
1.576 raeburn 5087: span.LC_cusr_emph {
5088: font-style: italic;
5089: }
5090:
1.633 raeburn 5091: span.LC_cusr_subheading {
5092: font-weight: normal;
5093: font-size: 85%;
5094: }
5095:
1.545 albertel 5096: table.LC_docs_documents {
5097: background: #BBBBBB;
1.547 albertel 5098: border-width: 0px;
1.545 albertel 5099: border-collapse: collapse;
5100: }
5101:
5102: table.LC_docs_documents td.LC_docs_document {
5103: border: 2px solid black;
5104: padding: 4px;
5105: }
5106:
5107: .LC_docs_course_commands div {
5108: float: left;
5109: border: 4px solid #AAAAAA;
5110: padding: 4px;
5111: background: #DDDDCC;
5112: }
5113:
5114: .LC_docs_entry_move {
5115: border: 0px;
5116: border-collapse: collapse;
1.544 albertel 5117: }
5118:
1.545 albertel 5119: .LC_docs_entry_move td {
5120: border: 2px solid #BBBBBB;
5121: background: #DDDDDD;
5122: }
5123:
5124: .LC_docs_editor td.LC_docs_entry_commands {
5125: background: #DDDDDD;
5126: font-size: x-small;
5127: }
1.544 albertel 5128: .LC_docs_copy {
1.545 albertel 5129: color: #000099;
1.544 albertel 5130: }
5131: .LC_docs_cut {
1.545 albertel 5132: color: #550044;
1.544 albertel 5133: }
5134: .LC_docs_rename {
1.545 albertel 5135: color: #009900;
1.544 albertel 5136: }
5137: .LC_docs_remove {
1.545 albertel 5138: color: #990000;
5139: }
5140:
1.547 albertel 5141: .LC_docs_reinit_warn,
5142: .LC_docs_ext_edit {
5143: font-size: x-small;
5144: }
5145:
1.545 albertel 5146: .LC_docs_editor td.LC_docs_entry_title,
5147: .LC_docs_editor td.LC_docs_entry_icon {
5148: background: #FFFFBB;
5149: }
5150: .LC_docs_editor td.LC_docs_entry_parameter {
5151: background: #BBBBFF;
5152: font-size: x-small;
5153: white-space: nowrap;
5154: }
5155:
5156: table.LC_docs_adddocs td,
5157: table.LC_docs_adddocs th {
5158: border: 1px solid #BBBBBB;
5159: padding: 4px;
5160: background: #DDDDDD;
1.543 albertel 5161: }
5162:
1.584 albertel 5163: table.LC_sty_begin {
5164: background: #BBFFBB;
5165: }
5166: table.LC_sty_end {
5167: background: #FFBBBB;
5168: }
5169:
1.589 raeburn 5170: table.LC_double_column {
5171: border-width: 0px;
5172: border-collapse: collapse;
5173: width: 100%;
5174: padding: 2px;
5175: }
5176:
5177: table.LC_double_column tr td.LC_left_col {
1.590 raeburn 5178: top: 2px;
1.589 raeburn 5179: left: 2px;
5180: width: 47%;
5181: vertical-align: top;
5182: }
5183:
5184: table.LC_double_column tr td.LC_right_col {
5185: top: 2px;
5186: right: 2px;
5187: width: 47%;
5188: vertical-align: top;
5189: }
5190:
1.594 raeburn 5191: span.LC_role_level {
5192: font-weight: bold;
5193: }
5194:
1.591 raeburn 5195: div.LC_left_float {
5196: float: left;
5197: padding-right: 5%;
1.597 albertel 5198: padding-bottom: 4px;
1.591 raeburn 5199: }
5200:
5201: div.LC_clear_float_header {
1.597 albertel 5202: padding-bottom: 2px;
1.591 raeburn 5203: }
5204:
5205: div.LC_clear_float_footer {
1.597 albertel 5206: padding-top: 10px;
1.591 raeburn 5207: clear: both;
5208: }
5209:
1.597 albertel 5210:
1.601 albertel 5211: div.LC_grade_select_mode {
1.604 albertel 5212: font-family: $sans;
1.601 albertel 5213: }
5214: div.LC_grade_select_mode div div {
5215: margin: 5px;
5216: }
5217: div.LC_grade_select_mode_selector {
5218: margin: 5px;
5219: float: left;
5220: }
5221: div.LC_grade_select_mode_selector_header {
5222: font: bold medium $sans;
5223: }
5224: div.LC_grade_select_mode_type {
5225: clear: left;
5226: }
5227:
1.597 albertel 5228: div.LC_grade_show_user {
5229: margin-top: 20px;
5230: border: 1px solid black;
5231: }
5232: div.LC_grade_user_name {
5233: background: #DDDDEE;
5234: border-bottom: 1px solid black;
5235: font: bold large $sans;
5236: }
5237: div.LC_grade_show_user_odd_row div.LC_grade_user_name {
5238: background: #DDEEDD;
5239: }
5240:
5241: div.LC_grade_show_problem,
5242: div.LC_grade_submissions,
5243: div.LC_grade_message_center,
5244: div.LC_grade_info_links,
5245: div.LC_grade_assign {
5246: margin: 5px;
5247: width: 99%;
5248: background: #FFFFFF;
5249: }
5250: div.LC_grade_show_problem_header,
5251: div.LC_grade_submissions_header,
5252: div.LC_grade_message_center_header,
5253: div.LC_grade_assign_header {
5254: font: bold large $sans;
5255: }
5256: div.LC_grade_show_problem_problem,
5257: div.LC_grade_submissions_body,
5258: div.LC_grade_message_center_body,
5259: div.LC_grade_assign_body {
5260: border: 1px solid black;
5261: width: 99%;
5262: background: #FFFFFF;
5263: }
1.598 albertel 5264: span.LC_grade_check_note {
5265: font: normal medium $sans;
5266: display: inline;
5267: position: absolute;
5268: right: 1em;
5269: }
1.597 albertel 5270:
1.613 albertel 5271: table.LC_scantron_action {
5272: width: 100%;
5273: }
5274: table.LC_scantron_action tr th {
5275: font: normal bold $sans;
5276: }
1.600 albertel 5277:
1.614 albertel 5278: div.LC_edit_problem_header,
5279: div.LC_edit_problem_footer {
1.600 albertel 5280: font: normal medium $sans;
1.602 albertel 5281: margin: 2px;
1.600 albertel 5282: }
5283: div.LC_edit_problem_header,
1.602 albertel 5284: div.LC_edit_problem_header div,
1.614 albertel 5285: div.LC_edit_problem_footer,
5286: div.LC_edit_problem_footer div,
1.602 albertel 5287: div.LC_edit_problem_editxml_header,
5288: div.LC_edit_problem_editxml_header div {
1.600 albertel 5289: margin-top: 5px;
5290: }
1.602 albertel 5291: div.LC_edit_problem_header_edit_row {
5292: background: $tabbg;
5293: padding: 3px;
5294: margin-bottom: 5px;
5295: }
1.600 albertel 5296: div.LC_edit_problem_header_title {
1.602 albertel 5297: font: larger bold $sans;
5298: background: $tabbg;
5299: padding: 3px;
5300: }
5301: table.LC_edit_problem_header_title {
5302: font: larger bold $sans;
5303: width: 100%;
5304: border-color: $pgbg;
5305: border-style: solid;
5306: border-width: $border;
5307:
1.600 albertel 5308: background: $tabbg;
1.602 albertel 5309: border-collapse: collapse;
5310: padding: 0px
5311: }
5312:
5313: div.LC_edit_problem_discards {
5314: float: left;
5315: padding-bottom: 5px;
5316: }
5317: div.LC_edit_problem_saves {
5318: float: right;
5319: padding-bottom: 5px;
1.600 albertel 5320: }
5321: hr.LC_edit_problem_divide {
1.602 albertel 5322: clear: both;
1.600 albertel 5323: color: $tabbg;
5324: background-color: $tabbg;
5325: height: 3px;
5326: border: 0px;
5327: }
1.343 albertel 5328: END
5329: }
5330:
1.306 albertel 5331: =pod
5332:
5333: =item * &headtag()
5334:
5335: Returns a uniform footer for LON-CAPA web pages.
5336:
1.307 albertel 5337: Inputs: $title - optional title for the head
5338: $head_extra - optional extra HTML to put inside the <head>
1.315 albertel 5339: $args - optional arguments
1.319 albertel 5340: force_register - if is true call registerurl so the remote is
5341: informed
1.415 albertel 5342: redirect -> array ref of
5343: 1- seconds before redirect occurs
5344: 2- url to redirect to
5345: 3- whether the side effect should occur
1.315 albertel 5346: (side effect of setting
5347: $env{'internal.head.redirect'} to the url
5348: redirected too)
1.352 albertel 5349: domain -> force to color decorate a page for a specific
5350: domain
5351: function -> force usage of a specific rolish color scheme
5352: bgcolor -> override the default page bgcolor
1.460 albertel 5353: no_auto_mt_title
5354: -> prevent &mt()ing the title arg
1.464 albertel 5355:
1.306 albertel 5356: =cut
5357:
5358: sub headtag {
1.313 albertel 5359: my ($title,$head_extra,$args) = @_;
1.306 albertel 5360:
1.363 albertel 5361: my $function = $args->{'function'} || &get_users_function();
5362: my $domain = $args->{'domain'} || &determinedomain();
5363: my $bgcolor = $args->{'bgcolor'} || &designparm($function.'.pgbg',$domain);
1.418 albertel 5364: my $url = join(':',$env{'user.name'},$env{'user.domain'},
1.458 albertel 5365: $Apache::lonnet::perlvar{'lonVersion'},
1.531 albertel 5366: #time(),
1.418 albertel 5367: $env{'environment.color.timestamp'},
1.363 albertel 5368: $function,$domain,$bgcolor);
5369:
1.369 www 5370: $url = '/adm/css/'.&escape($url).'.css';
1.363 albertel 5371:
1.308 albertel 5372: my $result =
5373: '<head>'.
1.461 albertel 5374: &font_settings();
1.319 albertel 5375:
1.461 albertel 5376: if (!$args->{'frameset'}) {
5377: $result .= &Apache::lonhtmlcommon::htmlareaheaders();
5378: }
1.319 albertel 5379: if ($args->{'force_register'}) {
5380: $result .= &Apache::lonmenu::registerurl(1);
5381: }
1.436 albertel 5382: if (!$args->{'no_nav_bar'}
5383: && !$args->{'only_body'}
5384: && !$args->{'frameset'}) {
5385: $result .= &help_menu_js();
5386: }
1.319 albertel 5387:
1.314 albertel 5388: if (ref($args->{'redirect'})) {
1.414 albertel 5389: my ($time,$url,$inhibit_continue) = @{$args->{'redirect'}};
1.315 albertel 5390: $url = &Apache::lonenc::check_encrypt($url);
1.414 albertel 5391: if (!$inhibit_continue) {
5392: $env{'internal.head.redirect'} = $url;
5393: }
1.313 albertel 5394: $result.=<<ADDMETA
5395: <meta http-equiv="pragma" content="no-cache" />
1.344 albertel 5396: <meta http-equiv="Refresh" content="$time; url=$url" />
1.313 albertel 5397: ADDMETA
5398: }
1.306 albertel 5399: if (!defined($title)) {
5400: $title = 'The LearningOnline Network with CAPA';
5401: }
1.460 albertel 5402: if (!$args->{'no_auto_mt_title'}) { $title = &mt($title); }
5403: $result .= '<title> LON-CAPA '.$title.'</title>'
1.414 albertel 5404: .'<link rel="stylesheet" type="text/css" href="'.$url.'" />'
5405: .$head_extra;
1.306 albertel 5406: return $result;
5407: }
5408:
5409: =pod
5410:
1.340 albertel 5411: =item * &font_settings()
5412:
5413: Returns neccessary <meta> to set the proper encoding
5414:
5415: Inputs: none
5416:
5417: =cut
5418:
5419: sub font_settings {
5420: my $headerstring='';
1.647 www 5421: if (!$env{'browser.mathml'} && $env{'browser.unicode'}) {
1.340 albertel 5422: $headerstring.=
5423: '<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />';
5424: }
5425: return $headerstring;
5426: }
5427:
1.341 albertel 5428: =pod
5429:
5430: =item * &xml_begin()
5431:
5432: Returns the needed doctype and <html>
5433:
5434: Inputs: none
5435:
5436: =cut
5437:
5438: sub xml_begin {
5439: my $output='';
5440:
1.592 albertel 5441: if ($env{'internal.start_page'}==1) {
5442: &Apache::lonhtmlcommon::init_htmlareafields();
5443: }
1.342 albertel 5444:
1.341 albertel 5445: if ($env{'browser.mathml'}) {
5446: $output='<?xml version="1.0"?>'
5447: #.'<?xml-stylesheet type="text/css" href="/adm/MathML/mathml.css"?>'."\n"
5448: # .'<!DOCTYPE html SYSTEM "/adm/MathML/mathml.dtd" '
5449:
5450: # .'<!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">] >'
5451: .'<!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">'
5452: .'<html xmlns:math="http://www.w3.org/1998/Math/MathML" '
5453: .'xmlns="http://www.w3.org/1999/xhtml">';
5454: } else {
5455: $output='<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"><html>';
5456: }
5457: return $output;
5458: }
1.340 albertel 5459:
5460: =pod
5461:
1.306 albertel 5462: =item * &endheadtag()
5463:
5464: Returns a uniform </head> for LON-CAPA web pages.
5465:
5466: Inputs: none
5467:
5468: =cut
5469:
5470: sub endheadtag {
5471: return '</head>';
5472: }
5473:
5474: =pod
5475:
5476: =item * &head()
5477:
5478: Returns a uniform complete <head>..</head> section for LON-CAPA web pages.
5479:
1.648 raeburn 5480: Inputs:
5481:
5482: =over 4
5483:
5484: $title - optional title for the page
5485:
5486: $head_extra - optional extra HTML to put inside the <head>
5487:
5488: =back
1.405 albertel 5489:
1.306 albertel 5490: =cut
5491:
5492: sub head {
1.325 albertel 5493: my ($title,$head_extra,$args) = @_;
5494: return &headtag($title,$head_extra,$args).&endheadtag();
1.306 albertel 5495: }
5496:
5497: =pod
5498:
5499: =item * &start_page()
5500:
5501: Returns a complete <html> .. <body> section for LON-CAPA web pages.
5502:
1.648 raeburn 5503: Inputs:
5504:
5505: =over 4
5506:
5507: $title - optional title for the page
5508:
5509: $head_extra - optional extra HTML to incude inside the <head>
5510:
5511: $args - additional optional args supported are:
5512:
5513: =over 8
5514:
5515: only_body -> is true will set &bodytag() onlybodytag
1.317 albertel 5516: arg on
1.648 raeburn 5517: no_nav_bar -> is true will set &bodytag() notopbar arg on
5518: add_entries -> additional attributes to add to the <body>
5519: domain -> force to color decorate a page for a
1.317 albertel 5520: specific domain
1.648 raeburn 5521: function -> force usage of a specific rolish color
1.317 albertel 5522: scheme
1.648 raeburn 5523: redirect -> see &headtag()
5524: bgcolor -> override the default page bg color
5525: js_ready -> return a string ready for being used in
1.317 albertel 5526: a javascript writeln
1.648 raeburn 5527: html_encode -> return a string ready for being used in
1.320 albertel 5528: a html attribute
1.648 raeburn 5529: force_register -> if is true will turn on the &bodytag()
1.317 albertel 5530: $forcereg arg
1.648 raeburn 5531: body_title -> alternate text to use instead of $title
1.326 albertel 5532: in the title box that appears, this text
5533: is not auto translated like the $title is
1.648 raeburn 5534: frameset -> if true will start with a <frameset>
1.330 albertel 5535: rather than <body>
1.648 raeburn 5536: no_title -> if true the title bar won't be shown
5537: skip_phases -> hash ref of
1.338 albertel 5538: head -> skip the <html><head> generation
5539: body -> skip all <body> generation
1.648 raeburn 5540: no_inline_link -> if true and in remote mode, don't show the
1.361 albertel 5541: 'Switch To Inline Menu' link
1.648 raeburn 5542: no_auto_mt_title -> prevent &mt()ing the title arg
5543: inherit_jsmath -> when creating popup window in a page,
5544: should it have jsmath forced on by the
5545: current page
1.361 albertel 5546:
1.648 raeburn 5547: =back
1.460 albertel 5548:
1.648 raeburn 5549: =back
1.562 albertel 5550:
1.306 albertel 5551: =cut
5552:
5553: sub start_page {
1.309 albertel 5554: my ($title,$head_extra,$args) = @_;
1.318 albertel 5555: #&Apache::lonnet::logthis("start_page ".join(':',caller(0)));
1.313 albertel 5556: my %head_args;
1.352 albertel 5557: foreach my $arg ('redirect','force_register','domain','function',
1.460 albertel 5558: 'bgcolor','frameset','no_nav_bar','only_body',
5559: 'no_auto_mt_title') {
1.319 albertel 5560: if (defined($args->{$arg})) {
1.324 raeburn 5561: $head_args{$arg} = $args->{$arg};
1.319 albertel 5562: }
1.313 albertel 5563: }
1.319 albertel 5564:
1.315 albertel 5565: $env{'internal.start_page'}++;
1.338 albertel 5566: my $result;
5567: if (! exists($args->{'skip_phases'}{'head'}) ) {
5568: $result.=
1.341 albertel 5569: &xml_begin().
1.338 albertel 5570: &headtag($title,$head_extra,\%head_args).&endheadtag();
5571: }
5572:
5573: if (! exists($args->{'skip_phases'}{'body'}) ) {
5574: if ($args->{'frameset'}) {
5575: my $attr_string = &make_attr_string($args->{'force_register'},
5576: $args->{'add_entries'});
5577: $result .= "\n<frameset $attr_string>\n";
5578: } else {
5579: $result .=
5580: &bodytag($title,
5581: $args->{'function'}, $args->{'add_entries'},
5582: $args->{'only_body'}, $args->{'domain'},
5583: $args->{'force_register'}, $args->{'body_title'},
5584: $args->{'no_nav_bar'}, $args->{'bgcolor'},
1.460 albertel 5585: $args->{'no_title'}, $args->{'no_inline_link'},
5586: $args);
1.338 albertel 5587: }
1.330 albertel 5588: }
1.338 albertel 5589:
1.315 albertel 5590: if ($args->{'js_ready'}) {
1.317 albertel 5591: $result = &js_ready($result);
1.315 albertel 5592: }
1.320 albertel 5593: if ($args->{'html_encode'}) {
5594: $result = &html_encode($result);
5595: }
1.315 albertel 5596: return $result;
1.306 albertel 5597: }
5598:
1.330 albertel 5599:
1.306 albertel 5600: =pod
5601:
5602: =item * &head()
5603:
5604: Returns a complete </body></html> section for LON-CAPA web pages.
5605:
1.315 albertel 5606: Inputs: $args - additional optional args supported are:
5607: js_ready -> return a string ready for being used in
5608: a javascript writeln
1.320 albertel 5609: html_encode -> return a string ready for being used in
5610: a html attribute
1.330 albertel 5611: frameset -> if true will start with a <frameset>
5612: rather than <body>
1.493 albertel 5613: dicsussion -> if true will get discussion from
5614: lonxml::xmlend
5615: (you can pass the target and parser arguments
5616: through optional 'target' and 'parser' args
5617: to this routine)
1.306 albertel 5618:
5619: =cut
5620:
5621: sub end_page {
1.315 albertel 5622: my ($args) = @_;
5623: $env{'internal.end_page'}++;
1.330 albertel 5624: my $result;
1.335 albertel 5625: if ($args->{'discussion'}) {
5626: my ($target,$parser);
5627: if (ref($args->{'discussion'})) {
5628: ($target,$parser) =($args->{'discussion'}{'target'},
5629: $args->{'discussion'}{'parser'});
5630: }
5631: $result .= &Apache::lonxml::xmlend($target,$parser);
5632: }
5633:
1.330 albertel 5634: if ($args->{'frameset'}) {
5635: $result .= '</frameset>';
5636: } else {
1.635 raeburn 5637: $result .= &endbodytag($args);
1.330 albertel 5638: }
5639: $result .= "\n</html>";
5640:
1.315 albertel 5641: if ($args->{'js_ready'}) {
1.317 albertel 5642: $result = &js_ready($result);
1.315 albertel 5643: }
1.335 albertel 5644:
1.320 albertel 5645: if ($args->{'html_encode'}) {
5646: $result = &html_encode($result);
5647: }
1.335 albertel 5648:
1.315 albertel 5649: return $result;
5650: }
5651:
1.320 albertel 5652: sub html_encode {
5653: my ($result) = @_;
5654:
1.322 albertel 5655: $result = &HTML::Entities::encode($result,'<>&"');
1.320 albertel 5656:
5657: return $result;
5658: }
1.317 albertel 5659: sub js_ready {
5660: my ($result) = @_;
5661:
1.323 albertel 5662: $result =~ s/[\n\r]/ /xmsg;
5663: $result =~ s/\\/\\\\/xmsg;
5664: $result =~ s/'/\\'/xmsg;
1.372 albertel 5665: $result =~ s{</}{<\\/}xmsg;
1.317 albertel 5666:
5667: return $result;
5668: }
5669:
1.315 albertel 5670: sub validate_page {
5671: if ( exists($env{'internal.start_page'})
1.316 albertel 5672: && $env{'internal.start_page'} > 1) {
5673: &Apache::lonnet::logthis('start_page called multiple times '.
1.318 albertel 5674: $env{'internal.start_page'}.' '.
1.316 albertel 5675: $ENV{'request.filename'});
1.315 albertel 5676: }
5677: if ( exists($env{'internal.end_page'})
1.316 albertel 5678: && $env{'internal.end_page'} > 1) {
5679: &Apache::lonnet::logthis('end_page called multiple times '.
1.318 albertel 5680: $env{'internal.end_page'}.' '.
1.316 albertel 5681: $env{'request.filename'});
1.315 albertel 5682: }
5683: if ( exists($env{'internal.start_page'})
5684: && ! exists($env{'internal.end_page'})) {
1.316 albertel 5685: &Apache::lonnet::logthis('start_page called without end_page '.
5686: $env{'request.filename'});
1.315 albertel 5687: }
5688: if ( ! exists($env{'internal.start_page'})
5689: && exists($env{'internal.end_page'})) {
1.316 albertel 5690: &Apache::lonnet::logthis('end_page called without start_page'.
5691: $env{'request.filename'});
1.315 albertel 5692: }
1.306 albertel 5693: }
1.315 albertel 5694:
1.318 albertel 5695: sub simple_error_page {
5696: my ($r,$title,$msg) = @_;
5697: my $page =
5698: &Apache::loncommon::start_page($title).
5699: &mt($msg).
5700: &Apache::loncommon::end_page();
5701: if (ref($r)) {
5702: $r->print($page);
1.327 albertel 5703: return;
1.318 albertel 5704: }
5705: return $page;
5706: }
1.347 albertel 5707:
5708: {
1.610 albertel 5709: my @row_count;
1.347 albertel 5710: sub start_data_table {
1.422 albertel 5711: my ($add_class) = @_;
5712: my $css_class = (join(' ','LC_data_table',$add_class));
1.610 albertel 5713: unshift(@row_count,0);
1.422 albertel 5714: return '<table class="'.$css_class.'">'."\n";
1.347 albertel 5715: }
5716:
5717: sub end_data_table {
1.610 albertel 5718: shift(@row_count);
1.389 albertel 5719: return '</table>'."\n";;
1.347 albertel 5720: }
5721:
5722: sub start_data_table_row {
1.422 albertel 5723: my ($add_class) = @_;
1.610 albertel 5724: $row_count[0]++;
5725: my $css_class = ($row_count[0] % 2)?'LC_odd_row':'LC_even_row';
1.428 albertel 5726: $css_class = (join(' ',$css_class,$add_class));
1.422 albertel 5727: return '<tr class="'.$css_class.'">'."\n";;
1.347 albertel 5728: }
1.471 banghart 5729:
5730: sub continue_data_table_row {
5731: my ($add_class) = @_;
1.610 albertel 5732: my $css_class = ($row_count[0] % 2)?'LC_odd_row':'LC_even_row';
1.471 banghart 5733: $css_class = (join(' ',$css_class,$add_class));
5734: return '<tr class="'.$css_class.'">'."\n";;
5735: }
1.347 albertel 5736:
5737: sub end_data_table_row {
1.389 albertel 5738: return '</tr>'."\n";;
1.347 albertel 5739: }
1.367 www 5740:
1.421 albertel 5741: sub start_data_table_empty_row {
1.610 albertel 5742: $row_count[0]++;
1.421 albertel 5743: return '<tr class="LC_empty_row" >'."\n";;
5744: }
5745:
5746: sub end_data_table_empty_row {
5747: return '</tr>'."\n";;
5748: }
5749:
1.367 www 5750: sub start_data_table_header_row {
1.389 albertel 5751: return '<tr class="LC_header_row">'."\n";;
1.367 www 5752: }
5753:
5754: sub end_data_table_header_row {
1.389 albertel 5755: return '</tr>'."\n";;
1.367 www 5756: }
1.347 albertel 5757: }
5758:
1.548 albertel 5759: =pod
5760:
5761: =item * &inhibit_menu_check($arg)
5762:
5763: Checks for a inhibitmenu state and generates output to preserve it
5764:
5765: Inputs: $arg - can be any of
5766: - undef - in which case the return value is a string
5767: to add into arguments list of a uri
5768: - 'input' - in which case the return value is a HTML
5769: <form> <input> field of type hidden to
5770: preserve the value
5771: - a url - in which case the return value is the url with
5772: the neccesary cgi args added to preserve the
5773: inhibitmenu state
5774: - a ref to a url - no return value, but the string is
5775: updated to include the neccessary cgi
5776: args to preserve the inhibitmenu state
5777:
5778: =cut
5779:
5780: sub inhibit_menu_check {
5781: my ($arg) = @_;
5782: &get_unprocessed_cgi($ENV{'QUERY_STRING'}, ['inhibitmenu']);
5783: if ($arg eq 'input') {
5784: if ($env{'form.inhibitmenu'}) {
5785: return '<input type="hidden" name="inhibitmenu" value="'.$env{'form.inhibitmenu'}.'" />';
5786: } else {
5787: return
5788: }
5789: }
5790: if ($env{'form.inhibitmenu'}) {
5791: if (ref($arg)) {
5792: $$arg .= '?inhibitmenu='.$env{'form.inhibitmenu'};
5793: } elsif ($arg eq '') {
5794: $arg .= 'inhibitmenu='.$env{'form.inhibitmenu'};
5795: } else {
5796: $arg .= '?inhibitmenu='.$env{'form.inhibitmenu'};
5797: }
5798: }
5799: if (!ref($arg)) {
5800: return $arg;
5801: }
5802: }
5803:
1.251 albertel 5804: ###############################################
1.182 matthew 5805:
5806: =pod
5807:
1.549 albertel 5808: =back
5809:
5810: =head1 User Information Routines
5811:
5812: =over 4
5813:
1.405 albertel 5814: =item * &get_users_function()
1.182 matthew 5815:
5816: Used by &bodytag to determine the current users primary role.
5817: Returns either 'student','coordinator','admin', or 'author'.
5818:
5819: =cut
5820:
5821: ###############################################
5822: sub get_users_function {
5823: my $function = 'student';
1.258 albertel 5824: if ($env{'request.role'}=~/^(cc|in|ta|ep)/) {
1.182 matthew 5825: $function='coordinator';
5826: }
1.258 albertel 5827: if ($env{'request.role'}=~/^(su|dc|ad|li)/) {
1.182 matthew 5828: $function='admin';
5829: }
1.258 albertel 5830: if (($env{'request.role'}=~/^(au|ca)/) ||
1.182 matthew 5831: ($ENV{'REQUEST_URI'}=~/^(\/priv|\~)/)) {
5832: $function='author';
5833: }
5834: return $function;
1.54 www 5835: }
1.99 www 5836:
5837: ###############################################
5838:
1.233 raeburn 5839: =pod
5840:
1.542 raeburn 5841: =item * &check_user_status()
1.274 raeburn 5842:
5843: Determines current status of supplied role for a
5844: specific user. Roles can be active, previous or future.
5845:
5846: Inputs:
5847: user's domain, user's username, course's domain,
1.375 raeburn 5848: course's number, optional section ID.
1.274 raeburn 5849:
5850: Outputs:
5851: role status: active, previous or future.
5852:
5853: =cut
5854:
5855: sub check_user_status {
1.412 raeburn 5856: my ($udom,$uname,$cdom,$crs,$role,$sec) = @_;
1.274 raeburn 5857: my %userinfo = &Apache::lonnet::dump('roles',$udom,$uname);
5858: my @uroles = keys %userinfo;
5859: my $srchstr;
5860: my $active_chk = 'none';
1.412 raeburn 5861: my $now = time;
1.274 raeburn 5862: if (@uroles > 0) {
1.412 raeburn 5863: if (($role eq 'cc') || ($sec eq '') || (!defined($sec))) {
1.274 raeburn 5864: $srchstr = '/'.$cdom.'/'.$crs.'_'.$role;
5865: } else {
1.412 raeburn 5866: $srchstr = '/'.$cdom.'/'.$crs.'/'.$sec.'_'.$role;
5867: }
5868: if (grep/^\Q$srchstr\E$/,@uroles) {
1.274 raeburn 5869: my $role_end = 0;
5870: my $role_start = 0;
5871: $active_chk = 'active';
1.412 raeburn 5872: if ($userinfo{$srchstr} =~ m/^\Q$role\E_(\d+)/) {
5873: $role_end = $1;
5874: if ($userinfo{$srchstr} =~ m/^\Q$role\E_\Q$role_end\E_(\d+)$/) {
5875: $role_start = $1;
1.274 raeburn 5876: }
5877: }
5878: if ($role_start > 0) {
1.412 raeburn 5879: if ($now < $role_start) {
1.274 raeburn 5880: $active_chk = 'future';
5881: }
5882: }
5883: if ($role_end > 0) {
1.412 raeburn 5884: if ($now > $role_end) {
1.274 raeburn 5885: $active_chk = 'previous';
5886: }
5887: }
5888: }
5889: }
5890: return $active_chk;
5891: }
5892:
5893: ###############################################
5894:
5895: =pod
5896:
1.405 albertel 5897: =item * &get_sections()
1.233 raeburn 5898:
5899: Determines all the sections for a course including
5900: sections with students and sections containing other roles.
1.419 raeburn 5901: Incoming parameters:
5902:
5903: 1. domain
5904: 2. course number
5905: 3. reference to array containing roles for which sections should
5906: be gathered (optional).
5907: 4. reference to array containing status types for which sections
5908: should be gathered (optional).
5909:
5910: If the third argument is undefined, sections are gathered for any role.
5911: If the fourth argument is undefined, sections are gathered for any status.
5912: Permissible values are 'active' or 'future' or 'previous'.
1.233 raeburn 5913:
1.374 raeburn 5914: Returns section hash (keys are section IDs, values are
5915: number of users in each section), subject to the
1.419 raeburn 5916: optional roles filter, optional status filter
1.233 raeburn 5917:
5918: =cut
5919:
5920: ###############################################
5921: sub get_sections {
1.419 raeburn 5922: my ($cdom,$cnum,$possible_roles,$possible_status) = @_;
1.366 albertel 5923: if (!defined($cdom) || !defined($cnum)) {
5924: my $cid = $env{'request.course.id'};
5925:
5926: return if (!defined($cid));
5927:
5928: $cdom = $env{'course.'.$cid.'.domain'};
5929: $cnum = $env{'course.'.$cid.'.num'};
5930: }
5931:
5932: my %sectioncount;
1.419 raeburn 5933: my $now = time;
1.240 albertel 5934:
1.366 albertel 5935: if (!defined($possible_roles) || (grep(/^st$/,@$possible_roles))) {
1.276 albertel 5936: my ($classlist) = &Apache::loncoursedata::get_classlist($cdom,$cnum);
1.240 albertel 5937: my $sec_index = &Apache::loncoursedata::CL_SECTION();
5938: my $status_index = &Apache::loncoursedata::CL_STATUS();
1.419 raeburn 5939: my $start_index = &Apache::loncoursedata::CL_START();
5940: my $end_index = &Apache::loncoursedata::CL_END();
5941: my $status;
1.366 albertel 5942: while (my ($student,$data) = each(%$classlist)) {
1.419 raeburn 5943: my ($section,$stu_status,$start,$end) = ($data->[$sec_index],
5944: $data->[$status_index],
5945: $data->[$start_index],
5946: $data->[$end_index]);
5947: if ($stu_status eq 'Active') {
5948: $status = 'active';
5949: } elsif ($end < $now) {
5950: $status = 'previous';
5951: } elsif ($start > $now) {
5952: $status = 'future';
5953: }
5954: if ($section ne '-1' && $section !~ /^\s*$/) {
5955: if ((!defined($possible_status)) || (($status ne '') &&
5956: (grep/^\Q$status\E$/,@{$possible_status}))) {
5957: $sectioncount{$section}++;
5958: }
1.240 albertel 5959: }
5960: }
5961: }
5962: my %courseroles = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum);
5963: foreach my $user (sort(keys(%courseroles))) {
5964: if ($user !~ /^(\w{2})/) { next; }
5965: my ($role) = ($user =~ /^(\w{2})/);
5966: if ($possible_roles && !(grep(/^$role$/,@$possible_roles))) { next; }
1.419 raeburn 5967: my ($section,$status);
1.240 albertel 5968: if ($role eq 'cr' &&
5969: $user =~ m-^$role/[^/]*/[^/]*/[^/]*:[^:]*:[^:]*:(\w+)-) {
5970: $section=$1;
5971: }
5972: if ($user =~ /^$role:[^:]*:[^:]*:(\w+)/) { $section=$1; }
5973: if (!defined($section) || $section eq '-1') { next; }
1.419 raeburn 5974: my ($end,$start) = ($courseroles{$user} =~ /^([^:]*):([^:]*)$/);
5975: if ($end == -1 && $start == -1) {
5976: next; #deleted role
5977: }
5978: if (!defined($possible_status)) {
5979: $sectioncount{$section}++;
5980: } else {
5981: if ((!$end || $end >= $now) && (!$start || $start <= $now)) {
5982: $status = 'active';
5983: } elsif ($end < $now) {
5984: $status = 'future';
5985: } elsif ($start > $now) {
5986: $status = 'previous';
5987: }
5988: if (($status ne '') && (grep/^\Q$status\E$/,@{$possible_status})) {
5989: $sectioncount{$section}++;
5990: }
5991: }
1.233 raeburn 5992: }
1.366 albertel 5993: return %sectioncount;
1.233 raeburn 5994: }
5995:
1.274 raeburn 5996: ###############################################
1.294 raeburn 5997:
5998: =pod
1.405 albertel 5999:
6000: =item * &get_course_users()
6001:
1.275 raeburn 6002: Retrieves usernames:domains for users in the specified course
6003: with specific role(s), and access status.
6004:
6005: Incoming parameters:
1.277 albertel 6006: 1. course domain
6007: 2. course number
6008: 3. access status: users must have - either active,
1.275 raeburn 6009: previous, future, or all.
1.277 albertel 6010: 4. reference to array of permissible roles
1.288 raeburn 6011: 5. reference to array of section restrictions (optional)
6012: 6. reference to results object (hash of hashes).
6013: 7. reference to optional userdata hash
1.609 raeburn 6014: 8. reference to optional statushash
1.630 raeburn 6015: 9. flag if privileged users (except those set to unhide in
6016: course settings) should be excluded
1.609 raeburn 6017: Keys of top level results hash are roles.
1.275 raeburn 6018: Keys of inner hashes are username:domain, with
6019: values set to access type.
1.288 raeburn 6020: Optional userdata hash returns an array with arguments in the
6021: same order as loncoursedata::get_classlist() for student data.
6022:
1.609 raeburn 6023: Optional statushash returns
6024:
1.288 raeburn 6025: Entries for end, start, section and status are blank because
6026: of the possibility of multiple values for non-student roles.
6027:
1.275 raeburn 6028: =cut
1.405 albertel 6029:
1.275 raeburn 6030: ###############################################
1.405 albertel 6031:
1.275 raeburn 6032: sub get_course_users {
1.630 raeburn 6033: my ($cdom,$cnum,$types,$roles,$sections,$users,$userdata,$statushash,$hidepriv) = @_;
1.288 raeburn 6034: my %idx = ();
1.419 raeburn 6035: my %seclists;
1.288 raeburn 6036:
6037: $idx{udom} = &Apache::loncoursedata::CL_SDOM();
6038: $idx{uname} = &Apache::loncoursedata::CL_SNAME();
6039: $idx{end} = &Apache::loncoursedata::CL_END();
6040: $idx{start} = &Apache::loncoursedata::CL_START();
6041: $idx{id} = &Apache::loncoursedata::CL_ID();
6042: $idx{section} = &Apache::loncoursedata::CL_SECTION();
6043: $idx{fullname} = &Apache::loncoursedata::CL_FULLNAME();
6044: $idx{status} = &Apache::loncoursedata::CL_STATUS();
6045:
1.290 albertel 6046: if (grep(/^st$/,@{$roles})) {
1.276 albertel 6047: my ($classlist,$keylist)=&Apache::loncoursedata::get_classlist($cdom,$cnum);
1.278 raeburn 6048: my $now = time;
1.277 albertel 6049: foreach my $student (keys(%{$classlist})) {
1.288 raeburn 6050: my $match = 0;
1.412 raeburn 6051: my $secmatch = 0;
1.419 raeburn 6052: my $section = $$classlist{$student}[$idx{section}];
1.609 raeburn 6053: my $status = $$classlist{$student}[$idx{status}];
1.419 raeburn 6054: if ($section eq '') {
6055: $section = 'none';
6056: }
1.291 albertel 6057: if ((ref($sections) eq 'ARRAY') && (@{$sections} > 0)) {
1.420 albertel 6058: if (grep(/^all$/,@{$sections})) {
1.412 raeburn 6059: $secmatch = 1;
6060: } elsif ($$classlist{$student}[$idx{section}] eq '') {
1.420 albertel 6061: if (grep(/^none$/,@{$sections})) {
1.412 raeburn 6062: $secmatch = 1;
6063: }
6064: } else {
1.419 raeburn 6065: if (grep(/^\Q$section\E$/,@{$sections})) {
1.412 raeburn 6066: $secmatch = 1;
6067: }
1.290 albertel 6068: }
1.412 raeburn 6069: if (!$secmatch) {
6070: next;
6071: }
1.419 raeburn 6072: }
1.275 raeburn 6073: if (defined($$types{'active'})) {
1.288 raeburn 6074: if ($$classlist{$student}[$idx{status}] eq 'Active') {
1.275 raeburn 6075: push(@{$$users{st}{$student}},'active');
1.288 raeburn 6076: $match = 1;
1.275 raeburn 6077: }
6078: }
6079: if (defined($$types{'previous'})) {
1.609 raeburn 6080: if ($$classlist{$student}[$idx{status}] eq 'Expired') {
1.275 raeburn 6081: push(@{$$users{st}{$student}},'previous');
1.288 raeburn 6082: $match = 1;
1.275 raeburn 6083: }
6084: }
6085: if (defined($$types{'future'})) {
1.609 raeburn 6086: if ($$classlist{$student}[$idx{status}] eq 'Future') {
1.275 raeburn 6087: push(@{$$users{st}{$student}},'future');
1.288 raeburn 6088: $match = 1;
1.275 raeburn 6089: }
6090: }
1.609 raeburn 6091: if ($match) {
6092: push(@{$seclists{$student}},$section);
6093: if (ref($userdata) eq 'HASH') {
6094: $$userdata{$student} = $$classlist{$student};
6095: }
6096: if (ref($statushash) eq 'HASH') {
6097: $statushash->{$student}{'st'}{$section} = $status;
6098: }
1.288 raeburn 6099: }
1.275 raeburn 6100: }
6101: }
1.412 raeburn 6102: if ((@{$roles} > 1) || ((@{$roles} == 1) && ($$roles[0] ne "st"))) {
1.439 raeburn 6103: my %coursepersonnel = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum);
6104: my $now = time;
1.609 raeburn 6105: my %displaystatus = ( previous => 'Expired',
6106: active => 'Active',
6107: future => 'Future',
6108: );
1.630 raeburn 6109: my %nothide;
6110: if ($hidepriv) {
6111: my %coursehash=&Apache::lonnet::coursedescription($cdom.'_'.$cnum);
6112: foreach my $user (split(/\s*\,\s*/,$coursehash{'nothideprivileged'})) {
6113: if ($user !~ /:/) {
6114: $nothide{join(':',split(/[\@]/,$user))}=1;
6115: } else {
6116: $nothide{$user} = 1;
6117: }
6118: }
6119: }
1.439 raeburn 6120: foreach my $person (sort(keys(%coursepersonnel))) {
1.288 raeburn 6121: my $match = 0;
1.412 raeburn 6122: my $secmatch = 0;
1.439 raeburn 6123: my $status;
1.412 raeburn 6124: my ($role,$user,$usec) = ($person =~ /^([^:]*):([^:]+:[^:]+):([^:]*)/);
1.275 raeburn 6125: $user =~ s/:$//;
1.439 raeburn 6126: my ($end,$start) = split(/:/,$coursepersonnel{$person});
6127: if ($end == -1 || $start == -1) {
6128: next;
6129: }
6130: if (($role) && ((grep(/^\Q$role\E$/,@{$roles})) ||
6131: (grep(/^cr$/,@{$roles}) && $role =~ /^cr\//))) {
1.412 raeburn 6132: my ($uname,$udom) = split(/:/,$user);
6133: if ((ref($sections) eq 'ARRAY') && (@{$sections} > 0)) {
1.420 albertel 6134: if (grep(/^all$/,@{$sections})) {
1.412 raeburn 6135: $secmatch = 1;
6136: } elsif ($usec eq '') {
1.420 albertel 6137: if (grep(/^none$/,@{$sections})) {
1.412 raeburn 6138: $secmatch = 1;
6139: }
6140: } else {
6141: if (grep(/^\Q$usec\E$/,@{$sections})) {
6142: $secmatch = 1;
6143: }
6144: }
6145: if (!$secmatch) {
6146: next;
6147: }
1.288 raeburn 6148: }
1.419 raeburn 6149: if ($usec eq '') {
6150: $usec = 'none';
6151: }
1.275 raeburn 6152: if ($uname ne '' && $udom ne '') {
1.630 raeburn 6153: if ($hidepriv) {
6154: if ((&Apache::lonnet::privileged($uname,$udom)) &&
6155: (!$nothide{$uname.':'.$udom})) {
6156: next;
6157: }
6158: }
1.503 raeburn 6159: if ($end > 0 && $end < $now) {
1.439 raeburn 6160: $status = 'previous';
6161: } elsif ($start > $now) {
6162: $status = 'future';
6163: } else {
6164: $status = 'active';
6165: }
1.277 albertel 6166: foreach my $type (keys(%{$types})) {
1.275 raeburn 6167: if ($status eq $type) {
1.420 albertel 6168: if (!grep(/^\Q$type\E$/,@{$$users{$role}{$user}})) {
1.419 raeburn 6169: push(@{$$users{$role}{$user}},$type);
6170: }
1.288 raeburn 6171: $match = 1;
6172: }
6173: }
1.419 raeburn 6174: if (($match) && (ref($userdata) eq 'HASH')) {
6175: if (!exists($$userdata{$uname.':'.$udom})) {
6176: &get_user_info($udom,$uname,\%idx,$userdata);
6177: }
1.420 albertel 6178: if (!grep(/^\Q$usec\E$/,@{$seclists{$uname.':'.$udom}})) {
1.419 raeburn 6179: push(@{$seclists{$uname.':'.$udom}},$usec);
6180: }
1.609 raeburn 6181: if (ref($statushash) eq 'HASH') {
6182: $statushash->{$uname.':'.$udom}{$role}{$usec} = $displaystatus{$status};
6183: }
1.275 raeburn 6184: }
6185: }
6186: }
6187: }
1.290 albertel 6188: if (grep(/^ow$/,@{$roles})) {
1.279 raeburn 6189: if ((defined($cdom)) && (defined($cnum))) {
6190: my %csettings = &Apache::lonnet::get('environment',['internal.courseowner'],$cdom,$cnum);
6191: if ( defined($csettings{'internal.courseowner'}) ) {
6192: my $owner = $csettings{'internal.courseowner'};
1.609 raeburn 6193: next if ($owner eq '');
6194: my ($ownername,$ownerdom);
6195: if ($owner =~ /^([^:]+):([^:]+)$/) {
6196: $ownername = $1;
6197: $ownerdom = $2;
6198: } else {
6199: $ownername = $owner;
6200: $ownerdom = $cdom;
6201: $owner = $ownername.':'.$ownerdom;
1.439 raeburn 6202: }
6203: @{$$users{'ow'}{$owner}} = 'any';
1.290 albertel 6204: if (defined($userdata) &&
1.609 raeburn 6205: !exists($$userdata{$owner})) {
6206: &get_user_info($ownerdom,$ownername,\%idx,$userdata);
6207: if (!grep(/^none$/,@{$seclists{$owner}})) {
6208: push(@{$seclists{$owner}},'none');
6209: }
6210: if (ref($statushash) eq 'HASH') {
6211: $statushash->{$owner}{'ow'}{'none'} = 'Any';
1.419 raeburn 6212: }
1.290 albertel 6213: }
1.279 raeburn 6214: }
6215: }
6216: }
1.419 raeburn 6217: foreach my $user (keys(%seclists)) {
6218: @{$seclists{$user}} = (sort {$a <=> $b} @{$seclists{$user}});
6219: $$userdata{$user}[$idx{section}] = join(',',@{$seclists{$user}});
6220: }
1.275 raeburn 6221: }
6222: return;
6223: }
6224:
1.288 raeburn 6225: sub get_user_info {
6226: my ($udom,$uname,$idx,$userdata) = @_;
1.289 albertel 6227: $$userdata{$uname.':'.$udom}[$$idx{fullname}] =
6228: &plainname($uname,$udom,'lastname');
1.291 albertel 6229: $$userdata{$uname.':'.$udom}[$$idx{uname}] = $uname;
1.297 raeburn 6230: $$userdata{$uname.':'.$udom}[$$idx{udom}] = $udom;
1.609 raeburn 6231: my %idhash = &Apache::lonnet::idrget($udom,($uname));
6232: $$userdata{$uname.':'.$udom}[$$idx{id}] = $idhash{$uname};
1.288 raeburn 6233: return;
6234: }
1.275 raeburn 6235:
1.472 raeburn 6236: ###############################################
6237:
6238: =pod
6239:
6240: =item * &get_user_quota()
6241:
6242: Retrieves quota assigned for storage of portfolio files for a user
6243:
6244: Incoming parameters:
6245: 1. user's username
6246: 2. user's domain
6247:
6248: Returns:
1.536 raeburn 6249: 1. Disk quota (in Mb) assigned to student.
6250: 2. (Optional) Type of setting: custom or default
6251: (individually assigned or default for user's
6252: institutional status).
6253: 3. (Optional) - User's institutional status (e.g., faculty, staff
6254: or student - types as defined in localenroll::inst_usertypes
6255: for user's domain, which determines default quota for user.
6256: 4. (Optional) - Default quota which would apply to the user.
1.472 raeburn 6257:
6258: If a value has been stored in the user's environment,
1.536 raeburn 6259: it will return that, otherwise it returns the maximal default
6260: defined for the user's instituional status(es) in the domain.
1.472 raeburn 6261:
6262: =cut
6263:
6264: ###############################################
6265:
6266:
6267: sub get_user_quota {
6268: my ($uname,$udom) = @_;
1.536 raeburn 6269: my ($quota,$quotatype,$settingstatus,$defquota);
1.472 raeburn 6270: if (!defined($udom)) {
6271: $udom = $env{'user.domain'};
6272: }
6273: if (!defined($uname)) {
6274: $uname = $env{'user.name'};
6275: }
6276: if (($udom eq '' || $uname eq '') ||
6277: ($udom eq 'public') && ($uname eq 'public')) {
6278: $quota = 0;
1.536 raeburn 6279: $quotatype = 'default';
6280: $defquota = 0;
1.472 raeburn 6281: } else {
1.536 raeburn 6282: my $inststatus;
1.472 raeburn 6283: if ($udom eq $env{'user.domain'} && $uname eq $env{'user.name'}) {
6284: $quota = $env{'environment.portfolioquota'};
1.536 raeburn 6285: $inststatus = $env{'environment.inststatus'};
1.472 raeburn 6286: } else {
1.536 raeburn 6287: my %userenv =
6288: &Apache::lonnet::get('environment',['portfolioquota',
6289: 'inststatus'],$udom,$uname);
1.472 raeburn 6290: my ($tmp) = keys(%userenv);
6291: if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
6292: $quota = $userenv{'portfolioquota'};
1.536 raeburn 6293: $inststatus = $userenv{'inststatus'};
1.472 raeburn 6294: } else {
6295: undef(%userenv);
6296: }
6297: }
1.536 raeburn 6298: ($defquota,$settingstatus) = &default_quota($udom,$inststatus);
1.472 raeburn 6299: if ($quota eq '') {
1.536 raeburn 6300: $quota = $defquota;
6301: $quotatype = 'default';
6302: } else {
6303: $quotatype = 'custom';
1.472 raeburn 6304: }
6305: }
1.536 raeburn 6306: if (wantarray) {
6307: return ($quota,$quotatype,$settingstatus,$defquota);
6308: } else {
6309: return $quota;
6310: }
1.472 raeburn 6311: }
6312:
6313: ###############################################
6314:
6315: =pod
6316:
6317: =item * &default_quota()
6318:
1.536 raeburn 6319: Retrieves default quota assigned for storage of user portfolio files,
6320: given an (optional) user's institutional status.
1.472 raeburn 6321:
6322: Incoming parameters:
6323: 1. domain
1.536 raeburn 6324: 2. (Optional) institutional status(es). This is a : separated list of
6325: status types (e.g., faculty, staff, student etc.)
6326: which apply to the user for whom the default is being retrieved.
6327: If the institutional status string in undefined, the domain
6328: default quota will be returned.
1.472 raeburn 6329:
6330: Returns:
6331: 1. Default disk quota (in Mb) for user portfolios in the domain.
1.536 raeburn 6332: 2. (Optional) institutional type which determined the value of the
6333: default quota.
1.472 raeburn 6334:
6335: If a value has been stored in the domain's configuration db,
6336: it will return that, otherwise it returns 20 (for backwards
6337: compatibility with domains which have not set up a configuration
6338: db file; the original statically defined portfolio quota was 20 Mb).
6339:
1.536 raeburn 6340: If the user's status includes multiple types (e.g., staff and student),
6341: the largest default quota which applies to the user determines the
6342: default quota returned.
6343:
1.472 raeburn 6344: =cut
6345:
6346: ###############################################
6347:
6348:
6349: sub default_quota {
1.536 raeburn 6350: my ($udom,$inststatus) = @_;
6351: my ($defquota,$settingstatus);
6352: my %quotahash = &Apache::lonnet::get_dom('configuration',
1.622 raeburn 6353: ['quotas'],$udom);
6354: if (ref($quotahash{'quotas'}) eq 'HASH') {
1.536 raeburn 6355: if ($inststatus ne '') {
6356: my @statuses = split(/:/,$inststatus);
6357: foreach my $item (@statuses) {
1.622 raeburn 6358: if ($quotahash{'quotas'}{$item} ne '') {
1.536 raeburn 6359: if ($defquota eq '') {
1.622 raeburn 6360: $defquota = $quotahash{'quotas'}{$item};
1.536 raeburn 6361: $settingstatus = $item;
1.622 raeburn 6362: } elsif ($quotahash{'quotas'}{$item} > $defquota) {
6363: $defquota = $quotahash{'quotas'}{$item};
1.536 raeburn 6364: $settingstatus = $item;
6365: }
6366: }
6367: }
6368: }
6369: if ($defquota eq '') {
1.622 raeburn 6370: $defquota = $quotahash{'quotas'}{'default'};
1.536 raeburn 6371: $settingstatus = 'default';
6372: }
6373: } else {
6374: $settingstatus = 'default';
6375: $defquota = 20;
6376: }
6377: if (wantarray) {
6378: return ($defquota,$settingstatus);
1.472 raeburn 6379: } else {
1.536 raeburn 6380: return $defquota;
1.472 raeburn 6381: }
6382: }
6383:
1.384 raeburn 6384: sub get_secgrprole_info {
6385: my ($cdom,$cnum,$needroles,$type) = @_;
6386: my %sections_count = &get_sections($cdom,$cnum);
6387: my @sections = (sort {$a <=> $b} keys(%sections_count));
6388: my %curr_groups = &Apache::longroup::coursegroups($cdom,$cnum);
6389: my @groups = sort(keys(%curr_groups));
6390: my $allroles = [];
6391: my $rolehash;
6392: my $accesshash = {
6393: active => 'Currently has access',
6394: future => 'Will have future access',
6395: previous => 'Previously had access',
6396: };
6397: if ($needroles) {
6398: $rolehash = {'all' => 'all'};
1.385 albertel 6399: my %user_roles = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum);
6400: if (&Apache::lonnet::error(%user_roles)) {
6401: undef(%user_roles);
6402: }
6403: foreach my $item (keys(%user_roles)) {
1.384 raeburn 6404: my ($role)=split(/\:/,$item,2);
6405: if ($role eq 'cr') { next; }
6406: if ($role =~ /^cr/) {
6407: $$rolehash{$role} = (split('/',$role))[3];
6408: } else {
6409: $$rolehash{$role} = &Apache::lonnet::plaintext($role,$type);
6410: }
6411: }
6412: foreach my $key (sort(keys(%{$rolehash}))) {
6413: push(@{$allroles},$key);
6414: }
6415: push (@{$allroles},'st');
6416: $$rolehash{'st'} = &Apache::lonnet::plaintext('st',$type);
6417: }
6418: return (\@sections,\@groups,$allroles,$rolehash,$accesshash);
6419: }
6420:
1.555 raeburn 6421: sub user_picker {
1.627 raeburn 6422: my ($dom,$srch,$forcenewuser,$caller,$cancreate,$usertype) = @_;
1.555 raeburn 6423: my $currdom = $dom;
6424: my %curr_selected = (
6425: srchin => 'dom',
1.580 raeburn 6426: srchby => 'lastname',
1.555 raeburn 6427: );
6428: my $srchterm;
1.625 raeburn 6429: if ((ref($srch) eq 'HASH') && ($env{'form.origform'} ne 'crtusername')) {
1.555 raeburn 6430: if ($srch->{'srchby'} ne '') {
6431: $curr_selected{'srchby'} = $srch->{'srchby'};
6432: }
6433: if ($srch->{'srchin'} ne '') {
6434: $curr_selected{'srchin'} = $srch->{'srchin'};
6435: }
6436: if ($srch->{'srchtype'} ne '') {
6437: $curr_selected{'srchtype'} = $srch->{'srchtype'};
6438: }
6439: if ($srch->{'srchdomain'} ne '') {
6440: $currdom = $srch->{'srchdomain'};
6441: }
6442: $srchterm = $srch->{'srchterm'};
6443: }
6444: my %lt=&Apache::lonlocal::texthash(
1.573 raeburn 6445: 'usr' => 'Search criteria',
1.563 raeburn 6446: 'doma' => 'Domain/institution to search',
1.558 albertel 6447: 'uname' => 'username',
6448: 'lastname' => 'last name',
1.555 raeburn 6449: 'lastfirst' => 'last name, first name',
1.558 albertel 6450: 'crs' => 'in this course',
1.576 raeburn 6451: 'dom' => 'in selected LON-CAPA domain',
1.558 albertel 6452: 'alc' => 'all LON-CAPA',
1.573 raeburn 6453: 'instd' => 'in institutional directory for selected domain',
1.558 albertel 6454: 'exact' => 'is',
6455: 'contains' => 'contains',
1.569 raeburn 6456: 'begins' => 'begins with',
1.571 raeburn 6457: 'youm' => "You must include some text to search for.",
6458: 'thte' => "The text you are searching for must contain at least two characters when using a 'begins' type search.",
6459: 'thet' => "The text you are searching for must contain at least three characters when using a 'contains' type search.",
6460: 'yomc' => "You must choose a domain when using an institutional directory search.",
6461: 'ymcd' => "You must choose a domain when using a domain search.",
6462: 'whus' => "When using searching by last,first you must include a comma as separator between last name and first name.",
6463: 'whse' => "When searching by last,first you must include at least one character in the first name.",
6464: 'thfo' => "The following need to be corrected before the search can be run:",
1.555 raeburn 6465: );
1.563 raeburn 6466: my $domform = &select_dom_form($currdom,'srchdomain',1,1);
6467: my $srchinsel = ' <select name="srchin">';
1.555 raeburn 6468:
6469: my @srchins = ('crs','dom','alc','instd');
6470:
6471: foreach my $option (@srchins) {
6472: # FIXME 'alc' option unavailable until
6473: # loncreateuser::print_user_query_page()
6474: # has been completed.
6475: next if ($option eq 'alc');
6476: next if ($option eq 'crs' && !$env{'request.course.id'});
1.563 raeburn 6477: if ($curr_selected{'srchin'} eq $option) {
6478: $srchinsel .= '
6479: <option value="'.$option.'" selected="selected">'.$lt{$option}.'</option>';
6480: } else {
6481: $srchinsel .= '
6482: <option value="'.$option.'">'.$lt{$option}.'</option>';
6483: }
1.555 raeburn 6484: }
1.563 raeburn 6485: $srchinsel .= "\n </select>\n";
1.555 raeburn 6486:
6487: my $srchbysel = ' <select name="srchby">';
1.580 raeburn 6488: foreach my $option ('lastname','lastfirst','uname') {
1.555 raeburn 6489: if ($curr_selected{'srchby'} eq $option) {
6490: $srchbysel .= '
6491: <option value="'.$option.'" selected="selected">'.$lt{$option}.'</option>';
6492: } else {
6493: $srchbysel .= '
6494: <option value="'.$option.'">'.$lt{$option}.'</option>';
6495: }
6496: }
6497: $srchbysel .= "\n </select>\n";
6498:
6499: my $srchtypesel = ' <select name="srchtype">';
1.580 raeburn 6500: foreach my $option ('begins','contains','exact') {
1.555 raeburn 6501: if ($curr_selected{'srchtype'} eq $option) {
6502: $srchtypesel .= '
6503: <option value="'.$option.'" selected="selected">'.$lt{$option}.'</option>';
6504: } else {
6505: $srchtypesel .= '
6506: <option value="'.$option.'">'.$lt{$option}.'</option>';
6507: }
6508: }
6509: $srchtypesel .= "\n </select>\n";
6510:
1.558 albertel 6511: my ($newuserscript,$new_user_create);
1.556 raeburn 6512:
6513: if ($forcenewuser) {
1.576 raeburn 6514: if (ref($srch) eq 'HASH') {
6515: if ($srch->{'srchby'} eq 'uname' && $srch->{'srchtype'} eq 'exact' && $srch->{'srchin'} eq 'dom' && $srch->{'srchdomain'} eq $env{'request.role.domain'}) {
1.627 raeburn 6516: if ($cancreate) {
6517: $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>';
6518: } else {
6519: my $helplink = ' href="javascript:helpMenu('."'display'".')"';
6520: my %usertypetext = (
6521: official => 'institutional',
6522: unofficial => 'non-institutional',
6523: );
6524: $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 />';
6525: }
1.576 raeburn 6526: }
6527: }
6528:
1.556 raeburn 6529: $newuserscript = <<"ENDSCRIPT";
6530:
1.570 raeburn 6531: function setSearch(createnew,callingForm) {
1.556 raeburn 6532: if (createnew == 1) {
1.570 raeburn 6533: for (var i=0; i<callingForm.srchby.length; i++) {
6534: if (callingForm.srchby.options[i].value == 'uname') {
6535: callingForm.srchby.selectedIndex = i;
1.556 raeburn 6536: }
6537: }
1.570 raeburn 6538: for (var i=0; i<callingForm.srchin.length; i++) {
6539: if ( callingForm.srchin.options[i].value == 'dom') {
6540: callingForm.srchin.selectedIndex = i;
1.556 raeburn 6541: }
6542: }
1.570 raeburn 6543: for (var i=0; i<callingForm.srchtype.length; i++) {
6544: if (callingForm.srchtype.options[i].value == 'exact') {
6545: callingForm.srchtype.selectedIndex = i;
1.556 raeburn 6546: }
6547: }
1.570 raeburn 6548: for (var i=0; i<callingForm.srchdomain.length; i++) {
6549: if (callingForm.srchdomain.options[i].value == '$env{'request.role.domain'}') {
6550: callingForm.srchdomain.selectedIndex = i;
1.556 raeburn 6551: }
6552: }
6553: }
6554: }
6555: ENDSCRIPT
1.558 albertel 6556:
1.556 raeburn 6557: }
6558:
1.555 raeburn 6559: my $output = <<"END_BLOCK";
1.556 raeburn 6560: <script type="text/javascript">
1.570 raeburn 6561: function validateEntry(callingForm) {
1.558 albertel 6562:
1.556 raeburn 6563: var checkok = 1;
1.558 albertel 6564: var srchin;
1.570 raeburn 6565: for (var i=0; i<callingForm.srchin.length; i++) {
6566: if ( callingForm.srchin[i].checked ) {
6567: srchin = callingForm.srchin[i].value;
1.558 albertel 6568: }
6569: }
6570:
1.570 raeburn 6571: var srchtype = callingForm.srchtype.options[callingForm.srchtype.selectedIndex].value;
6572: var srchby = callingForm.srchby.options[callingForm.srchby.selectedIndex].value;
6573: var srchdomain = callingForm.srchdomain.options[callingForm.srchdomain.selectedIndex].value;
6574: var srchterm = callingForm.srchterm.value;
6575: var srchin = callingForm.srchin.options[callingForm.srchin.selectedIndex].value;
1.556 raeburn 6576: var msg = "";
6577:
6578: if (srchterm == "") {
6579: checkok = 0;
1.571 raeburn 6580: msg += "$lt{'youm'}\\n";
1.556 raeburn 6581: }
6582:
1.569 raeburn 6583: if (srchtype== 'begins') {
6584: if (srchterm.length < 2) {
6585: checkok = 0;
1.571 raeburn 6586: msg += "$lt{'thte'}\\n";
1.569 raeburn 6587: }
6588: }
6589:
1.556 raeburn 6590: if (srchtype== 'contains') {
6591: if (srchterm.length < 3) {
6592: checkok = 0;
1.571 raeburn 6593: msg += "$lt{'thet'}\\n";
1.556 raeburn 6594: }
6595: }
6596: if (srchin == 'instd') {
6597: if (srchdomain == '') {
6598: checkok = 0;
1.571 raeburn 6599: msg += "$lt{'yomc'}\\n";
1.556 raeburn 6600: }
6601: }
6602: if (srchin == 'dom') {
6603: if (srchdomain == '') {
6604: checkok = 0;
1.571 raeburn 6605: msg += "$lt{'ymcd'}\\n";
1.556 raeburn 6606: }
6607: }
6608: if (srchby == 'lastfirst') {
6609: if (srchterm.indexOf(",") == -1) {
6610: checkok = 0;
1.571 raeburn 6611: msg += "$lt{'whus'}\\n";
1.556 raeburn 6612: }
6613: if (srchterm.indexOf(",") == srchterm.length -1) {
6614: checkok = 0;
1.571 raeburn 6615: msg += "$lt{'whse'}\\n";
1.556 raeburn 6616: }
6617: }
6618: if (checkok == 0) {
1.571 raeburn 6619: alert("$lt{'thfo'}\\n"+msg);
1.556 raeburn 6620: return;
6621: }
6622: if (checkok == 1) {
1.570 raeburn 6623: callingForm.submit();
1.556 raeburn 6624: }
6625: }
6626:
6627: $newuserscript
6628:
6629: </script>
1.558 albertel 6630:
6631: $new_user_create
6632:
1.555 raeburn 6633: <table>
1.558 albertel 6634: <tr>
1.573 raeburn 6635: <td>$lt{'doma'}:</td>
6636: <td>$domform</td>
6637: </td>
6638: </tr>
6639: <tr>
6640: <td>$lt{'usr'}:</td>
1.563 raeburn 6641: <td>$srchbysel
6642: $srchtypesel
6643: <input type="text" size="15" name="srchterm" value="$srchterm" />
1.564 albertel 6644: $srchinsel
1.563 raeburn 6645: </td>
6646: </tr>
1.555 raeburn 6647: </table>
6648: <br />
6649: END_BLOCK
1.558 albertel 6650:
1.555 raeburn 6651: return $output;
6652: }
6653:
1.612 raeburn 6654: sub user_rule_check {
1.615 raeburn 6655: my ($usershash,$checks,$alerts,$rulematch,$inst_results,$curr_rules,$got_rules) = @_;
1.612 raeburn 6656: my $response;
6657: if (ref($usershash) eq 'HASH') {
6658: foreach my $user (keys(%{$usershash})) {
6659: my ($uname,$udom) = split(/:/,$user);
6660: next if ($udom eq '' || $uname eq '');
1.615 raeburn 6661: my ($id,$newuser);
1.612 raeburn 6662: if (ref($usershash->{$user}) eq 'HASH') {
1.615 raeburn 6663: $newuser = $usershash->{$user}->{'newuser'};
1.612 raeburn 6664: $id = $usershash->{$user}->{'id'};
6665: }
6666: my $inst_response;
6667: if (ref($checks) eq 'HASH') {
6668: if (defined($checks->{'username'})) {
1.615 raeburn 6669: ($inst_response,%{$inst_results->{$user}}) =
1.612 raeburn 6670: &Apache::lonnet::get_instuser($udom,$uname);
6671: } elsif (defined($checks->{'id'})) {
1.615 raeburn 6672: ($inst_response,%{$inst_results->{$user}}) =
1.612 raeburn 6673: &Apache::lonnet::get_instuser($udom,undef,$id);
6674: }
1.615 raeburn 6675: } else {
6676: ($inst_response,%{$inst_results->{$user}}) =
6677: &Apache::lonnet::get_instuser($udom,$uname);
6678: return;
1.612 raeburn 6679: }
1.615 raeburn 6680: if (!$got_rules->{$udom}) {
1.612 raeburn 6681: my %domconfig = &Apache::lonnet::get_dom('configuration',
6682: ['usercreation'],$udom);
6683: if (ref($domconfig{'usercreation'}) eq 'HASH') {
1.615 raeburn 6684: foreach my $item ('username','id') {
1.612 raeburn 6685: if (ref($domconfig{'usercreation'}{$item.'_rule'}) eq 'ARRAY') {
6686: $$curr_rules{$udom}{$item} =
6687: $domconfig{'usercreation'}{$item.'_rule'};
1.585 raeburn 6688: }
6689: }
6690: }
1.615 raeburn 6691: $got_rules->{$udom} = 1;
1.585 raeburn 6692: }
1.612 raeburn 6693: foreach my $item (keys(%{$checks})) {
6694: if (ref($$curr_rules{$udom}) eq 'HASH') {
6695: if (ref($$curr_rules{$udom}{$item}) eq 'ARRAY') {
6696: if (@{$$curr_rules{$udom}{$item}} > 0) {
6697: my %rule_check = &Apache::lonnet::inst_rulecheck($udom,$uname,$id,$item,$$curr_rules{$udom}{$item});
6698: foreach my $rule (@{$$curr_rules{$udom}{$item}}) {
6699: if ($rule_check{$rule}) {
6700: $$rulematch{$user}{$item} = $rule;
6701: if ($inst_response eq 'ok') {
1.615 raeburn 6702: if (ref($inst_results) eq 'HASH') {
6703: if (ref($inst_results->{$user}) eq 'HASH') {
6704: if (keys(%{$inst_results->{$user}}) == 0) {
6705: $$alerts{$item}{$udom}{$uname} = 1;
6706: }
1.612 raeburn 6707: }
6708: }
1.615 raeburn 6709: }
6710: last;
1.585 raeburn 6711: }
6712: }
6713: }
6714: }
6715: }
6716: }
6717: }
6718: }
1.612 raeburn 6719: return;
6720: }
6721:
6722: sub user_rule_formats {
6723: my ($domain,$domdesc,$curr_rules,$check) = @_;
6724: my %text = (
6725: 'username' => 'Usernames',
6726: 'id' => 'IDs',
6727: );
6728: my $output;
6729: my ($rules,$ruleorder) = &Apache::lonnet::inst_userrules($domain,$check);
6730: if ((ref($rules) eq 'HASH') && (ref($ruleorder) eq 'ARRAY')) {
6731: if (@{$ruleorder} > 0) {
6732: $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>';
6733: foreach my $rule (@{$ruleorder}) {
6734: if (ref($curr_rules) eq 'ARRAY') {
6735: if (grep(/^\Q$rule\E$/,@{$curr_rules})) {
6736: if (ref($rules->{$rule}) eq 'HASH') {
6737: $output .= '<li>'.$rules->{$rule}{'name'}.': '.
6738: $rules->{$rule}{'desc'}.'</li>';
6739: }
6740: }
6741: }
6742: }
6743: $output .= '</ul>';
6744: }
6745: }
6746: return $output;
6747: }
6748:
6749: sub instrule_disallow_msg {
1.615 raeburn 6750: my ($checkitem,$domdesc,$count,$mode) = @_;
1.612 raeburn 6751: my $response;
6752: my %text = (
6753: item => 'username',
6754: items => 'usernames',
6755: match => 'matches',
6756: do => 'does',
6757: action => 'a username',
6758: one => 'one',
6759: );
6760: if ($count > 1) {
6761: $text{'item'} = 'usernames';
6762: $text{'match'} ='match';
6763: $text{'do'} = 'do';
6764: $text{'action'} = 'usernames',
6765: $text{'one'} = 'ones';
6766: }
6767: if ($checkitem eq 'id') {
6768: $text{'items'} = 'IDs';
6769: $text{'item'} = 'ID';
6770: $text{'action'} = 'an ID';
1.615 raeburn 6771: if ($count > 1) {
6772: $text{'item'} = 'IDs';
6773: $text{'action'} = 'IDs';
6774: }
1.612 raeburn 6775: }
6776: $response = &mt("The $text{'item'} you chose $text{'match'} the format of $text{'items'} defined for <span class=\"LC_cusr_emph\">[_1]</span>, but the $text{'item'} $text{'do'} not exist in the institutional directory.",$domdesc).'<br />';
1.615 raeburn 6777: if ($mode eq 'upload') {
6778: if ($checkitem eq 'username') {
6779: $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'}.");
6780: } elsif ($checkitem eq 'id') {
6781: $response .= &mt("Either upload a file which includes $text{'action'} with a different format -- $text{'one'} that will not conflict with 'official' institutional $text{'items'}, or when associating fields with data columns, omit an association for the ID/Student Number field.");
6782: }
6783: } else {
6784: if ($checkitem eq 'username') {
6785: $response .= &mt("You must choose $text{'action'} with a different format -- $text{'one'} that will not conflict with 'official' institutional $text{'items'}.");
6786: } elsif ($checkitem eq 'id') {
6787: $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.");
6788: }
1.612 raeburn 6789: }
6790: return $response;
1.585 raeburn 6791: }
6792:
1.624 raeburn 6793: sub personal_data_fieldtitles {
6794: my %fieldtitles = &Apache::lonlocal::texthash (
6795: id => 'Student/Employee ID',
6796: permanentemail => 'E-mail address',
6797: lastname => 'Last Name',
6798: firstname => 'First Name',
6799: middlename => 'Middle Name',
6800: generation => 'Generation',
6801: gen => 'Generation',
6802: );
6803: return %fieldtitles;
6804: }
6805:
1.642 raeburn 6806: sub sorted_inst_types {
6807: my ($dom) = @_;
6808: my ($usertypes,$order) = &Apache::lonnet::retrieve_inst_usertypes($dom);
6809: my $othertitle = &mt('All users');
6810: if ($env{'request.course.id'}) {
6811: $othertitle = 'any';
6812: }
6813: my @types;
6814: if (ref($order) eq 'ARRAY') {
6815: @types = @{$order};
6816: }
6817: if (@types == 0) {
6818: if (ref($usertypes) eq 'HASH') {
6819: @types = sort(keys(%{$usertypes}));
6820: }
6821: }
6822: if (keys(%{$usertypes}) > 0) {
6823: $othertitle = &mt('Other users');
6824: if ($env{'request.course.id'}) {
6825: $othertitle = 'other';
6826: }
6827: }
6828: return ($othertitle,$usertypes,\@types);
6829: }
6830:
1.645 raeburn 6831: sub get_institutional_codes {
6832: my ($settings,$allcourses,$LC_code) = @_;
6833: # Get complete list of course sections to update
6834: my @currsections = ();
6835: my @currxlists = ();
6836: my $coursecode = $$settings{'internal.coursecode'};
6837:
6838: if ($$settings{'internal.sectionnums'} ne '') {
6839: @currsections = split(/,/,$$settings{'internal.sectionnums'});
6840: }
6841:
6842: if ($$settings{'internal.crosslistings'} ne '') {
6843: @currxlists = split(/,/,$$settings{'internal.crosslistings'});
6844: }
6845:
6846: if (@currxlists > 0) {
6847: foreach (@currxlists) {
6848: if (m/^([^:]+):(\w*)$/) {
6849: unless (grep/^$1$/,@{$allcourses}) {
6850: push @{$allcourses},$1;
6851: $$LC_code{$1} = $2;
6852: }
6853: }
6854: }
6855: }
6856:
6857: if (@currsections > 0) {
6858: foreach (@currsections) {
6859: if (m/^(\w+):(\w*)$/) {
6860: my $sec = $coursecode.$1;
6861: my $lc_sec = $2;
6862: unless (grep/^$sec$/,@{$allcourses}) {
6863: push @{$allcourses},$sec;
6864: $$LC_code{$sec} = $lc_sec;
6865: }
6866: }
6867: }
6868: }
6869: return;
6870: }
6871:
1.112 bowersj2 6872: =pod
6873:
1.549 albertel 6874: =back
6875:
6876: =head1 HTTP Helpers
6877:
6878: =over 4
6879:
1.648 raeburn 6880: =item * &get_unprocessed_cgi($query,$possible_names)
1.112 bowersj2 6881:
1.258 albertel 6882: Modify the %env hash to contain unprocessed CGI form parameters held in
1.112 bowersj2 6883: $query. The parameters listed in $possible_names (an array reference),
1.258 albertel 6884: will be set in $env{'form.name'} if they do not already exist.
1.112 bowersj2 6885:
6886: Typically called with $ENV{'QUERY_STRING'} as the first parameter.
6887: $possible_names is an ref to an array of form element names. As an example:
6888: get_unprocessed_cgi($ENV{'QUERY_STRING'},['uname','udom']);
1.258 albertel 6889: will result in $env{'form.uname'} and $env{'form.udom'} being set.
1.112 bowersj2 6890:
6891: =cut
1.1 albertel 6892:
1.6 albertel 6893: sub get_unprocessed_cgi {
1.25 albertel 6894: my ($query,$possible_names)= @_;
1.26 matthew 6895: # $Apache::lonxml::debug=1;
1.356 albertel 6896: foreach my $pair (split(/&/,$query)) {
6897: my ($name, $value) = split(/=/,$pair);
1.369 www 6898: $name = &unescape($name);
1.25 albertel 6899: if (!defined($possible_names) || (grep {$_ eq $name} @$possible_names)) {
6900: $value =~ tr/+/ /;
6901: $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
1.258 albertel 6902: unless (defined($env{'form.'.$name})) { &add_to_env('form.'.$name,$value) };
1.25 albertel 6903: }
1.16 harris41 6904: }
1.6 albertel 6905: }
6906:
1.112 bowersj2 6907: =pod
6908:
1.648 raeburn 6909: =item * &cacheheader()
1.112 bowersj2 6910:
6911: returns cache-controlling header code
6912:
6913: =cut
6914:
1.7 albertel 6915: sub cacheheader {
1.258 albertel 6916: unless ($env{'request.method'} eq 'GET') { return ''; }
1.216 albertel 6917: my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime);
6918: my $output .='<meta HTTP-EQUIV="Expires" CONTENT="'.$date.'" />
1.7 albertel 6919: <meta HTTP-EQUIV="Cache-control" CONTENT="no-cache" />
6920: <meta HTTP-EQUIV="Pragma" CONTENT="no-cache" />';
1.216 albertel 6921: return $output;
1.7 albertel 6922: }
6923:
1.112 bowersj2 6924: =pod
6925:
1.648 raeburn 6926: =item * &no_cache($r)
1.112 bowersj2 6927:
6928: specifies header code to not have cache
6929:
6930: =cut
6931:
1.9 albertel 6932: sub no_cache {
1.216 albertel 6933: my ($r) = @_;
6934: if ($ENV{'REQUEST_METHOD'} ne 'GET' &&
1.258 albertel 6935: $env{'request.method'} ne 'GET') { return ''; }
1.216 albertel 6936: my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime(time));
6937: $r->no_cache(1);
6938: $r->header_out("Expires" => $date);
6939: $r->header_out("Pragma" => "no-cache");
1.123 www 6940: }
6941:
6942: sub content_type {
1.181 albertel 6943: my ($r,$type,$charset) = @_;
1.299 foxr 6944: if ($r) {
6945: # Note that printout.pl calls this with undef for $r.
6946: &no_cache($r);
6947: }
1.258 albertel 6948: if ($env{'browser.mathml'} && $type eq 'text/html') { $type='text/xml'; }
1.181 albertel 6949: unless ($charset) {
6950: $charset=&Apache::lonlocal::current_encoding;
6951: }
6952: if ($charset) { $type.='; charset='.$charset; }
6953: if ($r) {
6954: $r->content_type($type);
6955: } else {
6956: print("Content-type: $type\n\n");
6957: }
1.9 albertel 6958: }
1.25 albertel 6959:
1.112 bowersj2 6960: =pod
6961:
1.648 raeburn 6962: =item * &add_to_env($name,$value)
1.112 bowersj2 6963:
1.258 albertel 6964: adds $name to the %env hash with value
1.112 bowersj2 6965: $value, if $name already exists, the entry is converted to an array
6966: reference and $value is added to the array.
6967:
6968: =cut
6969:
1.25 albertel 6970: sub add_to_env {
6971: my ($name,$value)=@_;
1.258 albertel 6972: if (defined($env{$name})) {
6973: if (ref($env{$name})) {
1.25 albertel 6974: #already have multiple values
1.258 albertel 6975: push(@{ $env{$name} },$value);
1.25 albertel 6976: } else {
6977: #first time seeing multiple values, convert hash entry to an arrayref
1.258 albertel 6978: my $first=$env{$name};
6979: undef($env{$name});
6980: push(@{ $env{$name} },$first,$value);
1.25 albertel 6981: }
6982: } else {
1.258 albertel 6983: $env{$name}=$value;
1.25 albertel 6984: }
1.31 albertel 6985: }
1.149 albertel 6986:
6987: =pod
6988:
1.648 raeburn 6989: =item * &get_env_multiple($name)
1.149 albertel 6990:
1.258 albertel 6991: gets $name from the %env hash, it seemlessly handles the cases where multiple
1.149 albertel 6992: values may be defined and end up as an array ref.
6993:
6994: returns an array of values
6995:
6996: =cut
6997:
6998: sub get_env_multiple {
6999: my ($name) = @_;
7000: my @values;
1.258 albertel 7001: if (defined($env{$name})) {
1.149 albertel 7002: # exists is it an array
1.258 albertel 7003: if (ref($env{$name})) {
7004: @values=@{ $env{$name} };
1.149 albertel 7005: } else {
1.258 albertel 7006: $values[0]=$env{$name};
1.149 albertel 7007: }
7008: }
7009: return(@values);
7010: }
7011:
1.31 albertel 7012:
1.41 ng 7013: =pod
1.45 matthew 7014:
1.464 albertel 7015: =back
1.41 ng 7016:
1.112 bowersj2 7017: =head1 CSV Upload/Handling functions
1.38 albertel 7018:
1.41 ng 7019: =over 4
7020:
1.648 raeburn 7021: =item * &upfile_store($r)
1.41 ng 7022:
7023: Store uploaded file, $r should be the HTTP Request object,
1.258 albertel 7024: needs $env{'form.upfile'}
1.41 ng 7025: returns $datatoken to be put into hidden field
7026:
7027: =cut
1.31 albertel 7028:
7029: sub upfile_store {
7030: my $r=shift;
1.258 albertel 7031: $env{'form.upfile'}=~s/\r/\n/gs;
7032: $env{'form.upfile'}=~s/\f/\n/gs;
7033: $env{'form.upfile'}=~s/\n+/\n/gs;
7034: $env{'form.upfile'}=~s/\n+$//gs;
1.31 albertel 7035:
1.258 albertel 7036: my $datatoken=$env{'user.name'}.'_'.$env{'user.domain'}.
7037: '_enroll_'.$env{'request.course.id'}.'_'.time.'_'.$$;
1.31 albertel 7038: {
1.158 raeburn 7039: my $datafile = $r->dir_config('lonDaemons').
7040: '/tmp/'.$datatoken.'.tmp';
7041: if ( open(my $fh,">$datafile") ) {
1.258 albertel 7042: print $fh $env{'form.upfile'};
1.158 raeburn 7043: close($fh);
7044: }
1.31 albertel 7045: }
7046: return $datatoken;
7047: }
7048:
1.56 matthew 7049: =pod
7050:
1.648 raeburn 7051: =item * &load_tmp_file($r)
1.41 ng 7052:
7053: Load uploaded file from tmp, $r should be the HTTP Request object,
1.258 albertel 7054: needs $env{'form.datatoken'},
7055: sets $env{'form.upfile'} to the contents of the file
1.41 ng 7056:
7057: =cut
1.31 albertel 7058:
7059: sub load_tmp_file {
7060: my $r=shift;
7061: my @studentdata=();
7062: {
1.158 raeburn 7063: my $studentfile = $r->dir_config('lonDaemons').
1.258 albertel 7064: '/tmp/'.$env{'form.datatoken'}.'.tmp';
1.158 raeburn 7065: if ( open(my $fh,"<$studentfile") ) {
7066: @studentdata=<$fh>;
7067: close($fh);
7068: }
1.31 albertel 7069: }
1.258 albertel 7070: $env{'form.upfile'}=join('',@studentdata);
1.31 albertel 7071: }
7072:
1.56 matthew 7073: =pod
7074:
1.648 raeburn 7075: =item * &upfile_record_sep()
1.41 ng 7076:
7077: Separate uploaded file into records
7078: returns array of records,
1.258 albertel 7079: needs $env{'form.upfile'} and $env{'form.upfiletype'}
1.41 ng 7080:
7081: =cut
1.31 albertel 7082:
7083: sub upfile_record_sep {
1.258 albertel 7084: if ($env{'form.upfiletype'} eq 'xml') {
1.31 albertel 7085: } else {
1.248 albertel 7086: my @records;
1.258 albertel 7087: foreach my $line (split(/\n/,$env{'form.upfile'})) {
1.248 albertel 7088: if ($line=~/^\s*$/) { next; }
7089: push(@records,$line);
7090: }
7091: return @records;
1.31 albertel 7092: }
7093: }
7094:
1.56 matthew 7095: =pod
7096:
1.648 raeburn 7097: =item * &record_sep($record)
1.41 ng 7098:
1.258 albertel 7099: Separate a record into fields $record should be an item from the upfile_record_sep(), needs $env{'form.upfiletype'}
1.41 ng 7100:
7101: =cut
7102:
1.263 www 7103: sub takeleft {
7104: my $index=shift;
7105: return substr('0000'.$index,-4,4);
7106: }
7107:
1.31 albertel 7108: sub record_sep {
7109: my $record=shift;
7110: my %components=();
1.258 albertel 7111: if ($env{'form.upfiletype'} eq 'xml') {
7112: } elsif ($env{'form.upfiletype'} eq 'space') {
1.31 albertel 7113: my $i=0;
1.356 albertel 7114: foreach my $field (split(/\s+/,$record)) {
1.31 albertel 7115: $field=~s/^(\"|\')//;
7116: $field=~s/(\"|\')$//;
1.263 www 7117: $components{&takeleft($i)}=$field;
1.31 albertel 7118: $i++;
7119: }
1.258 albertel 7120: } elsif ($env{'form.upfiletype'} eq 'tab') {
1.31 albertel 7121: my $i=0;
1.356 albertel 7122: foreach my $field (split(/\t/,$record)) {
1.31 albertel 7123: $field=~s/^(\"|\')//;
7124: $field=~s/(\"|\')$//;
1.263 www 7125: $components{&takeleft($i)}=$field;
1.31 albertel 7126: $i++;
7127: }
7128: } else {
1.561 www 7129: my $separator=',';
1.480 banghart 7130: if ($env{'form.upfiletype'} eq 'semisv') {
1.561 www 7131: $separator=';';
1.480 banghart 7132: }
1.31 albertel 7133: my $i=0;
1.561 www 7134: # the character we are looking for to indicate the end of a quote or a record
7135: my $looking_for=$separator;
7136: # do not add the characters to the fields
7137: my $ignore=0;
7138: # we just encountered a separator (or the beginning of the record)
7139: my $just_found_separator=1;
7140: # store the field we are working on here
7141: my $field='';
7142: # work our way through all characters in record
7143: foreach my $character ($record=~/(.)/g) {
7144: if ($character eq $looking_for) {
7145: if ($character ne $separator) {
7146: # Found the end of a quote, again looking for separator
7147: $looking_for=$separator;
7148: $ignore=1;
7149: } else {
7150: # Found a separator, store away what we got
7151: $components{&takeleft($i)}=$field;
7152: $i++;
7153: $just_found_separator=1;
7154: $ignore=0;
7155: $field='';
7156: }
7157: next;
7158: }
7159: # single or double quotation marks after a separator indicate beginning of a quote
7160: # we are now looking for the end of the quote and need to ignore separators
7161: if ((($character eq '"') || ($character eq "'")) && ($just_found_separator)) {
7162: $looking_for=$character;
7163: next;
7164: }
7165: # ignore would be true after we reached the end of a quote
7166: if ($ignore) { next; }
7167: if (($just_found_separator) && ($character=~/\s/)) { next; }
7168: $field.=$character;
7169: $just_found_separator=0;
1.31 albertel 7170: }
1.561 www 7171: # catch the very last entry, since we never encountered the separator
7172: $components{&takeleft($i)}=$field;
1.31 albertel 7173: }
7174: return %components;
7175: }
7176:
1.144 matthew 7177: ######################################################
7178: ######################################################
7179:
1.56 matthew 7180: =pod
7181:
1.648 raeburn 7182: =item * &upfile_select_html()
1.41 ng 7183:
1.144 matthew 7184: Return HTML code to select a file from the users machine and specify
7185: the file type.
1.41 ng 7186:
7187: =cut
7188:
1.144 matthew 7189: ######################################################
7190: ######################################################
1.31 albertel 7191: sub upfile_select_html {
1.144 matthew 7192: my %Types = (
7193: csv => &mt('CSV (comma separated values, spreadsheet)'),
1.480 banghart 7194: semisv => &mt('Semicolon separated values'),
1.144 matthew 7195: space => &mt('Space separated'),
7196: tab => &mt('Tabulator separated'),
7197: # xml => &mt('HTML/XML'),
7198: );
7199: my $Str = '<input type="file" name="upfile" size="50" />'.
7200: '<br />Type: <select name="upfiletype">';
7201: foreach my $type (sort(keys(%Types))) {
7202: $Str .= '<option value="'.$type.'" >'.$Types{$type}."</option>\n";
7203: }
7204: $Str .= "</select>\n";
7205: return $Str;
1.31 albertel 7206: }
7207:
1.301 albertel 7208: sub get_samples {
7209: my ($records,$toget) = @_;
7210: my @samples=({});
7211: my $got=0;
7212: foreach my $rec (@$records) {
7213: my %temp = &record_sep($rec);
7214: if (! grep(/\S/, values(%temp))) { next; }
7215: if (%temp) {
7216: $samples[$got]=\%temp;
7217: $got++;
7218: if ($got == $toget) { last; }
7219: }
7220: }
7221: return \@samples;
7222: }
7223:
1.144 matthew 7224: ######################################################
7225: ######################################################
7226:
1.56 matthew 7227: =pod
7228:
1.648 raeburn 7229: =item * &csv_print_samples($r,$records)
1.41 ng 7230:
7231: Prints a table of sample values from each column uploaded $r is an
7232: Apache Request ref, $records is an arrayref from
7233: &Apache::loncommon::upfile_record_sep
7234:
7235: =cut
7236:
1.144 matthew 7237: ######################################################
7238: ######################################################
1.31 albertel 7239: sub csv_print_samples {
7240: my ($r,$records) = @_;
1.301 albertel 7241: my $samples = &get_samples($records,3);
7242:
1.594 raeburn 7243: $r->print(&mt('Samples').'<br />'.&start_data_table().
7244: &start_data_table_header_row());
1.356 albertel 7245: foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
7246: $r->print('<th>'.&mt('Column [_1]',($sample+1)).'</th>'); }
1.594 raeburn 7247: $r->print(&end_data_table_header_row());
1.301 albertel 7248: foreach my $hash (@$samples) {
1.594 raeburn 7249: $r->print(&start_data_table_row());
1.356 albertel 7250: foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
1.31 albertel 7251: $r->print('<td>');
1.356 albertel 7252: if (defined($$hash{$sample})) { $r->print($$hash{$sample}); }
1.31 albertel 7253: $r->print('</td>');
7254: }
1.594 raeburn 7255: $r->print(&end_data_table_row());
1.31 albertel 7256: }
1.594 raeburn 7257: $r->print(&end_data_table().'<br />'."\n");
1.31 albertel 7258: }
7259:
1.144 matthew 7260: ######################################################
7261: ######################################################
7262:
1.56 matthew 7263: =pod
7264:
1.648 raeburn 7265: =item * &csv_print_select_table($r,$records,$d)
1.41 ng 7266:
7267: Prints a table to create associations between values and table columns.
1.144 matthew 7268:
1.41 ng 7269: $r is an Apache Request ref,
7270: $records is an arrayref from &Apache::loncommon::upfile_record_sep,
1.174 matthew 7271: $d is an array of 2 element arrays (internal name, displayed name,defaultcol)
1.41 ng 7272:
7273: =cut
7274:
1.144 matthew 7275: ######################################################
7276: ######################################################
1.31 albertel 7277: sub csv_print_select_table {
7278: my ($r,$records,$d) = @_;
1.301 albertel 7279: my $i=0;
7280: my $samples = &get_samples($records,1);
1.144 matthew 7281: $r->print(&mt('Associate columns with student attributes.')."\n".
1.594 raeburn 7282: &start_data_table().&start_data_table_header_row().
1.144 matthew 7283: '<th>'.&mt('Attribute').'</th>'.
1.594 raeburn 7284: '<th>'.&mt('Column').'</th>'.
7285: &end_data_table_header_row()."\n");
1.356 albertel 7286: foreach my $array_ref (@$d) {
7287: my ($value,$display,$defaultcol)=@{ $array_ref };
1.594 raeburn 7288: $r->print(&start_data_table_row().'<tr><td>'.$display.'</td>');
1.31 albertel 7289:
7290: $r->print('<td><select name=f'.$i.
1.32 matthew 7291: ' onchange="javascript:flip(this.form,'.$i.');">');
1.31 albertel 7292: $r->print('<option value="none"></option>');
1.356 albertel 7293: foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) {
7294: $r->print('<option value="'.$sample.'"'.
7295: ($sample eq $defaultcol ? ' selected="selected" ' : '').
7296: '>Column '.($sample+1).'</option>');
1.31 albertel 7297: }
1.594 raeburn 7298: $r->print('</select></td>'.&end_data_table_row()."\n");
1.31 albertel 7299: $i++;
7300: }
1.594 raeburn 7301: $r->print(&end_data_table());
1.31 albertel 7302: $i--;
7303: return $i;
7304: }
1.56 matthew 7305:
1.144 matthew 7306: ######################################################
7307: ######################################################
7308:
1.56 matthew 7309: =pod
1.31 albertel 7310:
1.648 raeburn 7311: =item * &csv_samples_select_table($r,$records,$d)
1.41 ng 7312:
7313: Prints a table of sample values from the upload and can make associate samples to internal names.
7314:
7315: $r is an Apache Request ref,
7316: $records is an arrayref from &Apache::loncommon::upfile_record_sep,
7317: $d is an array of 2 element arrays (internal name, displayed name)
7318:
7319: =cut
7320:
1.144 matthew 7321: ######################################################
7322: ######################################################
1.31 albertel 7323: sub csv_samples_select_table {
7324: my ($r,$records,$d) = @_;
7325: my $i=0;
1.144 matthew 7326: #
1.301 albertel 7327: my $samples = &get_samples($records,3);
1.594 raeburn 7328: $r->print(&start_data_table().
7329: &start_data_table_header_row().'<th>'.
7330: &mt('Field').'</th><th>'.&mt('Samples').'</th>'.
7331: &end_data_table_header_row());
1.301 albertel 7332:
7333: foreach my $key (sort(keys(%{ $samples->[0] }))) {
1.594 raeburn 7334: $r->print(&start_data_table_row().'<td><select name="f'.$i.'"'.
1.32 matthew 7335: ' onchange="javascript:flip(this.form,'.$i.');">');
1.301 albertel 7336: foreach my $option (@$d) {
7337: my ($value,$display,$defaultcol)=@{ $option };
1.174 matthew 7338: $r->print('<option value="'.$value.'"'.
1.253 albertel 7339: ($i eq $defaultcol ? ' selected="selected" ':'').'>'.
1.174 matthew 7340: $display.'</option>');
1.31 albertel 7341: }
7342: $r->print('</select></td><td>');
1.301 albertel 7343: foreach my $line (0..2) {
7344: if (defined($samples->[$line]{$key})) {
7345: $r->print($samples->[$line]{$key}."<br />\n");
7346: }
7347: }
1.594 raeburn 7348: $r->print('</td>'.&end_data_table_row());
1.31 albertel 7349: $i++;
7350: }
1.594 raeburn 7351: $r->print(&end_data_table());
1.31 albertel 7352: $i--;
7353: return($i);
1.115 matthew 7354: }
7355:
1.144 matthew 7356: ######################################################
7357: ######################################################
7358:
1.115 matthew 7359: =pod
7360:
1.648 raeburn 7361: =item * &clean_excel_name($name)
1.115 matthew 7362:
7363: Returns a replacement for $name which does not contain any illegal characters.
7364:
7365: =cut
7366:
1.144 matthew 7367: ######################################################
7368: ######################################################
1.115 matthew 7369: sub clean_excel_name {
7370: my ($name) = @_;
7371: $name =~ s/[:\*\?\/\\]//g;
7372: if (length($name) > 31) {
7373: $name = substr($name,0,31);
7374: }
7375: return $name;
1.25 albertel 7376: }
1.84 albertel 7377:
1.85 albertel 7378: =pod
7379:
1.648 raeburn 7380: =item * &check_if_partid_hidden($id,$symb,$udom,$uname)
1.85 albertel 7381:
7382: Returns either 1 or undef
7383:
7384: 1 if the part is to be hidden, undef if it is to be shown
7385:
7386: Arguments are:
7387:
7388: $id the id of the part to be checked
7389: $symb, optional the symb of the resource to check
7390: $udom, optional the domain of the user to check for
7391: $uname, optional the username of the user to check for
7392:
7393: =cut
1.84 albertel 7394:
7395: sub check_if_partid_hidden {
7396: my ($id,$symb,$udom,$uname) = @_;
1.133 albertel 7397: my $hiddenparts=&Apache::lonnet::EXT('resource.0.hiddenparts',
1.84 albertel 7398: $symb,$udom,$uname);
1.141 albertel 7399: my $truth=1;
7400: #if the string starts with !, then the list is the list to show not hide
7401: if ($hiddenparts=~s/^\s*!//) { $truth=undef; }
1.84 albertel 7402: my @hiddenlist=split(/,/,$hiddenparts);
7403: foreach my $checkid (@hiddenlist) {
1.141 albertel 7404: if ($checkid =~ /^\s*\Q$id\E\s*$/) { return $truth; }
1.84 albertel 7405: }
1.141 albertel 7406: return !$truth;
1.84 albertel 7407: }
1.127 matthew 7408:
1.138 matthew 7409:
7410: ############################################################
7411: ############################################################
7412:
7413: =pod
7414:
1.157 matthew 7415: =back
7416:
1.138 matthew 7417: =head1 cgi-bin script and graphing routines
7418:
1.157 matthew 7419: =over 4
7420:
1.648 raeburn 7421: =item * &get_cgi_id()
1.138 matthew 7422:
7423: Inputs: none
7424:
7425: Returns an id which can be used to pass environment variables
7426: to various cgi-bin scripts. These environment variables will
7427: be removed from the users environment after a given time by
7428: the routine &Apache::lonnet::transfer_profile_to_env.
7429:
7430: =cut
7431:
7432: ############################################################
7433: ############################################################
1.152 albertel 7434: my $uniq=0;
1.136 matthew 7435: sub get_cgi_id {
1.154 albertel 7436: $uniq=($uniq+1)%100000;
1.280 albertel 7437: return (time.'_'.$$.'_'.$uniq);
1.136 matthew 7438: }
7439:
1.127 matthew 7440: ############################################################
7441: ############################################################
7442:
7443: =pod
7444:
1.648 raeburn 7445: =item * &DrawBarGraph()
1.127 matthew 7446:
1.138 matthew 7447: Facilitates the plotting of data in a (stacked) bar graph.
7448: Puts plot definition data into the users environment in order for
7449: graph.png to plot it. Returns an <img> tag for the plot.
7450: The bars on the plot are labeled '1','2',...,'n'.
7451:
7452: Inputs:
7453:
7454: =over 4
7455:
7456: =item $Title: string, the title of the plot
7457:
7458: =item $xlabel: string, text describing the X-axis of the plot
7459:
7460: =item $ylabel: string, text describing the Y-axis of the plot
7461:
7462: =item $Max: scalar, the maximum Y value to use in the plot
7463: If $Max is < any data point, the graph will not be rendered.
7464:
1.140 matthew 7465: =item $colors: array ref holding the colors to be used for the data sets when
1.138 matthew 7466: they are plotted. If undefined, default values will be used.
7467:
1.178 matthew 7468: =item $labels: array ref holding the labels to use on the x-axis for the bars.
7469:
1.138 matthew 7470: =item @Values: An array of array references. Each array reference holds data
7471: to be plotted in a stacked bar chart.
7472:
1.239 matthew 7473: =item If the final element of @Values is a hash reference the key/value
7474: pairs will be added to the graph definition.
7475:
1.138 matthew 7476: =back
7477:
7478: Returns:
7479:
7480: An <img> tag which references graph.png and the appropriate identifying
7481: information for the plot.
7482:
1.127 matthew 7483: =cut
7484:
7485: ############################################################
7486: ############################################################
1.134 matthew 7487: sub DrawBarGraph {
1.178 matthew 7488: my ($Title,$xlabel,$ylabel,$Max,$colors,$labels,@Values)=@_;
1.134 matthew 7489: #
7490: if (! defined($colors)) {
7491: $colors = ['#33ff00',
7492: '#0033cc', '#990000', '#aaaa66', '#663399', '#ff9933',
7493: '#66ccff', '#ff9999', '#cccc33', '#660000', '#33cc66',
7494: ];
7495: }
1.228 matthew 7496: my $extra_settings = {};
7497: if (ref($Values[-1]) eq 'HASH') {
7498: $extra_settings = pop(@Values);
7499: }
1.127 matthew 7500: #
1.136 matthew 7501: my $identifier = &get_cgi_id();
7502: my $id = 'cgi.'.$identifier;
1.129 matthew 7503: if (! @Values || ref($Values[0]) ne 'ARRAY') {
1.127 matthew 7504: return '';
7505: }
1.225 matthew 7506: #
7507: my @Labels;
7508: if (defined($labels)) {
7509: @Labels = @$labels;
7510: } else {
7511: for (my $i=0;$i<@{$Values[0]};$i++) {
7512: push (@Labels,$i+1);
7513: }
7514: }
7515: #
1.129 matthew 7516: my $NumBars = scalar(@{$Values[0]});
1.225 matthew 7517: if ($NumBars < scalar(@Labels)) { $NumBars = scalar(@Labels); }
1.129 matthew 7518: my %ValuesHash;
7519: my $NumSets=1;
7520: foreach my $array (@Values) {
7521: next if (! ref($array));
1.136 matthew 7522: $ValuesHash{$id.'.data.'.$NumSets++} =
1.132 matthew 7523: join(',',@$array);
1.129 matthew 7524: }
1.127 matthew 7525: #
1.136 matthew 7526: my ($height,$width,$xskip,$bar_width) = (200,120,1,15);
1.225 matthew 7527: if ($NumBars < 3) {
7528: $width = 120+$NumBars*32;
1.220 matthew 7529: $xskip = 1;
1.225 matthew 7530: $bar_width = 30;
7531: } elsif ($NumBars < 5) {
7532: $width = 120+$NumBars*20;
7533: $xskip = 1;
7534: $bar_width = 20;
1.220 matthew 7535: } elsif ($NumBars < 10) {
1.136 matthew 7536: $width = 120+$NumBars*15;
7537: $xskip = 1;
7538: $bar_width = 15;
7539: } elsif ($NumBars <= 25) {
7540: $width = 120+$NumBars*11;
7541: $xskip = 5;
7542: $bar_width = 8;
7543: } elsif ($NumBars <= 50) {
7544: $width = 120+$NumBars*8;
7545: $xskip = 5;
7546: $bar_width = 4;
7547: } else {
7548: $width = 120+$NumBars*8;
7549: $xskip = 5;
7550: $bar_width = 4;
7551: }
7552: #
1.137 matthew 7553: $Max = 1 if ($Max < 1);
7554: if ( int($Max) < $Max ) {
7555: $Max++;
7556: $Max = int($Max);
7557: }
1.127 matthew 7558: $Title = '' if (! defined($Title));
7559: $xlabel = '' if (! defined($xlabel));
7560: $ylabel = '' if (! defined($ylabel));
1.369 www 7561: $ValuesHash{$id.'.title'} = &escape($Title);
7562: $ValuesHash{$id.'.xlabel'} = &escape($xlabel);
7563: $ValuesHash{$id.'.ylabel'} = &escape($ylabel);
1.137 matthew 7564: $ValuesHash{$id.'.y_max_value'} = $Max;
1.136 matthew 7565: $ValuesHash{$id.'.NumBars'} = $NumBars;
7566: $ValuesHash{$id.'.NumSets'} = $NumSets;
7567: $ValuesHash{$id.'.PlotType'} = 'bar';
7568: $ValuesHash{$id.'.Colors'} = join(',',@{$colors});
7569: $ValuesHash{$id.'.height'} = $height;
7570: $ValuesHash{$id.'.width'} = $width;
7571: $ValuesHash{$id.'.xskip'} = $xskip;
7572: $ValuesHash{$id.'.bar_width'} = $bar_width;
7573: $ValuesHash{$id.'.labels'} = join(',',@Labels);
1.127 matthew 7574: #
1.228 matthew 7575: # Deal with other parameters
7576: while (my ($key,$value) = each(%$extra_settings)) {
7577: $ValuesHash{$id.'.'.$key} = $value;
7578: }
7579: #
1.646 raeburn 7580: &Apache::lonnet::appenv(\%ValuesHash);
1.137 matthew 7581: return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';
7582: }
7583:
7584: ############################################################
7585: ############################################################
7586:
7587: =pod
7588:
1.648 raeburn 7589: =item * &DrawXYGraph()
1.137 matthew 7590:
1.138 matthew 7591: Facilitates the plotting of data in an XY graph.
7592: Puts plot definition data into the users environment in order for
7593: graph.png to plot it. Returns an <img> tag for the plot.
7594:
7595: Inputs:
7596:
7597: =over 4
7598:
7599: =item $Title: string, the title of the plot
7600:
7601: =item $xlabel: string, text describing the X-axis of the plot
7602:
7603: =item $ylabel: string, text describing the Y-axis of the plot
7604:
7605: =item $Max: scalar, the maximum Y value to use in the plot
7606: If $Max is < any data point, the graph will not be rendered.
7607:
7608: =item $colors: Array ref containing the hex color codes for the data to be
7609: plotted in. If undefined, default values will be used.
7610:
7611: =item $Xlabels: Array ref containing the labels to be used for the X-axis.
7612:
7613: =item $Ydata: Array ref containing Array refs.
1.185 www 7614: Each of the contained arrays will be plotted as a separate curve.
1.138 matthew 7615:
7616: =item %Values: hash indicating or overriding any default values which are
7617: passed to graph.png.
7618: Possible values are: width, xskip, x_ticks, x_tick_offset, among others.
7619:
7620: =back
7621:
7622: Returns:
7623:
7624: An <img> tag which references graph.png and the appropriate identifying
7625: information for the plot.
7626:
1.137 matthew 7627: =cut
7628:
7629: ############################################################
7630: ############################################################
7631: sub DrawXYGraph {
7632: my ($Title,$xlabel,$ylabel,$Max,$colors,$Xlabels,$Ydata,%Values)=@_;
7633: #
7634: # Create the identifier for the graph
7635: my $identifier = &get_cgi_id();
7636: my $id = 'cgi.'.$identifier;
7637: #
7638: $Title = '' if (! defined($Title));
7639: $xlabel = '' if (! defined($xlabel));
7640: $ylabel = '' if (! defined($ylabel));
7641: my %ValuesHash =
7642: (
1.369 www 7643: $id.'.title' => &escape($Title),
7644: $id.'.xlabel' => &escape($xlabel),
7645: $id.'.ylabel' => &escape($ylabel),
1.137 matthew 7646: $id.'.y_max_value'=> $Max,
7647: $id.'.labels' => join(',',@$Xlabels),
7648: $id.'.PlotType' => 'XY',
7649: );
7650: #
7651: if (defined($colors) && ref($colors) eq 'ARRAY') {
7652: $ValuesHash{$id.'.Colors'} = join(',',@{$colors});
7653: }
7654: #
7655: if (! ref($Ydata) || ref($Ydata) ne 'ARRAY') {
7656: return '';
7657: }
7658: my $NumSets=1;
1.138 matthew 7659: foreach my $array (@{$Ydata}){
1.137 matthew 7660: next if (! ref($array));
7661: $ValuesHash{$id.'.data.'.$NumSets++} = join(',',@$array);
7662: }
1.138 matthew 7663: $ValuesHash{$id.'.NumSets'} = $NumSets-1;
1.137 matthew 7664: #
7665: # Deal with other parameters
7666: while (my ($key,$value) = each(%Values)) {
7667: $ValuesHash{$id.'.'.$key} = $value;
1.127 matthew 7668: }
7669: #
1.646 raeburn 7670: &Apache::lonnet::appenv(\%ValuesHash);
1.136 matthew 7671: return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';
7672: }
7673:
7674: ############################################################
7675: ############################################################
7676:
7677: =pod
7678:
1.648 raeburn 7679: =item * &DrawXYYGraph()
1.138 matthew 7680:
7681: Facilitates the plotting of data in an XY graph with two Y axes.
7682: Puts plot definition data into the users environment in order for
7683: graph.png to plot it. Returns an <img> tag for the plot.
7684:
7685: Inputs:
7686:
7687: =over 4
7688:
7689: =item $Title: string, the title of the plot
7690:
7691: =item $xlabel: string, text describing the X-axis of the plot
7692:
7693: =item $ylabel: string, text describing the Y-axis of the plot
7694:
7695: =item $colors: Array ref containing the hex color codes for the data to be
7696: plotted in. If undefined, default values will be used.
7697:
7698: =item $Xlabels: Array ref containing the labels to be used for the X-axis.
7699:
7700: =item $Ydata1: The first data set
7701:
7702: =item $Min1: The minimum value of the left Y-axis
7703:
7704: =item $Max1: The maximum value of the left Y-axis
7705:
7706: =item $Ydata2: The second data set
7707:
7708: =item $Min2: The minimum value of the right Y-axis
7709:
7710: =item $Max2: The maximum value of the left Y-axis
7711:
7712: =item %Values: hash indicating or overriding any default values which are
7713: passed to graph.png.
7714: Possible values are: width, xskip, x_ticks, x_tick_offset, among others.
7715:
7716: =back
7717:
7718: Returns:
7719:
7720: An <img> tag which references graph.png and the appropriate identifying
7721: information for the plot.
1.136 matthew 7722:
7723: =cut
7724:
7725: ############################################################
7726: ############################################################
1.137 matthew 7727: sub DrawXYYGraph {
7728: my ($Title,$xlabel,$ylabel,$colors,$Xlabels,$Ydata1,$Min1,$Max1,
7729: $Ydata2,$Min2,$Max2,%Values)=@_;
1.136 matthew 7730: #
7731: # Create the identifier for the graph
7732: my $identifier = &get_cgi_id();
7733: my $id = 'cgi.'.$identifier;
7734: #
7735: $Title = '' if (! defined($Title));
7736: $xlabel = '' if (! defined($xlabel));
7737: $ylabel = '' if (! defined($ylabel));
7738: my %ValuesHash =
7739: (
1.369 www 7740: $id.'.title' => &escape($Title),
7741: $id.'.xlabel' => &escape($xlabel),
7742: $id.'.ylabel' => &escape($ylabel),
1.136 matthew 7743: $id.'.labels' => join(',',@$Xlabels),
7744: $id.'.PlotType' => 'XY',
7745: $id.'.NumSets' => 2,
1.137 matthew 7746: $id.'.two_axes' => 1,
7747: $id.'.y1_max_value' => $Max1,
7748: $id.'.y1_min_value' => $Min1,
7749: $id.'.y2_max_value' => $Max2,
7750: $id.'.y2_min_value' => $Min2,
1.136 matthew 7751: );
7752: #
1.137 matthew 7753: if (defined($colors) && ref($colors) eq 'ARRAY') {
7754: $ValuesHash{$id.'.Colors'} = join(',',@{$colors});
7755: }
7756: #
7757: if (! ref($Ydata1) || ref($Ydata1) ne 'ARRAY' ||
7758: ! ref($Ydata2) || ref($Ydata2) ne 'ARRAY'){
1.136 matthew 7759: return '';
7760: }
7761: my $NumSets=1;
1.137 matthew 7762: foreach my $array ($Ydata1,$Ydata2){
1.136 matthew 7763: next if (! ref($array));
7764: $ValuesHash{$id.'.data.'.$NumSets++} = join(',',@$array);
1.137 matthew 7765: }
7766: #
7767: # Deal with other parameters
7768: while (my ($key,$value) = each(%Values)) {
7769: $ValuesHash{$id.'.'.$key} = $value;
1.136 matthew 7770: }
7771: #
1.646 raeburn 7772: &Apache::lonnet::appenv(\%ValuesHash);
1.130 albertel 7773: return '<img src="/cgi-bin/graph.png?'.$identifier.'" border="1" />';
1.139 matthew 7774: }
7775:
7776: ############################################################
7777: ############################################################
7778:
7779: =pod
7780:
1.157 matthew 7781: =back
7782:
1.139 matthew 7783: =head1 Statistics helper routines?
7784:
7785: Bad place for them but what the hell.
7786:
1.157 matthew 7787: =over 4
7788:
1.648 raeburn 7789: =item * &chartlink()
1.139 matthew 7790:
7791: Returns a link to the chart for a specific student.
7792:
7793: Inputs:
7794:
7795: =over 4
7796:
7797: =item $linktext: The text of the link
7798:
7799: =item $sname: The students username
7800:
7801: =item $sdomain: The students domain
7802:
7803: =back
7804:
1.157 matthew 7805: =back
7806:
1.139 matthew 7807: =cut
7808:
7809: ############################################################
7810: ############################################################
7811: sub chartlink {
7812: my ($linktext, $sname, $sdomain) = @_;
7813: my $link = '<a href="/adm/statistics?reportSelected=student_assessment'.
1.369 www 7814: '&SelectedStudent='.&escape($sname.':'.$sdomain).
1.219 albertel 7815: '&chartoutputmode='.HTML::Entities::encode('html, with all links').
1.139 matthew 7816: '">'.$linktext.'</a>';
1.153 matthew 7817: }
7818:
7819: #######################################################
7820: #######################################################
7821:
7822: =pod
7823:
7824: =head1 Course Environment Routines
1.157 matthew 7825:
7826: =over 4
1.153 matthew 7827:
1.648 raeburn 7828: =item * &restore_course_settings()
1.153 matthew 7829:
1.648 raeburn 7830: =item * &store_course_settings()
1.153 matthew 7831:
7832: Restores/Store indicated form parameters from the course environment.
7833: Will not overwrite existing values of the form parameters.
7834:
7835: Inputs:
7836: a scalar describing the data (e.g. 'chart', 'problem_analysis')
7837:
7838: a hash ref describing the data to be stored. For example:
7839:
7840: %Save_Parameters = ('Status' => 'scalar',
7841: 'chartoutputmode' => 'scalar',
7842: 'chartoutputdata' => 'scalar',
7843: 'Section' => 'array',
1.373 raeburn 7844: 'Group' => 'array',
1.153 matthew 7845: 'StudentData' => 'array',
7846: 'Maps' => 'array');
7847:
7848: Returns: both routines return nothing
7849:
1.631 raeburn 7850: =back
7851:
1.153 matthew 7852: =cut
7853:
7854: #######################################################
7855: #######################################################
7856: sub store_course_settings {
1.496 albertel 7857: return &store_settings($env{'request.course.id'},@_);
7858: }
7859:
7860: sub store_settings {
1.153 matthew 7861: # save to the environment
7862: # appenv the same items, just to be safe
1.300 albertel 7863: my $udom = $env{'user.domain'};
7864: my $uname = $env{'user.name'};
1.496 albertel 7865: my ($context,$prefix,$Settings) = @_;
1.153 matthew 7866: my %SaveHash;
7867: my %AppHash;
7868: while (my ($setting,$type) = each(%$Settings)) {
1.496 albertel 7869: my $basename = join('.','internal',$context,$prefix,$setting);
1.300 albertel 7870: my $envname = 'environment.'.$basename;
1.258 albertel 7871: if (exists($env{'form.'.$setting})) {
1.153 matthew 7872: # Save this value away
7873: if ($type eq 'scalar' &&
1.258 albertel 7874: (! exists($env{$envname}) ||
7875: $env{$envname} ne $env{'form.'.$setting})) {
7876: $SaveHash{$basename} = $env{'form.'.$setting};
7877: $AppHash{$envname} = $env{'form.'.$setting};
1.153 matthew 7878: } elsif ($type eq 'array') {
7879: my $stored_form;
1.258 albertel 7880: if (ref($env{'form.'.$setting})) {
1.153 matthew 7881: $stored_form = join(',',
7882: map {
1.369 www 7883: &escape($_);
1.258 albertel 7884: } sort(@{$env{'form.'.$setting}}));
1.153 matthew 7885: } else {
7886: $stored_form =
1.369 www 7887: &escape($env{'form.'.$setting});
1.153 matthew 7888: }
7889: # Determine if the array contents are the same.
1.258 albertel 7890: if ($stored_form ne $env{$envname}) {
1.153 matthew 7891: $SaveHash{$basename} = $stored_form;
7892: $AppHash{$envname} = $stored_form;
7893: }
7894: }
7895: }
7896: }
7897: my $put_result = &Apache::lonnet::put('environment',\%SaveHash,
1.300 albertel 7898: $udom,$uname);
1.153 matthew 7899: if ($put_result !~ /^(ok|delayed)/) {
7900: &Apache::lonnet::logthis('unable to save form parameters, '.
7901: 'got error:'.$put_result);
7902: }
7903: # Make sure these settings stick around in this session, too
1.646 raeburn 7904: &Apache::lonnet::appenv(\%AppHash);
1.153 matthew 7905: return;
7906: }
7907:
7908: sub restore_course_settings {
1.499 albertel 7909: return &restore_settings($env{'request.course.id'},@_);
1.496 albertel 7910: }
7911:
7912: sub restore_settings {
7913: my ($context,$prefix,$Settings) = @_;
1.153 matthew 7914: while (my ($setting,$type) = each(%$Settings)) {
1.258 albertel 7915: next if (exists($env{'form.'.$setting}));
1.496 albertel 7916: my $envname = 'environment.internal.'.$context.'.'.$prefix.
1.153 matthew 7917: '.'.$setting;
1.258 albertel 7918: if (exists($env{$envname})) {
1.153 matthew 7919: if ($type eq 'scalar') {
1.258 albertel 7920: $env{'form.'.$setting} = $env{$envname};
1.153 matthew 7921: } elsif ($type eq 'array') {
1.258 albertel 7922: $env{'form.'.$setting} = [
1.153 matthew 7923: map {
1.369 www 7924: &unescape($_);
1.258 albertel 7925: } split(',',$env{$envname})
1.153 matthew 7926: ];
7927: }
7928: }
7929: }
1.127 matthew 7930: }
7931:
1.618 raeburn 7932: #######################################################
7933: #######################################################
7934:
7935: =pod
7936:
7937: =head1 Domain E-mail Routines
7938:
7939: =over 4
7940:
1.648 raeburn 7941: =item * &build_recipient_list()
1.618 raeburn 7942:
7943: Build recipient lists for three types of e-mail:
7944: (a) Error Reports, (b) Package Updates, (c) Help requests, generated by
1.619 raeburn 7945: lonerrorhandler.pm, CHECKRPMS and lonsupportreq.pm respectively.
1.618 raeburn 7946:
7947: Inputs:
1.619 raeburn 7948: defmail (scalar - email address of default recipient),
1.618 raeburn 7949: mailing type (scalar - errormail, packagesmail, or helpdeskmail),
1.619 raeburn 7950: defdom (domain for which to retrieve configuration settings),
7951: origmail (scalar - email address of recipient from loncapa.conf,
7952: i.e., predates configuration by DC via domainprefs.pm
1.618 raeburn 7953:
7954: Returns: comma separated list of addresses to which to send e-mail.
7955:
7956: =cut
7957:
7958: ############################################################
7959: ############################################################
7960: sub build_recipient_list {
1.619 raeburn 7961: my ($defmail,$mailing,$defdom,$origmail) = @_;
1.618 raeburn 7962: my @recipients;
7963: my $otheremails;
7964: my %domconfig =
7965: &Apache::lonnet::get_dom('configuration',['contacts'],$defdom);
7966: if (ref($domconfig{'contacts'}) eq 'HASH') {
7967: if (ref($domconfig{'contacts'}{$mailing}) eq 'HASH') {
7968: my @contacts = ('adminemail','supportemail');
7969: foreach my $item (@contacts) {
7970: if ($domconfig{'contacts'}{$mailing}{$item}) {
1.619 raeburn 7971: my $addr = $domconfig{'contacts'}{$item};
7972: if (!grep(/^\Q$addr\E$/,@recipients)) {
7973: push(@recipients,$addr);
7974: }
1.618 raeburn 7975: }
7976: $otheremails = $domconfig{'contacts'}{$mailing}{'others'};
7977: }
7978: }
1.619 raeburn 7979: } elsif ($origmail ne '') {
7980: push(@recipients,$origmail);
1.618 raeburn 7981: }
7982: if ($defmail ne '') {
7983: push(@recipients,$defmail);
7984: }
7985: if ($otheremails) {
1.619 raeburn 7986: my @others;
7987: if ($otheremails =~ /,/) {
7988: @others = split(/,/,$otheremails);
1.618 raeburn 7989: } else {
1.619 raeburn 7990: push(@others,$otheremails);
7991: }
7992: foreach my $addr (@others) {
7993: if (!grep(/^\Q$addr\E$/,@recipients)) {
7994: push(@recipients,$addr);
7995: }
1.618 raeburn 7996: }
7997: }
1.619 raeburn 7998: my $recipientlist = join(',',@recipients);
1.618 raeburn 7999: return $recipientlist;
8000: }
8001:
1.127 matthew 8002: ############################################################
8003: ############################################################
1.154 albertel 8004:
1.443 albertel 8005: sub commit_customrole {
8006: my ($udom,$uname,$url,$three,$four,$five,$start,$end) = @_;
1.630 raeburn 8007: my $output = &mt('Assigning custom role').' "'.$five.'" by '.$four.':'.$three.' in '.$url.
1.443 albertel 8008: ($start?', '.&mt('starting').' '.localtime($start):'').
8009: ($end?', ending '.localtime($end):'').': <b>'.
8010: &Apache::lonnet::assigncustomrole(
8011: $udom,$uname,$url,$three,$four,$five,$end,$start).
8012: '</b><br />';
8013: return $output;
8014: }
8015:
8016: sub commit_standardrole {
1.541 raeburn 8017: my ($udom,$uname,$url,$three,$start,$end,$one,$two,$sec,$context) = @_;
8018: my ($output,$logmsg,$linefeed);
8019: if ($context eq 'auto') {
8020: $linefeed = "\n";
8021: } else {
8022: $linefeed = "<br />\n";
8023: }
1.443 albertel 8024: if ($three eq 'st') {
1.541 raeburn 8025: my $result = &commit_studentrole(\$logmsg,$udom,$uname,$url,$three,$start,$end,
8026: $one,$two,$sec,$context);
8027: if (($result =~ /^error/) || ($result eq 'not_in_class') ||
1.626 raeburn 8028: ($result eq 'unknown_course') || ($result eq 'refused')) {
8029: $output = $logmsg.' '.&mt('Error: ').$result."\n";
1.443 albertel 8030: } else {
1.541 raeburn 8031: $output = $logmsg.$linefeed.&mt('Assigning').' '.$three.' in '.$url.
1.443 albertel 8032: ($start?', '.&mt('starting').' '.localtime($start):'').
1.541 raeburn 8033: ($end?', '.&mt('ending').' '.localtime($end):'').': ';
8034: if ($context eq 'auto') {
8035: $output .= $result.$linefeed.&mt('Add to classlist').': ok';
8036: } else {
8037: $output .= '<b>'.$result.'</b>'.$linefeed.
8038: &mt('Add to classlist').': <b>ok</b>';
8039: }
8040: $output .= $linefeed;
1.443 albertel 8041: }
8042: } else {
8043: $output = &mt('Assigning').' '.$three.' in '.$url.
8044: ($start?', '.&mt('starting').' '.localtime($start):'').
1.541 raeburn 8045: ($end?', '.&mt('ending').' '.localtime($end):'').': ';
1.652 raeburn 8046: my $result = &Apache::lonnet::assignrole($udom,$uname,$url,$three,$end,$start,'','',$context);
1.541 raeburn 8047: if ($context eq 'auto') {
8048: $output .= $result.$linefeed;
8049: } else {
8050: $output .= '<b>'.$result.'</b>'.$linefeed;
8051: }
1.443 albertel 8052: }
8053: return $output;
8054: }
8055:
8056: sub commit_studentrole {
1.541 raeburn 8057: my ($logmsg,$udom,$uname,$url,$three,$start,$end,$one,$two,$sec,$context) = @_;
1.626 raeburn 8058: my ($result,$linefeed,$oldsecurl,$newsecurl);
1.541 raeburn 8059: if ($context eq 'auto') {
8060: $linefeed = "\n";
8061: } else {
8062: $linefeed = '<br />'."\n";
8063: }
1.443 albertel 8064: if (defined($one) && defined($two)) {
8065: my $cid=$one.'_'.$two;
8066: my $oldsec=&Apache::lonnet::getsection($udom,$uname,$cid);
8067: my $secchange = 0;
8068: my $expire_role_result;
8069: my $modify_section_result;
1.628 raeburn 8070: if ($oldsec ne '-1') {
8071: if ($oldsec ne $sec) {
1.443 albertel 8072: $secchange = 1;
1.628 raeburn 8073: my $now = time;
1.443 albertel 8074: my $uurl='/'.$cid;
8075: $uurl=~s/\_/\//g;
8076: if ($oldsec) {
8077: $uurl.='/'.$oldsec;
8078: }
1.626 raeburn 8079: $oldsecurl = $uurl;
1.628 raeburn 8080: $expire_role_result =
1.652 raeburn 8081: &Apache::lonnet::assignrole($udom,$uname,$uurl,'st',$now,'','',$context);
1.628 raeburn 8082: if ($env{'request.course.sec'} ne '') {
8083: if ($expire_role_result eq 'refused') {
8084: my @roles = ('st');
8085: my @statuses = ('previous');
8086: my @roledoms = ($one);
8087: my $withsec = 1;
8088: my %roleshash =
8089: &Apache::lonnet::get_my_roles($uname,$udom,'userroles',
8090: \@statuses,\@roles,\@roledoms,$withsec);
8091: if (defined ($roleshash{$two.':'.$one.':st:'.$oldsec})) {
8092: my ($oldstart,$oldend) =
8093: split(':',$roleshash{$two.':'.$one.':st:'.$oldsec});
8094: if ($oldend > 0 && $oldend <= $now) {
8095: $expire_role_result = 'ok';
8096: }
8097: }
8098: }
8099: }
1.443 albertel 8100: $result = $expire_role_result;
8101: }
8102: }
8103: if (($expire_role_result eq 'ok') || ($secchange == 0)) {
1.652 raeburn 8104: $modify_section_result = &Apache::lonnet::modify_student_enrollment($udom,$uname,undef,undef,undef,undef,undef,$sec,$end,$start,'','',$cid,'',$context);
1.443 albertel 8105: if ($modify_section_result =~ /^ok/) {
8106: if ($secchange == 1) {
1.628 raeburn 8107: if ($sec eq '') {
8108: $$logmsg .= &mt('Section for [_1] switched from (possibly expired) old section: [_2] to student role without a section.',$uname,$oldsec).$linefeed;
8109: } else {
8110: $$logmsg .= &mt('Section for [_1] switched from (possibly expired) old section: [_2] to new section: [_3].',$uname,$oldsec,$sec).$linefeed;
8111: }
1.443 albertel 8112: } elsif ($oldsec eq '-1') {
1.628 raeburn 8113: if ($sec eq '') {
8114: $$logmsg .= &mt('New student role without a section for [_1] in course [_2].',$uname,$cid).$linefeed;
8115: } else {
8116: $$logmsg .= &mt('New student role for [_1] in section [_2] in course [_3].',$uname,$sec,$cid).$linefeed;
8117: }
1.443 albertel 8118: } else {
1.628 raeburn 8119: if ($sec eq '') {
8120: $$logmsg .= &mt('Student [_1] assigned to course [_2] without a section.',$uname,$cid).$linefeed;
8121: } else {
8122: $$logmsg .= &mt('Student [_1] assigned to section [_2] in course [_3].',$uname,$sec,$cid).$linefeed;
8123: }
1.443 albertel 8124: }
8125: } else {
1.628 raeburn 8126: if ($secchange) {
8127: $$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;
8128: } else {
8129: $$logmsg .= &mt('Error when attempting to modify role for [_1] for section: "[_2]" in course [_3] -error:',$uname,$sec,$cid).' '.$modify_section_result.$linefeed;
8130: }
1.443 albertel 8131: }
8132: $result = $modify_section_result;
8133: } elsif ($secchange == 1) {
1.628 raeburn 8134: if ($oldsec eq '') {
8135: $$logmsg .= &mt('Error when attempting to expire existing role without a section for [_1] in course [_3] -error: ',$uname,$cid).' '.$expire_role_result.$linefeed;
8136: } else {
8137: $$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;
8138: }
1.626 raeburn 8139: if ($expire_role_result eq 'refused') {
8140: my $newsecurl = '/'.$cid;
8141: $newsecurl =~ s/\_/\//g;
8142: if ($sec ne '') {
8143: $newsecurl.='/'.$sec;
8144: }
8145: if (&Apache::lonnet::allowed('cst',$newsecurl) && !(&Apache::lonnet::allowed('cst',$oldsecurl))) {
8146: if ($sec eq '') {
8147: $$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;
8148: } else {
8149: $$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;
8150: }
8151: }
8152: }
1.443 albertel 8153: }
8154: } else {
1.626 raeburn 8155: $$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 8156: $result = "error: incomplete course id\n";
8157: }
8158: return $result;
8159: }
8160:
8161: ############################################################
8162: ############################################################
8163:
1.566 albertel 8164: sub check_clone {
1.578 raeburn 8165: my ($args,$linefeed) = @_;
1.566 albertel 8166: my $cloneid='/'.$args->{'clonedomain'}.'/'.$args->{'clonecourse'};
8167: my ($clonecrsudom,$clonecrsunum)= &LONCAPA::split_courseid($cloneid);
8168: my $clonehome=&Apache::lonnet::homeserver($clonecrsunum,$clonecrsudom);
8169: my $clonemsg;
8170: my $can_clone = 0;
8171:
8172: if ($clonehome eq 'no_host') {
1.578 raeburn 8173: $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 8174: } else {
8175: my %clonedesc = &Apache::lonnet::coursedescription($cloneid,{'one_time' => 1});
1.568 albertel 8176: if ($env{'request.role.domain'} eq $args->{'clonedomain'}) {
1.566 albertel 8177: $can_clone = 1;
8178: } else {
8179: my %clonehash = &Apache::lonnet::get('environment',['cloners'],
8180: $args->{'clonedomain'},$args->{'clonecourse'});
8181: my @cloners = split(/,/,$clonehash{'cloners'});
1.578 raeburn 8182: if (grep(/^\*$/,@cloners)) {
8183: $can_clone = 1;
8184: } elsif (grep(/^\*\:\Q$args->{'ccdomain'}\E$/,@cloners)) {
8185: $can_clone = 1;
8186: } else {
8187: my %roleshash =
8188: &Apache::lonnet::get_my_roles($args->{'ccuname'},
8189: $args->{'ccdomain'},
8190: 'userroles',['active'],['cc'],
8191: [$args->{'clonedomain'}]);
8192: if (($roleshash{$args->{'clonecourse'}.':'.$args->{'clonedomain'}.':cc'}) || (grep(/^\Q$args->{'ccuname'}\E:\Q$args->{'ccdomain'}\E$/,@cloners))) {
8193: $can_clone = 1;
8194: } else {
8195: $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'});
8196: }
1.566 albertel 8197: }
1.578 raeburn 8198: }
1.566 albertel 8199: }
8200: return ($can_clone, $clonemsg, $cloneid, $clonehome);
8201: }
8202:
1.444 albertel 8203: sub construct_course {
1.541 raeburn 8204: my ($args,$logmsg,$courseid,$crsudom,$crsunum,$udom,$uname,$context) = @_;
1.444 albertel 8205: my $outcome;
1.541 raeburn 8206: my $linefeed = '<br />'."\n";
8207: if ($context eq 'auto') {
8208: $linefeed = "\n";
8209: }
1.566 albertel 8210:
8211: #
8212: # Are we cloning?
8213: #
8214: my ($can_clone, $clonemsg, $cloneid, $clonehome);
8215: if (($args->{'clonecourse'}) && ($args->{'clonedomain'})) {
1.578 raeburn 8216: ($can_clone, $clonemsg, $cloneid, $clonehome) = &check_clone($args,$linefeed);
1.566 albertel 8217: if ($context ne 'auto') {
1.578 raeburn 8218: if ($clonemsg ne '') {
8219: $clonemsg = '<span class="LC_error">'.$clonemsg.'</span>';
8220: }
1.566 albertel 8221: }
8222: $outcome .= $clonemsg.$linefeed;
8223:
8224: if (!$can_clone) {
8225: return (0,$outcome);
8226: }
8227: }
8228:
1.444 albertel 8229: #
8230: # Open course
8231: #
8232: my $crstype = lc($args->{'crstype'});
8233: my %cenv=();
8234: $$courseid=&Apache::lonnet::createcourse($args->{'course_domain'},
8235: $args->{'cdescr'},
8236: $args->{'curl'},
8237: $args->{'course_home'},
8238: $args->{'nonstandard'},
8239: $args->{'crscode'},
8240: $args->{'ccuname'}.':'.
8241: $args->{'ccdomain'},
8242: $args->{'crstype'});
8243:
8244: # Note: The testing routines depend on this being output; see
8245: # Utils::Course. This needs to at least be output as a comment
8246: # if anyone ever decides to not show this, and Utils::Course::new
8247: # will need to be suitably modified.
1.541 raeburn 8248: $outcome .= &mt('New LON-CAPA [_1] ID: [_2]',$crstype,$$courseid).$linefeed;
1.444 albertel 8249: #
8250: # Check if created correctly
8251: #
1.479 albertel 8252: ($$crsudom,$$crsunum)= &LONCAPA::split_courseid($$courseid);
1.444 albertel 8253: my $crsuhome=&Apache::lonnet::homeserver($$crsunum,$$crsudom);
1.541 raeburn 8254: $outcome .= &mt('Created on').': '.$crsuhome.$linefeed;
1.566 albertel 8255:
1.444 albertel 8256: #
1.566 albertel 8257: # Do the cloning
8258: #
8259: if ($can_clone && $cloneid) {
8260: $clonemsg = &mt('Cloning [_1] from [_2]',$crstype,$clonehome);
8261: if ($context ne 'auto') {
8262: $clonemsg = '<span class="LC_success">'.$clonemsg.'</span>';
8263: }
8264: $outcome .= $clonemsg.$linefeed;
8265: my %oldcenv=&Apache::lonnet::dump('environment',$$crsudom,$$crsunum);
1.444 albertel 8266: # Copy all files
1.637 www 8267: &Apache::lonclonecourse::copycoursefiles($cloneid,$$courseid,$args->{'datemode'},$args->{'dateshift'});
1.444 albertel 8268: # Restore URL
1.566 albertel 8269: $cenv{'url'}=$oldcenv{'url'};
1.444 albertel 8270: # Restore title
1.566 albertel 8271: $cenv{'description'}=$oldcenv{'description'};
1.444 albertel 8272: # Mark as cloned
1.566 albertel 8273: $cenv{'clonedfrom'}=$cloneid;
1.638 www 8274: # Need to clone grading mode
8275: my %newenv=&Apache::lonnet::get('environment',['grading'],$$crsudom,$$crsunum);
8276: $cenv{'grading'}=$newenv{'grading'};
8277: # Do not clone these environment entries
8278: &Apache::lonnet::del('environment',
8279: ['default_enrollment_start_date',
8280: 'default_enrollment_end_date',
8281: 'question.email',
8282: 'policy.email',
8283: 'comment.email',
8284: 'pch.users.denied',
8285: 'plc.users.denied'],
8286: $$crsudom,$$crsunum);
1.444 albertel 8287: }
1.566 albertel 8288:
1.444 albertel 8289: #
8290: # Set environment (will override cloned, if existing)
8291: #
8292: my @sections = ();
8293: my @xlists = ();
8294: if ($args->{'crstype'}) {
8295: $cenv{'type'}=$args->{'crstype'};
8296: }
8297: if ($args->{'crsid'}) {
8298: $cenv{'courseid'}=$args->{'crsid'};
8299: }
8300: if ($args->{'crscode'}) {
8301: $cenv{'internal.coursecode'}=$args->{'crscode'};
8302: }
8303: if ($args->{'crsquota'} ne '') {
8304: $cenv{'internal.coursequota'}=$args->{'crsquota'};
8305: } else {
8306: $cenv{'internal.coursequota'}=$args->{'crsquota'} = 20;
8307: }
8308: if ($args->{'ccuname'}) {
8309: $cenv{'internal.courseowner'} = $args->{'ccuname'}.
8310: ':'.$args->{'ccdomain'};
8311: } else {
8312: $cenv{'internal.courseowner'} = $args->{'curruser'};
8313: }
8314: my @badclasses = (); # Used to accumulate sections/crosslistings that did not pass classlist access check for course owner.
8315: if ($args->{'crssections'}) {
8316: $cenv{'internal.sectionnums'} = '';
8317: if ($args->{'crssections'} =~ m/,/) {
8318: @sections = split/,/,$args->{'crssections'};
8319: } else {
8320: $sections[0] = $args->{'crssections'};
8321: }
8322: if (@sections > 0) {
8323: foreach my $item (@sections) {
8324: my ($sec,$gp) = split/:/,$item;
8325: my $class = $args->{'crscode'}.$sec;
8326: my $addcheck = &Apache::lonnet::auto_new_course($$crsunum,$$crsudom,$class,$cenv{'internal.courseowner'});
8327: $cenv{'internal.sectionnums'} .= $item.',';
8328: unless ($addcheck eq 'ok') {
8329: push @badclasses, $class;
8330: }
8331: }
8332: $cenv{'internal.sectionnums'} =~ s/,$//;
8333: }
8334: }
8335: # do not hide course coordinator from staff listing,
8336: # even if privileged
8337: $cenv{'nothideprivileged'}=$args->{'ccuname'}.':'.$args->{'ccdomain'};
8338: # add crosslistings
8339: if ($args->{'crsxlist'}) {
8340: $cenv{'internal.crosslistings'}='';
8341: if ($args->{'crsxlist'} =~ m/,/) {
8342: @xlists = split/,/,$args->{'crsxlist'};
8343: } else {
8344: $xlists[0] = $args->{'crsxlist'};
8345: }
8346: if (@xlists > 0) {
8347: foreach my $item (@xlists) {
8348: my ($xl,$gp) = split/:/,$item;
8349: my $addcheck = &Apache::lonnet::auto_new_course($$crsunum,$$crsudom,$xl,$cenv{'internal.courseowner'});
8350: $cenv{'internal.crosslistings'} .= $item.',';
8351: unless ($addcheck eq 'ok') {
8352: push @badclasses, $xl;
8353: }
8354: }
8355: $cenv{'internal.crosslistings'} =~ s/,$//;
8356: }
8357: }
8358: if ($args->{'autoadds'}) {
8359: $cenv{'internal.autoadds'}=$args->{'autoadds'};
8360: }
8361: if ($args->{'autodrops'}) {
8362: $cenv{'internal.autodrops'}=$args->{'autodrops'};
8363: }
8364: # check for notification of enrollment changes
8365: my @notified = ();
8366: if ($args->{'notify_owner'}) {
8367: if ($args->{'ccuname'} ne '') {
8368: push(@notified,$args->{'ccuname'}.':'.$args->{'ccdomain'});
8369: }
8370: }
8371: if ($args->{'notify_dc'}) {
8372: if ($uname ne '') {
1.630 raeburn 8373: push(@notified,$uname.':'.$udom);
1.444 albertel 8374: }
8375: }
8376: if (@notified > 0) {
8377: my $notifylist;
8378: if (@notified > 1) {
8379: $notifylist = join(',',@notified);
8380: } else {
8381: $notifylist = $notified[0];
8382: }
8383: $cenv{'internal.notifylist'} = $notifylist;
8384: }
8385: if (@badclasses > 0) {
8386: my %lt=&Apache::lonlocal::texthash(
8387: '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',
8388: 'dnhr' => 'does not have rights to access enrollment in these classes',
8389: 'adby' => 'as determined by the policies of your institution on access to official classlists'
8390: );
1.541 raeburn 8391: my $badclass_msg = $cenv{'internal.courseowner'}.') - '.$lt{'dnhr'}.
8392: ' ('.$lt{'adby'}.')';
8393: if ($context eq 'auto') {
8394: $outcome .= $badclass_msg.$linefeed;
1.566 albertel 8395: $outcome .= '<div class="LC_warning">'.$badclass_msg.$linefeed.'<ul>'."\n";
1.541 raeburn 8396: foreach my $item (@badclasses) {
8397: if ($context eq 'auto') {
8398: $outcome .= " - $item\n";
8399: } else {
8400: $outcome .= "<li>$item</li>\n";
8401: }
8402: }
8403: if ($context eq 'auto') {
8404: $outcome .= $linefeed;
8405: } else {
1.566 albertel 8406: $outcome .= "</ul><br /><br /></div>\n";
1.541 raeburn 8407: }
8408: }
1.444 albertel 8409: }
8410: if ($args->{'no_end_date'}) {
8411: $args->{'endaccess'} = 0;
8412: }
8413: $cenv{'internal.autostart'}=$args->{'enrollstart'};
8414: $cenv{'internal.autoend'}=$args->{'enrollend'};
8415: $cenv{'default_enrollment_start_date'}=$args->{'startaccess'};
8416: $cenv{'default_enrollment_end_date'}=$args->{'endaccess'};
8417: if ($args->{'showphotos'}) {
8418: $cenv{'internal.showphotos'}=$args->{'showphotos'};
8419: }
8420: $cenv{'internal.authtype'} = $args->{'authtype'};
8421: $cenv{'internal.autharg'} = $args->{'autharg'};
8422: if ( ($cenv{'internal.authtype'} =~ /^krb/) && ($cenv{'internal.autoadds'} == 1)) {
8423: if (! defined($cenv{'internal.autharg'}) || $cenv{'internal.autharg'} eq '') {
1.541 raeburn 8424: 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');
8425: if ($context eq 'auto') {
8426: $outcome .= $krb_msg;
8427: } else {
1.566 albertel 8428: $outcome .= '<span class="LC_error">'.$krb_msg.'</span>';
1.541 raeburn 8429: }
8430: $outcome .= $linefeed;
1.444 albertel 8431: }
8432: }
8433: if (($args->{'ccdomain'}) && ($args->{'ccuname'})) {
8434: if ($args->{'setpolicy'}) {
8435: $cenv{'policy.email'}=$args->{'ccuname'}.':'.$args->{'ccdomain'};
8436: }
8437: if ($args->{'setcontent'}) {
8438: $cenv{'question.email'}=$args->{'ccuname'}.':'.$args->{'ccdomain'};
8439: }
8440: }
8441: if ($args->{'reshome'}) {
8442: $cenv{'reshome'}=$args->{'reshome'}.'/';
8443: $cenv{'reshome'}=~s/\/+$/\//;
8444: }
8445: #
8446: # course has keyed access
8447: #
8448: if ($args->{'setkeys'}) {
8449: $cenv{'keyaccess'}='yes';
8450: }
8451: # if specified, key authority is not course, but user
8452: # only active if keyaccess is yes
8453: if ($args->{'keyauth'}) {
1.487 albertel 8454: my ($user,$domain) = split(':',$args->{'keyauth'});
8455: $user = &LONCAPA::clean_username($user);
8456: $domain = &LONCAPA::clean_username($domain);
1.488 foxr 8457: if ($user ne '' && $domain ne '') {
1.487 albertel 8458: $cenv{'keyauth'}=$user.':'.$domain;
1.444 albertel 8459: }
8460: }
8461:
8462: if ($args->{'disresdis'}) {
8463: $cenv{'pch.roles.denied'}='st';
8464: }
8465: if ($args->{'disablechat'}) {
8466: $cenv{'plc.roles.denied'}='st';
8467: }
8468:
8469: # Record we've not yet viewed the Course Initialization Helper for this
8470: # course
8471: $cenv{'course.helper.not.run'} = 1;
8472: #
8473: # Use new Randomseed
8474: #
8475: $cenv{'rndseed'}=&Apache::lonnet::latest_rnd_algorithm_id();;
8476: $cenv{'receiptalg'}=&Apache::lonnet::latest_receipt_algorithm_id();;
8477: #
8478: # The encryption code and receipt prefix for this course
8479: #
8480: $cenv{'internal.encseed'}=$Apache::lonnet::perlvar{'lonReceipt'}.$$.time.int(rand(9999));
8481: $cenv{'internal.encpref'}=100+int(9*rand(99));
8482: #
8483: # By default, use standard grading
8484: if (!defined($cenv{'grading'})) { $cenv{'grading'} = 'standard'; }
8485:
1.541 raeburn 8486: $outcome .= $linefeed.&mt('Setting environment').': '.
8487: &Apache::lonnet::put('environment',\%cenv,$$crsudom,$$crsunum).$linefeed;
1.444 albertel 8488: #
8489: # Open all assignments
8490: #
8491: if ($args->{'openall'}) {
8492: my $storeunder=$$crsudom.'_'.$$crsunum.'.0.opendate';
8493: my %storecontent = ($storeunder => time,
8494: $storeunder.'.type' => 'date_start');
8495:
8496: $outcome .= &mt('Opening all assignments').': '.&Apache::lonnet::cput
1.541 raeburn 8497: ('resourcedata',\%storecontent,$$crsudom,$$crsunum).$linefeed;
1.444 albertel 8498: }
8499: #
8500: # Set first page
8501: #
8502: unless (($args->{'nonstandard'}) || ($args->{'firstres'} eq 'blank')
8503: || ($cloneid)) {
1.445 albertel 8504: use LONCAPA::map;
1.444 albertel 8505: $outcome .= &mt('Setting first resource').': ';
1.445 albertel 8506:
8507: my $map = '/uploaded/'.$$crsudom.'/'.$$crsunum.'/default.sequence';
8508: my ($errtext,$fatal)=&LONCAPA::map::mapread($map);
8509:
1.444 albertel 8510: $outcome .= ($fatal?$errtext:'read ok').' - ';
8511: my $title; my $url;
8512: if ($args->{'firstres'} eq 'syl') {
8513: $title='Syllabus';
8514: $url='/public/'.$$crsudom.'/'.$$crsunum.'/syllabus';
8515: } else {
8516: $title='Navigate Contents';
8517: $url='/adm/navmaps';
8518: }
1.445 albertel 8519:
8520: $LONCAPA::map::resources[1]=$title.':'.$url.':false:start:res';
8521: (my $outtext,$errtext) = &LONCAPA::map::storemap($map,1);
8522:
8523: if ($errtext) { $fatal=2; }
1.541 raeburn 8524: $outcome .= ($fatal?$errtext:'write ok').$linefeed;
1.444 albertel 8525: }
1.566 albertel 8526:
8527: return (1,$outcome);
1.444 albertel 8528: }
8529:
8530: ############################################################
8531: ############################################################
8532:
1.378 raeburn 8533: sub course_type {
8534: my ($cid) = @_;
8535: if (!defined($cid)) {
8536: $cid = $env{'request.course.id'};
8537: }
1.404 albertel 8538: if (defined($env{'course.'.$cid.'.type'})) {
8539: return $env{'course.'.$cid.'.type'};
1.378 raeburn 8540: } else {
8541: return 'Course';
1.377 raeburn 8542: }
8543: }
1.156 albertel 8544:
1.406 raeburn 8545: sub group_term {
8546: my $crstype = &course_type();
8547: my %names = (
8548: 'Course' => 'group',
8549: 'Group' => 'team',
8550: );
8551: return $names{$crstype};
8552: }
8553:
1.156 albertel 8554: sub icon {
8555: my ($file)=@_;
1.505 albertel 8556: my $curfext = lc((split(/\./,$file))[-1]);
1.168 albertel 8557: my $iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/unknown.gif';
1.156 albertel 8558: my $embstyle = &Apache::loncommon::fileembstyle($curfext);
1.168 albertel 8559: if (!(!defined($embstyle) || $embstyle eq 'unk' || $embstyle eq 'hdn')) {
8560: if (-e $Apache::lonnet::perlvar{'lonDocRoot'}.'/'.
8561: $Apache::lonnet::perlvar{'lonIconsURL'}.'/'.
8562: $curfext.".gif") {
8563: $iconname=$Apache::lonnet::perlvar{'lonIconsURL'}.'/'.
8564: $curfext.".gif";
8565: }
8566: }
1.249 albertel 8567: return &lonhttpdurl($iconname);
1.154 albertel 8568: }
1.84 albertel 8569:
1.575 albertel 8570: sub lonhttpd_port {
1.215 albertel 8571: my $lonhttpd_port=$Apache::lonnet::perlvar{'lonhttpdPort'};
8572: if (!defined($lonhttpd_port)) { $lonhttpd_port='8080'; }
1.574 albertel 8573: # IE doesn't like a secure page getting images from a non-secure
8574: # port (when logging we haven't parsed the browser type so default
8575: # back to secure
8576: if ((!exists($env{'browser.type'}) || $env{'browser.type'} eq 'explorer')
8577: && $ENV{'SERVER_PORT'} == 443) {
1.575 albertel 8578: return 443;
8579: }
8580: return $lonhttpd_port;
8581:
8582: }
8583:
8584: sub lonhttpdurl {
8585: my ($url)=@_;
8586:
8587: my $lonhttpd_port = &lonhttpd_port();
8588: if ($lonhttpd_port == 443) {
1.574 albertel 8589: return 'https://'.$ENV{'SERVER_NAME'}.$url;
8590: }
1.215 albertel 8591: return 'http://'.$ENV{'SERVER_NAME'}.':'.$lonhttpd_port.$url;
8592: }
8593:
1.213 albertel 8594: sub connection_aborted {
8595: my ($r)=@_;
8596: $r->print(" ");$r->rflush();
8597: my $c = $r->connection;
8598: return $c->aborted();
8599: }
8600:
1.221 foxr 8601: # Escapes strings that may have embedded 's that will be put into
1.222 foxr 8602: # strings as 'strings'.
8603: sub escape_single {
1.221 foxr 8604: my ($input) = @_;
1.223 albertel 8605: $input =~ s/\\/\\\\/g; # Escape the \'s..(must be first)>
1.221 foxr 8606: $input =~ s/\'/\\\'/g; # Esacpe the 's....
8607: return $input;
8608: }
1.223 albertel 8609:
1.222 foxr 8610: # Same as escape_single, but escape's "'s This
8611: # can be used for "strings"
8612: sub escape_double {
8613: my ($input) = @_;
8614: $input =~ s/\\/\\\\/g; # Escape the /'s..(must be first)>
8615: $input =~ s/\"/\\\"/g; # Esacpe the "s....
8616: return $input;
8617: }
1.223 albertel 8618:
1.222 foxr 8619: # Escapes the last element of a full URL.
8620: sub escape_url {
8621: my ($url) = @_;
1.238 raeburn 8622: my @urlslices = split(/\//, $url,-1);
1.369 www 8623: my $lastitem = &escape(pop(@urlslices));
1.223 albertel 8624: return join('/',@urlslices).'/'.$lastitem;
1.222 foxr 8625: }
1.462 albertel 8626:
8627: # -------------------------------------------------------- Initliaze user login
8628: sub init_user_environment {
1.463 albertel 8629: my ($r, $username, $domain, $authhost, $form, $args) = @_;
1.462 albertel 8630: my $lonids=$Apache::lonnet::perlvar{'lonIDsDir'};
8631:
8632: my $public=($username eq 'public' && $domain eq 'public');
8633:
8634: # See if old ID present, if so, remove
8635:
8636: my ($filename,$cookie,$userroles);
8637: my $now=time;
8638:
8639: if ($public) {
8640: my $max_public=100;
8641: my $oldest;
8642: my $oldest_time=0;
8643: for(my $next=1;$next<=$max_public;$next++) {
8644: if (-e $lonids."/publicuser_$next.id") {
8645: my $mtime=(stat($lonids."/publicuser_$next.id"))[9];
8646: if ($mtime<$oldest_time || !$oldest_time) {
8647: $oldest_time=$mtime;
8648: $oldest=$next;
8649: }
8650: } else {
8651: $cookie="publicuser_$next";
8652: last;
8653: }
8654: }
8655: if (!$cookie) { $cookie="publicuser_$oldest"; }
8656: } else {
1.463 albertel 8657: # if this isn't a robot, kill any existing non-robot sessions
8658: if (!$args->{'robot'}) {
8659: opendir(DIR,$lonids);
8660: while ($filename=readdir(DIR)) {
8661: if ($filename=~/^$username\_\d+\_$domain\_$authhost\.id$/) {
8662: unlink($lonids.'/'.$filename);
8663: }
1.462 albertel 8664: }
1.463 albertel 8665: closedir(DIR);
1.462 albertel 8666: }
8667: # Give them a new cookie
1.463 albertel 8668: my $id = ($args->{'robot'} ? 'robot'.$args->{'robot'}
8669: : $now);
8670: $cookie="$username\_$id\_$domain\_$authhost";
1.462 albertel 8671:
8672: # Initialize roles
8673:
8674: $userroles=&Apache::lonnet::rolesinit($domain,$username,$authhost);
8675: }
8676: # ------------------------------------ Check browser type and MathML capability
8677:
8678: my ($httpbrowser,$clientbrowser,$clientversion,$clientmathml,
8679: $clientunicode,$clientos) = &decode_user_agent($r);
8680:
8681: # -------------------------------------- Any accessibility options to remember?
8682: if (($form->{'interface'}) && ($form->{'remember'} eq 'true')) {
8683: foreach my $option ('imagesuppress','appletsuppress',
8684: 'embedsuppress','fontenhance','blackwhite') {
8685: if ($form->{$option} eq 'true') {
8686: &Apache::lonnet::put('environment',{$option => 'on'},
8687: $domain,$username);
8688: } else {
8689: &Apache::lonnet::del('environment',[$option],
8690: $domain,$username);
8691: }
8692: }
8693: }
8694: # ------------------------------------------------------------- Get environment
8695:
8696: my %userenv = &Apache::lonnet::dump('environment',$domain,$username);
8697: my ($tmp) = keys(%userenv);
8698: if ($tmp !~ /^(con_lost|error|no_such_host)/i) {
8699: # default remote control to off
8700: if ($userenv{'remote'} ne 'on') { $userenv{'remote'} = 'off'; }
8701: } else {
8702: undef(%userenv);
8703: }
8704: if (($userenv{'interface'}) && (!$form->{'interface'})) {
8705: $form->{'interface'}=$userenv{'interface'};
8706: }
8707: $env{'environment.remote'}=$userenv{'remote'};
8708: if ($userenv{'texengine'} eq 'ttm') { $clientmathml=1; }
8709:
8710: # --------------- Do not trust query string to be put directly into environment
8711: foreach my $option ('imagesuppress','appletsuppress',
8712: 'embedsuppress','fontenhance','blackwhite',
8713: 'interface','localpath','localres') {
8714: $form->{$option}=~s/[\n\r\=]//gs;
8715: }
8716: # --------------------------------------------------------- Write first profile
8717:
8718: {
8719: my %initial_env =
8720: ("user.name" => $username,
8721: "user.domain" => $domain,
8722: "user.home" => $authhost,
8723: "browser.type" => $clientbrowser,
8724: "browser.version" => $clientversion,
8725: "browser.mathml" => $clientmathml,
8726: "browser.unicode" => $clientunicode,
8727: "browser.os" => $clientos,
8728: "server.domain" => $Apache::lonnet::perlvar{'lonDefDomain'},
8729: "request.course.fn" => '',
8730: "request.course.uri" => '',
8731: "request.course.sec" => '',
8732: "request.role" => 'cm',
8733: "request.role.adv" => $env{'user.adv'},
8734: "request.host" => $ENV{'REMOTE_ADDR'},);
8735:
8736: if ($form->{'localpath'}) {
8737: $initial_env{"browser.localpath"} = $form->{'localpath'};
8738: $initial_env{"browser.localres"} = $form->{'localres'};
8739: }
8740:
8741: if ($public) {
8742: $initial_env{"environment.remote"} = "off";
8743: }
8744: if ($form->{'interface'}) {
8745: $form->{'interface'}=~s/\W//gs;
8746: $initial_env{"browser.interface"} = $form->{'interface'};
8747: $env{'browser.interface'}=$form->{'interface'};
8748: foreach my $option ('imagesuppress','appletsuppress',
8749: 'embedsuppress','fontenhance','blackwhite') {
8750: if (($form->{$option} eq 'true') ||
8751: ($userenv{$option} eq 'on')) {
8752: $initial_env{"browser.$option"} = "on";
8753: }
8754: }
8755: }
8756:
8757: $env{'user.environment'} = "$lonids/$cookie.id";
8758:
8759: if (tie(my %disk_env,'GDBM_File',"$lonids/$cookie.id",
8760: &GDBM_WRCREAT(),0640)) {
8761: &_add_to_env(\%disk_env,\%initial_env);
8762: &_add_to_env(\%disk_env,\%userenv,'environment.');
8763: &_add_to_env(\%disk_env,$userroles);
1.463 albertel 8764: if (ref($args->{'extra_env'})) {
8765: &_add_to_env(\%disk_env,$args->{'extra_env'});
8766: }
1.462 albertel 8767: untie(%disk_env);
8768: } else {
8769: &Apache::lonnet::logthis("<font color=\"blue\">WARNING: ".
8770: 'Could not create environment storage in lonauth: '.$!.'</font>');
8771: return 'error: '.$!;
8772: }
8773: }
8774: $env{'request.role'}='cm';
8775: $env{'request.role.adv'}=$env{'user.adv'};
8776: $env{'browser.type'}=$clientbrowser;
8777:
8778: return $cookie;
8779:
8780: }
8781:
8782: sub _add_to_env {
8783: my ($idf,$env_data,$prefix) = @_;
8784: while (my ($key,$value) = each(%$env_data)) {
8785: $idf->{$prefix.$key} = $value;
8786: $env{$prefix.$key} = $value;
8787: }
8788: }
8789:
8790:
1.41 ng 8791: =pod
8792:
8793: =back
8794:
1.112 bowersj2 8795: =cut
1.41 ng 8796:
1.112 bowersj2 8797: 1;
8798: __END__;
1.41 ng 8799:
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