--- loncom/interface/loncommon.pm 2004/05/03 16:07:18 1.191 +++ loncom/interface/loncommon.pm 2005/05/26 20:49:23 1.262 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # a pile of common routines # -# $Id: loncommon.pm,v 1.191 2004/05/03 16:07:18 matthew Exp $ +# $Id: loncommon.pm,v 1.262 2005/05/26 20:49:23 albertel Exp $ # # Copyright Michigan State University Board of Trustees # @@ -55,11 +55,10 @@ redundancy from other modules and increa package Apache::loncommon; use strict; -use Apache::lonnet(); +use Apache::lonnet; use GDBM_File; use POSIX qw(strftime mktime); use Apache::Constants qw(:common :http :methods); -use Apache::lonmsg(); use Apache::lonmenu(); use Apache::lonlocal; use HTML::Entities; @@ -74,6 +73,7 @@ my $readit; my %language; my %supported_language; my %cprtag; +my %scprtag; my %fe; my %fd; my %category_extensions; @@ -131,6 +131,20 @@ BEGIN { close($fh); } } +# ------------------------------------------------------------------ source copyrights + { + my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}. + '/source_copyright.tab'; + if ( open (my $fh,"<$sourcecopyrightfile") ) { + while (<$fh>) { + next if /^\#/; + chomp; + my ($key,$val)=(split(/\s+/,$_,2)); + $scprtag{$key}=$val; + } + close($fh); + } + } # -------------------------------------------------------------- domain designs @@ -235,8 +249,11 @@ of the element the selection from the se =cut sub browser_and_searcher_javascript { + my ($mode)=@_; + if (!defined($mode)) { $mode='edit'; } my $resurl=&lastresurl(); return < END } sub lastresurl { - if ($ENV{'environment.lastresurl'}) { - return $ENV{'environment.lastresurl'} + if ($env{'environment.lastresurl'}) { + return $env{'environment.lastresurl'} } else { return '/res'; } @@ -303,9 +329,9 @@ sub storeresurl { sub studentbrowser_javascript { unless ( - (($ENV{'request.course.id'}) && - (&Apache::lonnet::allowed('srm',$ENV{'request.course.id'}))) - || ($ENV{'request.role'}=~/^(au|dc|su)/) + (($env{'request.course.id'}) && + (&Apache::lonnet::allowed('srm',$env{'request.course.id'}))) + || ($env{'request.role'}=~/^(au|dc|su)/) ) { return ''; } return (<<'ENDSTDBRW'); + (Help Menu) +ENDTEMPLATE + if ($component_help) { + if (!$text) { + $template=&help_open_topic($component_help,undef,$stayOnPage, + $width,$height).' '.$template; + } else { + my $help_text; + $help_text=&Apache::lonnet::unescape($topic); + $template='
'. + &help_open_topic($component_help,$help_text,$stayOnPage, + $width,$height).''.$template. + '
'; + } + } + if ($text ne '') { $template.='' }; + return $template; +} + sub help_open_bug { my ($topic, $text, $stayOnPage, $width, $height) = @_; - unless ($ENV{'user.adv'}) { return ''; } + unless ($env{'user.adv'}) { return ''; } unless ($Apache::lonnet::perlvar{'BugzillaHost'}) { return ''; } $text = "" if (not defined $text); $stayOnPage = 0 if (not defined $stayOnPage); - if ($ENV{'browser.interface'} eq 'textual' || - $ENV{'environment.remote'} eq 'off' ) { + if ($env{'browser.interface'} eq 'textual' || + $env{'environment.remote'} eq 'off' ) { $stayOnPage=1; } $width = 600 if (not defined $width); @@ -658,8 +777,9 @@ sub help_open_bug { # Add the graphic my $title = &mt('Report a Bug'); + my $bugicon=&lonhttpdurl("/adm/lonMisc/smallBug.gif"); $template .= <<"ENDTEMPLATE"; - (Bug: $topic) + (Bug: $topic) ENDTEMPLATE if ($text ne '') { $template.='' }; return $template; @@ -668,12 +788,12 @@ ENDTEMPLATE sub help_open_faq { my ($topic, $text, $stayOnPage, $width, $height) = @_; - unless ($ENV{'user.adv'}) { return ''; } + unless ($env{'user.adv'}) { return ''; } unless ($Apache::lonnet::perlvar{'FAQHost'}) { return ''; } $text = "" if (not defined $text); $stayOnPage = 0 if (not defined $stayOnPage); - if ($ENV{'browser.interface'} eq 'textual' || - $ENV{'environment.remote'} eq 'off' ) { + if ($env{'browser.interface'} eq 'textual' || + $env{'environment.remote'} eq 'off' ) { $stayOnPage=1; } $width = 350 if (not defined $width); @@ -702,8 +822,9 @@ sub help_open_faq { # Add the graphic my $title = &mt('View the FAQ'); + my $faqicon=&lonhttpdurl("/adm/lonMisc/smallFAQ.gif"); $template .= <<"ENDTEMPLATE"; - (FAQ: $topic) + (FAQ: $topic) ENDTEMPLATE if ($text ne '') { $template.='' }; return $template; @@ -715,6 +836,98 @@ ENDTEMPLATE =pod +=item * change_content_javascript(): + +This and the next function allow you to create small sections of an +otherwise static HTML page that you can update on the fly with +Javascript, even in Netscape 4. + +The Javascript fragment returned by this function (no EscriptE tag) +must be written to the HTML page once. It will prove the Javascript +function "change(name, content)". Calling the change function with the +name of the section +you want to update, matching the name passed to C, and +the new content you want to put in there, will put the content into +that area. + +B: Netscape 4 only reserves enough space for the changable area +to contain room for the original contents. You need to "make space" +for whatever changes you wish to make, and be B to check your +code in Netscape 4. This feature in Netscape 4 is B powerful; +it's adequate for updating a one-line status display, but little more. +This script will set the space to 100% width, so you only need to +worry about height in Netscape 4. + +Modern browsers are much less limiting, and if you can commit to the +user not using Netscape 4, this feature may be used freely with +pretty much any HTML. + +=cut + +sub change_content_javascript { + # If we're on Netscape 4, we need to use Layer-based code + if ($env{'browser.type'} eq 'netscape' && + $env{'browser.version'} =~ /^4\./) { + return (<. $name is +the name you will use to reference the area later; do not repeat the +same name on a given HTML page more then once. $origContent is what +the area will originally contain, which can be left blank. + +=cut + +sub changable_area { + my ($name, $origContent) = @_; + + if ($env{'browser.type'} eq 'netscape' && + $env{'browser.version'} =~ /^4\./) { + # If this is netscape 4, we need to use the Layer tag + return "$origContent"; + } else { + return "$origContent"; + } +} + +=pod + +=back + +=head1 Excel and CSV file utility routines + +=over 4 + +=cut + +############################################################### +############################################################### + +=pod + =item * csv_translate($text) Translate $text to allow it to be output as a 'comma separated values' @@ -727,11 +940,10 @@ format. sub csv_translate { my $text = shift; $text =~ s/\"/\"\"/g; - $text =~ s/\n//g; + $text =~ s/\n/ /g; return $text; } - ############################################################### ############################################################### @@ -755,6 +967,10 @@ Currently supported formats: =item h3 +=item h4 + +=item i + =item date =back @@ -777,8 +993,10 @@ sub define_excel_formats { $format->{'h1'} = $workbook->add_format(bold=>1, size=>18); $format->{'h2'} = $workbook->add_format(bold=>1, size=>16); $format->{'h3'} = $workbook->add_format(bold=>1, size=>14); + $format->{'h4'} = $workbook->add_format(bold=>1, size=>12); + $format->{'i'} = $workbook->add_format(italic=>1); $format->{'date'} = $workbook->add_format(num_format=> - 'mmm d yyyy hh:mm AM/PM'); + 'mm/dd/yyyy hh:mm:ss'); return $format; } @@ -787,84 +1005,83 @@ sub define_excel_formats { =pod -=item * change_content_javascript(): +=item * create_workbook -This and the next function allow you to create small sections of an -otherwise static HTML page that you can update on the fly with -Javascript, even in Netscape 4. +Create an Excel worksheet. If it fails, output message on the +request object and return undefs. -The Javascript fragment returned by this function (no EscriptE tag) -must be written to the HTML page once. It will prove the Javascript -function "change(name, content)". Calling the change function with the -name of the section -you want to update, matching the name passed to C, and -the new content you want to put in there, will put the content into -that area. +Inputs: Apache request object -B: Netscape 4 only reserves enough space for the changable area -to contain room for the original contents. You need to "make space" -for whatever changes you wish to make, and be B to check your -code in Netscape 4. This feature in Netscape 4 is B powerful; -it's adequate for updating a one-line status display, but little more. -This script will set the space to 100% width, so you only need to -worry about height in Netscape 4. - -Modern browsers are much less limiting, and if you can commit to the -user not using Netscape 4, this feature may be used freely with -pretty much any HTML. +Returns (undef) on failure, + Excel worksheet object, scalar with filename, and formats + from &Apache::loncommon::define_excel_formats on success =cut -sub change_content_javascript { - # If we're on Netscape 4, we need to use Layer-based code - if ($ENV{'browser.type'} eq 'netscape' && - $ENV{'browser.version'} =~ /^4\./) { - return (<new('/home/httpd'.$filename); + if (! defined($workbook)) { + $r->log_error("Error creating excel spreadsheet $filename: $!"); + $r->print('

'.&mt("Unable to create new Excel file. ". + "This error has been logged. ". + "Please alert your LON-CAPA administrator"). + '

'); + return (undef); } + # + $workbook->set_tempdir('/home/httpd/perl/tmp'); + # + my $format = &Apache::loncommon::define_excel_formats($workbook); + return ($workbook,$filename,$format); } +############################################################### +############################################################### + =pod -=item * changable_area($name, $origContent): +=item * create_text_file -This provides a "changable area" that can be modified on the fly via -the Javascript code provided in C. $name is -the name you will use to reference the area later; do not repeat the -same name on a given HTML page more then once. $origContent is what -the area will originally contain, which can be left blank. +Create a file to write to and eventually make available to the usre. +If file creation fails, outputs an error message on the request object and +return undefs. -=cut +Inputs: Apache request object, and file suffix -sub changable_area { - my ($name, $origContent) = @_; +Returns (undef) on failure, + Filehandle and filename on success. - if ($ENV{'browser.type'} eq 'netscape' && - $ENV{'browser.version'} =~ /^4\./) { - # If this is netscape 4, we need to use the Layer tag - return "$origContent"; - } else { - return "$origContent"; +=cut + +############################################################### +############################################################### +sub create_text_file { + my ($r,$suffix) = @_; + if (! defined($suffix)) { $suffix = 'txt'; }; + my $fh; + my $filename = '/prtspool/'. + $env{'user.name'}.'_'.$env{'user.domain'}.'_'. + time.'_'.rand(1000000000).'.'.$suffix; + $fh = Apache::File->new('>/home/httpd'.$filename); + if (! defined($fh)) { + $r->log_error("Couldn't open $filename for output $!"); + $r->print("Problems occured in creating the output file. ". + "This error has been logged. ". + "Please alert your LON-CAPA administrator."); } + return ($fh,$filename) } -=pod + +=pod =back @@ -926,7 +1143,7 @@ sub multiple_select_form { $output.="\n\n"; @@ -957,7 +1174,7 @@ sub select_form { } foreach (@keys) { $selectform.="\n"; } $selectform.=""; @@ -994,7 +1211,7 @@ sub select_level_form { my $selectform = ""; @@ -1024,7 +1241,7 @@ sub select_dom_form { my $selectdomain = ""; @@ -1123,9 +1340,11 @@ Outputs: ############################################################### ############################################################### sub decode_user_agent { + my ($r)=@_; my @browsertype=split(/\&/,$Apache::lonnet::perlvar{"lonBrowsDet"}); my %mathcap=split(/\&/,$$Apache::lonnet::perlvar{"lonMathML"}); my $httpbrowser=$ENV{"HTTP_USER_AGENT"}; + if (!$httpbrowser && $r) { $httpbrowser=$r->header_in('User-Agent'); } my $clientbrowser='unknown'; my $clientversion='0'; my $clientmathml=''; @@ -1640,21 +1859,26 @@ sub get_related_words { =over 4 -=item * plainname($uname,$udom) +=item * plainname($uname,$udom,$first) Takes a users logon name and returns it as a string in -"first middle last generation" form +"first middle last generation" form +if $first is set to 'lastname' then it returns it as +'lastname generation, firstname middlename' if their is a lastname =cut ############################################################### sub plainname { - my ($uname,$udom)=@_; + my ($uname,$udom,$first)=@_; my %names=&Apache::lonnet::get('environment', ['firstname','middlename','lastname','generation'], $udom,$uname); - my $name=$names{'firstname'}.' '.$names{'middlename'}.' '. - $names{'lastname'}.' '.$names{'generation'}; + my $name=&Apache::lonnet::format_name($names{'firstname'}, + $names{'middlename'}, + $names{'lastname'}, + $names{'generation'},$first); + $name=~s/^\s+//; $name=~s/\s+$//; $name=~s/\s+/ /g; if ($name !~ /\S/) { $name=$uname.'@'.$udom; } @@ -1680,8 +1904,19 @@ if the user does not sub nickname { my ($uname,$udom)=@_; - my %names=&Apache::lonnet::get('environment', - ['nickname','firstname','middlename','lastname','generation'],$udom,$uname); + my %names; + if ($uname eq $env{'user.name'} && + $udom eq $env{'user.domain'}) { + %names=('nickname' => $env{'environment.nickname'} , + 'firstname' => $env{'environment.firstname'} , + 'middlename' => $env{'environment.middlename'}, + 'lastname' => $env{'environment.lastname'} , + 'generation' => $env{'environment.generation'}); + } else { + %names=&Apache::lonnet::get('environment', + ['nickname','firstname','middlename', + 'lastname','generation'],$udom,$uname); + } my $name=$names{'nickname'}; if ($name) { $name='"'.$name.'"'; @@ -1707,17 +1942,21 @@ Gets a users screenname and returns it a sub screenname { my ($uname,$udom)=@_; - my %names= - &Apache::lonnet::get('environment',['screenname'],$udom,$uname); + if ($uname eq $env{'user.name'} && + $udom eq $env{'user.domain'}) {return $env{'environment.screenname'};} + my %names=&Apache::lonnet::get('environment',['screenname'],$udom,$uname); return $names{'screenname'}; } + # ------------------------------------------------------------- Message Wrapper sub messagewrapper { - my ($link,$un,$do)=@_; + my ($link,$username,$domain)=@_; return -"$link"; + ''.$link.''; } # --------------------------------------------------------------- Notes Wrapper @@ -1730,8 +1969,8 @@ sub noteswrapper { sub aboutmewrapper { my ($link,$username,$domain,$target)=@_; - return "$link"; + return ''.$link.''; } # ------------------------------------------------------------ Syllabus Wrapper @@ -1742,9 +1981,28 @@ sub syllabuswrapper { if ($fontcolor) { $linktext=''.$linktext.''; } - return "$linktext"; + return qq{$linktext}; } +sub track_student_link { + my ($linktext,$sname,$sdom,$target) = @_; + my $link ="/adm/trackstudent"; + my $title = 'View recent activity'; + if (defined($sname) && $sname !~ /^\s*$/ && + defined($sdom) && $sdom !~ /^\s*$/) { + $link .= "?selected_student=$sname:$sdom"; + $title .= ' of this student'; + } + if (defined($target) && $target !~ /^\s*$/) { + $target = qq{target="$target"}; + } else { + $target = ''; + } + return qq{$linktext}; +} + + + =pod =back @@ -1814,6 +2072,30 @@ sub copyrightdescription { =pod +=item * source_copyrightids() + +returns list of all source copyrights + +=cut + +sub source_copyrightids { + return sort(keys(%scprtag)); +} + +=pod + +=item * source_copyrightdescription() + +returns description of a specified source copyright id + +=cut + +sub source_copyrightdescription { + return &mt($scprtag{shift(@_)}); +} + +=pod + =item * filecategories() returns list of all file categories @@ -1909,8 +2191,8 @@ sub display_languages { $languages{$_}=1; } &get_unprocessed_cgi($ENV{'QUERY_STRING'},['displaylanguage']); - if ($ENV{'form.displaylanguage'}) { - foreach (split(/\s*(\,|\;|\:)\s*/,$ENV{'form.displaylanguage'})) { + if ($env{'form.displaylanguage'}) { + foreach (split(/\s*(\,|\;|\:)\s*/,$env{'form.displaylanguage'})) { $languages{$_}=1; } } @@ -1919,24 +2201,24 @@ sub display_languages { sub preferred_languages { my @languages=(); - if ($ENV{'course.'.$ENV{'request.course.id'}.'.languages'}) { + if ($env{'course.'.$env{'request.course.id'}.'.languages'}) { @languages=(@languages,split(/\s*(\,|\;|\:)\s*/, - $ENV{'course.'.$ENV{'request.course.id'}.'.languages'})); + $env{'course.'.$env{'request.course.id'}.'.languages'})); } - if ($ENV{'environment.languages'}) { - @languages=split(/\s*(\,|\;|\:)\s*/,$ENV{'environment.languages'}); + if ($env{'environment.languages'}) { + @languages=split(/\s*(\,|\;|\:)\s*/,$env{'environment.languages'}); } my $browser=(split(/\;/,$ENV{'HTTP_ACCEPT_LANGUAGE'}))[0]; if ($browser) { @languages=(@languages,split(/\s*(\,|\;|\:)\s*/,$browser)); } - if ($Apache::lonnet::domain_lang_def{$ENV{'user.domain'}}) { + if ($Apache::lonnet::domain_lang_def{$env{'user.domain'}}) { @languages=(@languages, - $Apache::lonnet::domain_lang_def{$ENV{'user.domain'}}); + $Apache::lonnet::domain_lang_def{$env{'user.domain'}}); } - if ($Apache::lonnet::domain_lang_def{$ENV{'request.role.domain'}}) { + if ($Apache::lonnet::domain_lang_def{$env{'request.role.domain'}}) { @languages=(@languages, - $Apache::lonnet::domain_lang_def{$ENV{'request.role.domain'}}); + $Apache::lonnet::domain_lang_def{$env{'request.role.domain'}}); } if ($Apache::lonnet::domain_lang_def{ $Apache::lonnet::perlvar{'lonDefDomain'}}) { @@ -2115,7 +2397,7 @@ sub get_student_view { if (defined($moreenv)) { %form=(%form,%{$moreenv}); } - if ($target eq 'tex') {$form{'grade_target'} = 'tex';} + if (defined($target)) { $form{'grade_target'} = $target; } $feedurl=&Apache::lonnet::clutter($feedurl); my $userview=&Apache::lonnet::ssi_body($feedurl,%form); $userview=~s/\]*\>//gi; @@ -2155,7 +2437,7 @@ sub get_student_answers { =item * &submlink() -Inputs: $text $uname $udom $symb +Inputs: $text $uname $udom $symb $target Returns: A link to grades.pm such as to see the SUBM view of a student @@ -2163,15 +2445,64 @@ Returns: A link to grades.pm such as to ############################################### sub submlink { - my ($text,$uname,$udom,$symb)=@_; + my ($text,$uname,$udom,$symb,$target)=@_; if (!($uname && $udom)) { (my $cursymb, my $courseid,$udom,$uname)= &Apache::lonxml::whichuser($symb); if (!$symb) { $symb=$cursymb; } } - if (!$symb) { $symb=&symbread(); } - return ''.$text.''; + if (!$symb) { $symb=&Apache::lonnet::symbread(); } + $symb=&Apache::lonnet::escape($symb); + if ($target) { $target="target=\"$target\""; } + return ''.$text.''; +} +############################################## + +=pod + +=item * &pgrdlink() + +Inputs: $text $uname $udom $symb $target + +Returns: A link to grades.pm such as to see the PGRD view of a student + +=cut + +############################################### +sub pgrdlink { + my $link=&submlink(@_); + $link=~s/(&command=submission)/$1&showgrading=yes/; + return $link; +} +############################################## + +=pod + +=item * &pprmlink() + +Inputs: $text $uname $udom $symb $target + +Returns: A link to parmset.pm such as to see the PPRM view of a +student andn resource + +=cut + +############################################### +sub pprmlink { + my ($text,$uname,$udom,$symb,$target)=@_; + if (!($uname && $udom)) { + (my $cursymb, my $courseid,$udom,$uname)= + &Apache::lonxml::whichuser($symb); + if (!$symb) { $symb=$cursymb; } + } + if (!$symb) { $symb=&Apache::lonnet::symbread(); } + $symb=&Apache::lonnet::escape($symb); + if ($target) { $target="target=\"$target\""; } + return ''.$text.''; } ############################################## @@ -2201,7 +2532,7 @@ sub maketime { my %th=@_; return POSIX::mktime( ($th{'seconds'},$th{'minutes'},$th{'hours'}, - $th{'day'},$th{'month'}-1,$th{'year'}-1900,0,0,$th{'dlsav'})); + $th{'day'},$th{'month'}-1,$th{'year'}-1900,0,0,-1)); } ######################################### @@ -2209,9 +2540,9 @@ sub maketime { sub findallcourses { my %courses=(); my $now=time; - foreach (keys %ENV) { + foreach (keys %env) { if ($_=~/^user\.role\.\w+\.\/(\w+)\/(\w+)/) { - my ($starttime,$endtime)=$ENV{$_}; + my ($starttime,$endtime)=$env{$_}; my $active=1; if ($starttime) { if ($now<$starttime) { $active=0; } @@ -2248,9 +2579,9 @@ sub determinedomain { if (! $domain) { # Determine domain if we have not been given one $domain = $Apache::lonnet::perlvar{'lonDefDomain'}; - if ($ENV{'user.domain'}) { $domain=$ENV{'user.domain'}; } - if ($ENV{'request.role.domain'}) { - $domain=$ENV{'request.role.domain'}; + if ($env{'user.domain'}) { $domain=$env{'user.domain'}; } + if ($env{'request.role.domain'}) { + $domain=$env{'request.role.domain'}; } } return $domain; @@ -2272,10 +2603,8 @@ sub domainlogo { my $domain = &determinedomain(shift); # See if there is a logo if (-e '/home/httpd/html/adm/lonDomLogos/'.$domain.'.gif') { - my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'}; - if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; } - return ''.$domain.''; + my $logo=&lonhttpdurl("/adm/lonDomLogos/$domain.gif"); + return ''.$domain.''; } elsif(exists($Apache::lonnet::domaindescription{$domain})) { return $Apache::lonnet::domaindescription{$domain}; } else { @@ -2297,7 +2626,7 @@ Returns: value of designparamter $which ############################################## sub designparm { my ($which,$domain)=@_; - if ($ENV{'browser.blackwhite'} eq 'on') { + if ($env{'browser.blackwhite'} eq 'on') { if ($which=~/\.(font|alink|vlink|link)$/) { return '#000000'; } @@ -2308,8 +2637,8 @@ sub designparm { return '#CCCCCC'; } } - if ($ENV{'environment.color.'.$which}) { - return $ENV{'environment.color.'.$which}; + if ($env{'environment.color.'.$which}) { + return $env{'environment.color.'.$which}; } $domain=&determinedomain($domain); if ($designhash{$domain.'.'.$which}) { @@ -2361,7 +2690,7 @@ other decorations will be returned. =cut sub bodytag { - my ($title,$function,$addentries,$bodyonly,$domain,$forcereg)=@_; + my ($title,$function,$addentries,$bodyonly,$domain,$forcereg,$customtitle)=@_; $title=&mt($title); $function = &get_users_function() if (!$function); my $img=&designparm($function.'.img',$domain); @@ -2375,16 +2704,16 @@ sub bodytag { # Accessibility font enhance unless ($addentries) { $addentries=''; } my $addstyle=''; - if ($ENV{'browser.fontenhance'} eq 'on') { + if ($env{'browser.fontenhance'} eq 'on') { $addstyle=' font-size: x-large;'; } # role and realm my ($role,$realm) - =&Apache::lonnet::plaintext((split(/\./,$ENV{'request.role'}))[0]); + =&Apache::lonnet::plaintext((split(/\./,$env{'request.role'}))[0]); # realm - if ($ENV{'request.course.id'}) { + if ($env{'request.course.id'}) { $realm= - $ENV{'course.'.$ENV{'request.course.id'}.'.description'}; + $env{'course.'.$env{'request.course.id'}.'.description'}; } unless ($realm) { $realm=' '; } # Set messages @@ -2394,33 +2723,109 @@ sub bodytag { if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; } # construct main body tag my $bodytag = < + END + if ($env{'environment.texengine'} eq 'jsMath') { + $bodytag.=''."\n". + ''."\n"; + } + my $upperleft=''.$function.''; if ($bodyonly) { return $bodytag; - } elsif ($ENV{'browser.interface'} eq 'textual') { + } elsif ($env{'browser.interface'} eq 'textual') { # Accessibility + return $bodytag.&Apache::lonmenu::menubuttons($forcereg,'web', $forcereg). '

LON-CAPA: '.$title.'

'; - } elsif ($ENV{'environment.remote'} eq 'off') { + } elsif ($env{'environment.remote'} eq 'off') { # No Remote - return $bodytag.&Apache::lonmenu::menubuttons($forcereg,'web', - $forcereg). - '
'.$title. -'
'; + my $roleinfo=(< + + $env{'environment.firstname'} + $env{'environment.middlename'} + $env{'environment.lastname'} + $env{'environment.generation'} +   +
+$role  +
+$realm  + +ENDROLE + my $titleinfo = ''.$title.''; + if ($customtitle) { + $titleinfo = $customtitle; + } + + if ($env{'request.state'} eq 'construct') { + my ($uname,$thisdisfn)= + ($env{'request.filename'} =~ m|^/home/([^/]+)/public_html/(.*)|); + my $formaction='/priv/'.$uname.'/'.$thisdisfn; + $formaction=~s/\/+/\//g; + unless ($customtitle) { #this is for resources; directories have customtitle, and crumbs and select recent are created in lonpubdir.pm + my $parentpath = ''; + my $lastitem = ''; + if ($thisdisfn =~ m-(.+/)([^/]*)$-) { + $parentpath = $1; + $lastitem = $2; + } else { + $lastitem = $thisdisfn; + } + $titleinfo = &Apache::loncommon::help_open_menu('','','','',3,'Authoring'). + 'Construction Space: '. + '
' + .&Apache::lonhtmlcommon::crumbs($uname.'/'.$parentpath,'_top','/priv','','+1',1)."$lastitem
" + .&Apache::lonhtmlcommon::select_recent('construct','recent','this.form.action=this.form.recent.value;this.form.submit()') + .'
' + .&Apache::lonmenu::constspaceform(); + + } + $forcereg=1; + } + my $titletable = ''. + ''.$roleinfo.'
'. + $titleinfo.'
'; + if ($env{'request.state'} eq 'construct') { + $bodytag .= &Apache::lonmenu::menubuttons($forcereg,'web',$forcereg,$titletable); + } else { + $bodytag .= &Apache::lonmenu::menubuttons($forcereg,'web',$forcereg). + $titletable; + } + return $bodytag; } # # Top frame rendering, Remote is up # + my $titleinfo = ' '.$title.''; + if ($customtitle) { + $titleinfo = $customtitle; + } + # + # Extra info if you are the DC + my $dc_info = ''; + if ($env{'user.adv'} && exists($env{'user.role.dc./'. + $env{'course.'.$env{'request.course.id'}. + '.domain'}.'/'})) { + my $cid = $env{'request.course.id'}; + $dc_info.= $cid.' '.$env{'course.'.$cid.'.internal.coursecode'}; + $dc_info = '('.$dc_info.')'; + } + # return(< @@ -2430,13 +2835,13 @@ $upperleft - $title - +$titleinfo $dc_info + - $ENV{'environment.firstname'} - $ENV{'environment.middlename'} - $ENV{'environment.lastname'} - $ENV{'environment.generation'} + $env{'environment.firstname'} + $env{'environment.middlename'} + $env{'environment.lastname'} + $env{'environment.generation'}   @@ -2445,11 +2850,45 @@ $upperleft $realm  -
+
ENDBODY } ############################################### +############################################### + +=pod + +=back + +=head1 HTTP Helpers + +=over 4 + +=item * &endbodytag() + +Returns a uniform footer for LON-CAPA web pages. + +Inputs: + +=over 4 + +=back + +Returns: A uniform footer for LON-CAPA web pages. + +=cut + +sub endbodytag { + my $endbodytag=''; + if ($env{'environment.texengine'} eq 'jsMath') { + $endbodytag=''. + "\n".$endbodytag; + } + return $endbodytag; +} + +############################################### =pod @@ -2463,13 +2902,13 @@ Returns either 'student','coordinator',' ############################################### sub get_users_function { my $function = 'student'; - if ($ENV{'request.role'}=~/^(cc|in|ta|ep)/) { + if ($env{'request.role'}=~/^(cc|in|ta|ep)/) { $function='coordinator'; } - if ($ENV{'request.role'}=~/^(su|dc|ad|li)/) { + if ($env{'request.role'}=~/^(su|dc|ad|li)/) { $function='admin'; } - if (($ENV{'request.role'}=~/^(au|ca)/) || + if (($env{'request.role'}=~/^(au|ca)/) || ($ENV{'REQUEST_URI'}=~/^(\/priv|\~)/)) { $function='author'; } @@ -2478,12 +2917,68 @@ sub get_users_function { ############################################### +=pod + +=item get_sections + +Determines all the sections for a course including +sections with students and sections containing other roles. +Incoming parameters: domain, course number, reference to +section hash (keys to be section/group IDs), reference to +array containing roles for which sections should be gathered +(optional). If the fourth argument is undefined, sections +are gathered for any role. + +Returns number of sections. + +=cut + +############################################### +sub get_sections { + my ($cdom,$cnum,$sectioncount,$possible_roles) = @_; + if (!($cdom && $cnum)) { return 0; } + my $cid = $cdom.'_'.$cnum; + my $numsections = 0; + + if (!defined($possible_roles) || (grep/^st$/,@$possible_roles)) { + my ($classlist) = &Apache::loncoursedata::get_classlist($cid,$cdom,$cnum); + my $sec_index = &Apache::loncoursedata::CL_SECTION(); + my $status_index = &Apache::loncoursedata::CL_STATUS(); + while (my ($student,$data) = each %$classlist) { + my ($section,$status) = ($data->[$sec_index], + $data->[$status_index]); + unless ($section eq '-1' || $section =~ /^\s*$/) { + if (!defined($$sectioncount{$section})) { $numsections++; } + $$sectioncount{$section}++; + } + } + } + my %courseroles = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum); + foreach my $user (sort(keys(%courseroles))) { + if ($user !~ /^(\w{2})/) { next; } + my ($role) = ($user =~ /^(\w{2})/); + if ($possible_roles && !(grep(/^$role$/,@$possible_roles))) { next; } + my $section; + if ($role eq 'cr' && + $user =~ m-^$role/[^/]*/[^/]*/[^/]*:[^:]*:[^:]*:(\w+)-) { + $section=$1; + } + if ($user =~ /^$role:[^:]*:[^:]*:(\w+)/) { $section=$1; } + if (!defined($section) || $section eq '-1') { next; } + if (!defined($$sectioncount{$section})) { $numsections++; } + $$sectioncount{$section}++; + } + return $numsections; +} + + sub get_posted_cgi { my $r=shift; my $buffer; - - $r->read($buffer,$r->header_in('Content-length'),0); + if ($r->header_in('Content-length')) { + $r->read($buffer,$r->header_in('Content-length'),0); + } unless ($buffer=~/^(\-+\w+)\s+Content\-Disposition\:\s*form\-data/si) { my @pairs=split(/&/,$buffer); my $pair; @@ -2508,8 +3003,8 @@ sub get_posted_cgi { if ($name) { chomp($value); if ($fname) { - $ENV{"form.$name.filename"}=$fname; - $ENV{"form.$name.mimetype"}=$fmime; + $env{"form.$name.filename"}=$fname; + $env{"form.$name.mimetype"}=$fmime; } else { $value=~s/\s+$//s; } @@ -2541,7 +3036,7 @@ sub get_posted_cgi { } } } - $ENV{'request.method'}=$ENV{'REQUEST_METHOD'}; + $env{'request.method'}=$ENV{'REQUEST_METHOD'}; $r->method_number(M_GET); $r->method('GET'); $r->headers_in->unset('Content-length'); @@ -2551,14 +3046,14 @@ sub get_posted_cgi { =item * get_unprocessed_cgi($query,$possible_names) -Modify the %ENV hash to contain unprocessed CGI form parameters held in +Modify the %env hash to contain unprocessed CGI form parameters held in $query. The parameters listed in $possible_names (an array reference), -will be set in $ENV{'form.name'} if they do not already exist. +will be set in $env{'form.name'} if they do not already exist. Typically called with $ENV{'QUERY_STRING'} as the first parameter. $possible_names is an ref to an array of form element names. As an example: get_unprocessed_cgi($ENV{'QUERY_STRING'},['uname','udom']); -will result in $ENV{'form.uname'} and $ENV{'form.udom'} being set. +will result in $env{'form.uname'} and $env{'form.udom'} being set. =cut @@ -2572,7 +3067,7 @@ sub get_unprocessed_cgi { $value =~ tr/+/ /; $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; &Apache::lonxml::debug("Seting :$name: to :$value:"); - unless (defined($ENV{'form.'.$name})) { &add_to_env('form.'.$name,$value) }; + unless (defined($env{'form.'.$name})) { &add_to_env('form.'.$name,$value) }; } } } @@ -2586,12 +3081,12 @@ returns cache-controlling header code =cut sub cacheheader { - unless ($ENV{'request.method'} eq 'GET') { return ''; } - my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime); - my $output .=' + unless ($env{'request.method'} eq 'GET') { return ''; } + my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime); + my $output .=' '; - return $output; + return $output; } =pod @@ -2603,16 +3098,18 @@ specifies header code to not have cache =cut sub no_cache { - my ($r) = @_; - unless ($ENV{'request.method'} eq 'GET') { return ''; } - #my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime); - $r->no_cache(1); - $r->header_out("Pragma" => "no-cache"); - #$r->header_out("Expires" => $date); + my ($r) = @_; + if ($ENV{'REQUEST_METHOD'} ne 'GET' && + $env{'request.method'} ne 'GET') { return ''; } + my $date=strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime(time)); + $r->no_cache(1); + $r->header_out("Expires" => $date); + $r->header_out("Pragma" => "no-cache"); } sub content_type { my ($r,$type,$charset) = @_; + if ($env{'browser.mathml'} && $type eq 'text/html') { $type='text/xml'; } unless ($charset) { $charset=&Apache::lonlocal::current_encoding; } @@ -2628,7 +3125,7 @@ sub content_type { =item * add_to_env($name,$value) -adds $name to the %ENV hash with value +adds $name to the %env hash with value $value, if $name already exists, the entry is converted to an array reference and $value is added to the array. @@ -2636,18 +3133,18 @@ reference and $value is added to the arr sub add_to_env { my ($name,$value)=@_; - if (defined($ENV{$name})) { - if (ref($ENV{$name})) { + if (defined($env{$name})) { + if (ref($env{$name})) { #already have multiple values - push(@{ $ENV{$name} },$value); + push(@{ $env{$name} },$value); } else { #first time seeing multiple values, convert hash entry to an arrayref - my $first=$ENV{$name}; - undef($ENV{$name}); - push(@{ $ENV{$name} },$first,$value); + my $first=$env{$name}; + undef($env{$name}); + push(@{ $env{$name} },$first,$value); } } else { - $ENV{$name}=$value; + $env{$name}=$value; } } @@ -2655,7 +3152,7 @@ sub add_to_env { =item * get_env_multiple($name) -gets $name from the %ENV hash, it seemlessly handles the cases where multiple +gets $name from the %env hash, it seemlessly handles the cases where multiple values may be defined and end up as an array ref. returns an array of values @@ -2665,12 +3162,12 @@ returns an array of values sub get_env_multiple { my ($name) = @_; my @values; - if (defined($ENV{$name})) { + if (defined($env{$name})) { # exists is it an array - if (ref($ENV{$name})) { - @values=@{ $ENV{$name} }; + if (ref($env{$name})) { + @values=@{ $env{$name} }; } else { - $values[0]=$ENV{$name}; + $values[0]=$env{$name}; } } return(@values); @@ -2688,25 +3185,25 @@ sub get_env_multiple { =item * upfile_store($r) Store uploaded file, $r should be the HTTP Request object, -needs $ENV{'form.upfile'} +needs $env{'form.upfile'} returns $datatoken to be put into hidden field =cut sub upfile_store { my $r=shift; - $ENV{'form.upfile'}=~s/\r/\n/gs; - $ENV{'form.upfile'}=~s/\f/\n/gs; - $ENV{'form.upfile'}=~s/\n+/\n/gs; - $ENV{'form.upfile'}=~s/\n+$//gs; + $env{'form.upfile'}=~s/\r/\n/gs; + $env{'form.upfile'}=~s/\f/\n/gs; + $env{'form.upfile'}=~s/\n+/\n/gs; + $env{'form.upfile'}=~s/\n+$//gs; - my $datatoken=$ENV{'user.name'}.'_'.$ENV{'user.domain'}. - '_enroll_'.$ENV{'request.course.id'}.'_'.time.'_'.$$; + my $datatoken=$env{'user.name'}.'_'.$env{'user.domain'}. + '_enroll_'.$env{'request.course.id'}.'_'.time.'_'.$$; { my $datafile = $r->dir_config('lonDaemons'). '/tmp/'.$datatoken.'.tmp'; if ( open(my $fh,">$datafile") ) { - print $fh $ENV{'form.upfile'}; + print $fh $env{'form.upfile'}; close($fh); } } @@ -2718,8 +3215,8 @@ sub upfile_store { =item * load_tmp_file($r) Load uploaded file from tmp, $r should be the HTTP Request object, -needs $ENV{'form.datatoken'}, -sets $ENV{'form.upfile'} to the contents of the file +needs $env{'form.datatoken'}, +sets $env{'form.upfile'} to the contents of the file =cut @@ -2728,13 +3225,13 @@ sub load_tmp_file { my @studentdata=(); { my $studentfile = $r->dir_config('lonDaemons'). - '/tmp/'.$ENV{'form.datatoken'}.'.tmp'; + '/tmp/'.$env{'form.datatoken'}.'.tmp'; if ( open(my $fh,"<$studentfile") ) { @studentdata=<$fh>; close($fh); } } - $ENV{'form.upfile'}=join('',@studentdata); + $env{'form.upfile'}=join('',@studentdata); } =pod @@ -2743,14 +3240,19 @@ sub load_tmp_file { Separate uploaded file into records returns array of records, -needs $ENV{'form.upfile'} and $ENV{'form.upfiletype'} +needs $env{'form.upfile'} and $env{'form.upfiletype'} =cut sub upfile_record_sep { - if ($ENV{'form.upfiletype'} eq 'xml') { + if ($env{'form.upfiletype'} eq 'xml') { } else { - return split(/\n/,$ENV{'form.upfile'}); + my @records; + foreach my $line (split(/\n/,$env{'form.upfile'})) { + if ($line=~/^\s*$/) { next; } + push(@records,$line); + } + return @records; } } @@ -2758,15 +3260,15 @@ sub upfile_record_sep { =item * record_sep($record) -Separate a record into fields $record should be an item from the upfile_record_sep(), needs $ENV{'form.upfiletype'} +Separate a record into fields $record should be an item from the upfile_record_sep(), needs $env{'form.upfiletype'} =cut sub record_sep { my $record=shift; my %components=(); - if ($ENV{'form.upfiletype'} eq 'xml') { - } elsif ($ENV{'form.upfiletype'} eq 'space') { + if ($env{'form.upfiletype'} eq 'xml') { + } elsif ($env{'form.upfiletype'} eq 'space') { my $i=0; foreach (split(/\s+/,$record)) { my $field=$_; @@ -2775,7 +3277,7 @@ sub record_sep { $components{$i}=$field; $i++; } - } elsif ($ENV{'form.upfiletype'} eq 'tab') { + } elsif ($env{'form.upfiletype'} eq 'tab') { my $i=0; foreach (split(/\t/,$record)) { my $field=$_; @@ -2908,7 +3410,7 @@ sub csv_print_select_table { $r->print(''); foreach (sort({$a <=> $b} keys(%sone))) { $r->print(''); } $r->print(''."\n"); @@ -2952,7 +3454,7 @@ sub csv_samples_select_table { foreach (@$d) { my ($value,$display,$defaultcol)=@{ $_ }; $r->print(''); } $r->print(''); @@ -3083,6 +3585,9 @@ they are plotted. If undefined, default =item @Values: An array of array references. Each array reference holds data to be plotted in a stacked bar chart. +=item If the final element of @Values is a hash reference the key/value +pairs will be added to the graph definition. + =back Returns: @@ -3103,13 +3608,28 @@ sub DrawBarGraph { '#66ccff', '#ff9999', '#cccc33', '#660000', '#33cc66', ]; } + my $extra_settings = {}; + if (ref($Values[-1]) eq 'HASH') { + $extra_settings = pop(@Values); + } # my $identifier = &get_cgi_id(); my $id = 'cgi.'.$identifier; if (! @Values || ref($Values[0]) ne 'ARRAY') { return ''; } + # + my @Labels; + if (defined($labels)) { + @Labels = @$labels; + } else { + for (my $i=0;$i<@{$Values[0]};$i++) { + push (@Labels,$i+1); + } + } + # my $NumBars = scalar(@{$Values[0]}); + if ($NumBars < scalar(@Labels)) { $NumBars = scalar(@Labels); } my %ValuesHash; my $NumSets=1; foreach my $array (@Values) { @@ -3119,7 +3639,15 @@ sub DrawBarGraph { } # my ($height,$width,$xskip,$bar_width) = (200,120,1,15); - if ($NumBars < 10) { + if ($NumBars < 3) { + $width = 120+$NumBars*32; + $xskip = 1; + $bar_width = 30; + } elsif ($NumBars < 5) { + $width = 120+$NumBars*20; + $xskip = 1; + $bar_width = 20; + } elsif ($NumBars < 10) { $width = 120+$NumBars*15; $xskip = 1; $bar_width = 15; @@ -3137,15 +3665,6 @@ sub DrawBarGraph { $bar_width = 4; } # - my @Labels; - if (defined($labels)) { - @Labels = @$labels; - } else { - for (my $i=0;$i<@{$Values[0]};$i++) { - push (@Labels,$i+1); - } - } - # $Max = 1 if ($Max < 1); if ( int($Max) < $Max ) { $Max++; @@ -3168,6 +3687,11 @@ sub DrawBarGraph { $ValuesHash{$id.'.bar_width'} = $bar_width; $ValuesHash{$id.'.labels'} = join(',',@Labels); # + # Deal with other parameters + while (my ($key,$value) = each(%$extra_settings)) { + $ValuesHash{$id.'.'.$key} = $value; + } + # &Apache::lonnet::appenv(%ValuesHash); return ''; } @@ -3402,8 +3926,8 @@ Inputs: sub chartlink { my ($linktext, $sname, $sdomain) = @_; my $link = ''.$linktext.''; } @@ -3444,34 +3968,34 @@ Returns: both routines return nothing sub store_course_settings { # save to the environment # appenv the same items, just to be safe - my $courseid = $ENV{'request.course.id'}; - my $coursedom = $ENV{'course.'.$courseid.'.domain'}; + my $courseid = $env{'request.course.id'}; + my $coursedom = $env{'course.'.$courseid.'.domain'}; my ($prefix,$Settings) = @_; my %SaveHash; my %AppHash; while (my ($setting,$type) = each(%$Settings)) { my $basename = 'internal.'.$prefix.'.'.$setting; my $envname = 'course.'.$courseid.'.'.$basename; - if (exists($ENV{'form.'.$setting})) { + if (exists($env{'form.'.$setting})) { # Save this value away if ($type eq 'scalar' && - (! exists($ENV{$envname}) || - $ENV{$envname} ne $ENV{'form.'.$setting})) { - $SaveHash{$basename} = $ENV{'form.'.$setting}; - $AppHash{$envname} = $ENV{'form.'.$setting}; + (! exists($env{$envname}) || + $env{$envname} ne $env{'form.'.$setting})) { + $SaveHash{$basename} = $env{'form.'.$setting}; + $AppHash{$envname} = $env{'form.'.$setting}; } elsif ($type eq 'array') { my $stored_form; - if (ref($ENV{'form.'.$setting})) { + if (ref($env{'form.'.$setting})) { $stored_form = join(',', map { &Apache::lonnet::escape($_); - } sort(@{$ENV{'form.'.$setting}})); + } sort(@{$env{'form.'.$setting}})); } else { $stored_form = - &Apache::lonnet::escape($ENV{'form.'.$setting}); + &Apache::lonnet::escape($env{'form.'.$setting}); } # Determine if the array contents are the same. - if ($stored_form ne $ENV{$envname}) { + if ($stored_form ne $env{$envname}) { $SaveHash{$basename} = $stored_form; $AppHash{$envname} = $stored_form; } @@ -3480,7 +4004,7 @@ sub store_course_settings { } my $put_result = &Apache::lonnet::put('environment',\%SaveHash, $coursedom, - $ENV{'course.'.$courseid.'.num'}); + $env{'course.'.$courseid.'.num'}); if ($put_result !~ /^(ok|delayed)/) { &Apache::lonnet::logthis('unable to save form parameters, '. 'got error:'.$put_result); @@ -3491,20 +4015,20 @@ sub store_course_settings { } sub restore_course_settings { - my $courseid = $ENV{'request.course.id'}; + my $courseid = $env{'request.course.id'}; my ($prefix,$Settings) = @_; while (my ($setting,$type) = each(%$Settings)) { - next if (exists($ENV{'form.'.$setting})); + next if (exists($env{'form.'.$setting})); my $envname = 'course.'.$courseid.'.internal.'.$prefix. '.'.$setting; - if (exists($ENV{$envname})) { + if (exists($env{$envname})) { if ($type eq 'scalar') { - $ENV{'form.'.$setting} = $ENV{$envname}; + $env{'form.'.$setting} = $env{$envname}; } elsif ($type eq 'array') { - $ENV{'form.'.$setting} = [ + $env{'form.'.$setting} = [ map { &Apache::lonnet::unescape($_); - } split(',',$ENV{$envname}) + } split(',',$env{$envname}) ]; } } @@ -3537,9 +4061,48 @@ sub icon { $curfext.".gif"; } } - return $iconname; + return &lonhttpdurl($iconname); } +sub lonhttpdurl { + my ($url)=@_; + my $lonhttpd_port=$Apache::lonnet::perlvar{'lonhttpdPort'}; + if (!defined($lonhttpd_port)) { $lonhttpd_port='8080'; } + return 'http://'.$ENV{'SERVER_NAME'}.':'.$lonhttpd_port.$url; +} + +sub connection_aborted { + my ($r)=@_; + $r->print(" ");$r->rflush(); + my $c = $r->connection; + return $c->aborted(); +} + +# Escapes strings that may have embedded 's that will be put into +# strings as 'strings'. +sub escape_single { + my ($input) = @_; + $input =~ s/\\/\\\\/g; # Escape the \'s..(must be first)> + $input =~ s/\'/\\\'/g; # Esacpe the 's.... + return $input; +} + +# Same as escape_single, but escape's "'s This +# can be used for "strings" +sub escape_double { + my ($input) = @_; + $input =~ s/\\/\\\\/g; # Escape the /'s..(must be first)> + $input =~ s/\"/\\\"/g; # Esacpe the "s.... + return $input; +} + +# Escapes the last element of a full URL. +sub escape_url { + my ($url) = @_; + my @urlslices = split(/\//, $url,-1); + my $lastitem = &Apache::lonnet::escape(pop(@urlslices)); + return join('/',@urlslices).'/'.$lastitem; +} =pod =back