--- loncom/interface/loncommon.pm 2004/07/12 17:02:07 1.198 +++ loncom/interface/loncommon.pm 2005/11/15 22:03:05 1.294 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # a pile of common routines # -# $Id: loncommon.pm,v 1.198 2004/07/12 17:02:07 raeburn Exp $ +# $Id: loncommon.pm,v 1.294 2005/11/15 22:03:05 raeburn 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; @@ -153,19 +152,20 @@ BEGIN { my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors'; opendir(DIR,$designdir); while ($filename=readdir(DIR)) { + if ($filename!~/\.tab$/) { next; } my ($domain)=($filename=~/^(\w+)\./); - { - my $designfile = $designdir.'/'.$filename; - if ( open (my $fh,"<$designfile") ) { - while (<$fh>) { - next if /^\#/; - chomp; - my ($key,$val)=(split(/\=/,$_)); - if ($val) { $designhash{$domain.'.'.$key}=$val; } - } - close($fh); - } - } + { + my $designfile = $designdir.'/'.$filename; + if ( open (my $fh,"<$designfile") ) { + while (<$fh>) { + next if /^\#/; + chomp; + my ($key,$val)=(split(/\=/,$_)); + if ($val) { $designhash{$domain.'.'.$key}=$val; } + } + close($fh); + } + } } closedir(DIR); @@ -250,8 +250,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'; } @@ -318,9 +330,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) + (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); @@ -728,8 +805,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; @@ -738,12 +816,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); @@ -772,8 +850,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; @@ -785,6 +864,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' @@ -797,11 +968,10 @@ format. sub csv_translate { my $text = shift; $text =~ s/\"/\"\"/g; - $text =~ s/\n//g; + $text =~ s/\n/ /g; return $text; } - ############################################################### ############################################################### @@ -825,6 +995,10 @@ Currently supported formats: =item h3 +=item h4 + +=item i + =item date =back @@ -847,8 +1021,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; } @@ -857,84 +1033,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 @@ -977,27 +1152,49 @@ sub domain_select { } &get_domains; if ($multiple) { $domains{''}=&mt('Any domain'); - return &multiple_select_form($name,$value,4,%domains); + return &multiple_select_form($name,$value,4,\%domains); } else { return &select_form($name,$value,%domains); } } +#------------------------------------------- + +=pod + +=item * multiple_select_form($name,$value,$size,$hash,$order) + +Returns a string containing a element + $value - sclara or array ref of values that should already be selected + $size - number of rows long the select element is + $hash - the elements should be 'option' => 'shown text' + (shown text should already have been &mt()) + $order - (optional) array ref of the order to show the elments in + +=cut + +#------------------------------------------- sub multiple_select_form { - my ($name,$value,$size,%hash)=@_; + my ($name,$value,$size,$hash,$order)=@_; my %selected = map { $_ => 1 } ref($value)?@{$value}:($value); my $output=''; if (! defined($size)) { $size = 4; - if (scalar(keys(%hash))<4) { - $size = scalar(keys(%hash)); + if (scalar(keys(%$hash))<4) { + $size = scalar(keys(%$hash)); } } $output.="\n\n"; return $output; @@ -1027,7 +1224,7 @@ sub select_form { } foreach (@keys) { $selectform.="\n"; } $selectform.=""; @@ -1064,7 +1261,7 @@ sub select_level_form { my $selectform = ""; @@ -1094,7 +1291,7 @@ sub select_dom_form { my $selectdomain = ""; @@ -1193,9 +1390,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=''; @@ -1391,10 +1590,11 @@ sub authform_nochange{ kerb_def_dom => 'MSU.EDU', @_, ); - my $result = &mt('[_1] Do not change login data', + my $result = ''; return $result; } @@ -1426,14 +1626,15 @@ sub authform_kerberos{ my $jscall = "javascript:changed_radio('krb',$in{'formname'});"; my $result .= &mt ('[_1] Kerberos authenticated with domain [_2] '. - '[_3] Version 4 [_4] Version 5', - '', - '', - '', - ''); + ''); return $result; } @@ -1458,9 +1659,9 @@ sub authform_internal{ my $jscall = "javascript:changed_radio('int',$args{'formname'});"; my $result.=&mt ('[_1] Internally authenticated (with initial password [_2])', - '', - ''); return $result; } @@ -1485,9 +1686,9 @@ sub authform_local{ my $jscall = "javascript:changed_radio('loc',$in{'formname'});"; my $result.=&mt('[_1] Local Authentication with argument [_2]', - '', - ''); return $result; } @@ -1501,9 +1702,9 @@ sub authform_filesystem{ my $jscall = "javascript:changed_radio('fsys',$in{'formname'});"; my $result.= &mt ('[_1] Filesystem Authenticated (with initial password [_2])', - '', - ''); return $result; } @@ -1710,21 +1911,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; } @@ -1750,8 +1956,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.'"'; @@ -1777,17 +1994,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 @@ -1800,8 +2021,8 @@ sub noteswrapper { sub aboutmewrapper { my ($link,$username,$domain,$target)=@_; - return "$link"; + return ''.$link.''; } # ------------------------------------------------------------ Syllabus Wrapper @@ -1812,7 +2033,25 @@ sub syllabuswrapper { if ($fontcolor) { $linktext=''.$linktext.''; } - return "$linktext"; + return qq{$linktext}; +} + +sub track_student_link { + my ($linktext,$sname,$sdom,$target,$start) = @_; + 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 = ''; + } + if ($start) { $link.='&start='.$start; } + return qq{$linktext}; } =pod @@ -2003,8 +2242,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; } } @@ -2013,24 +2252,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'}}) { @@ -2209,7 +2448,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; @@ -2249,7 +2488,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 @@ -2257,15 +2496,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 and a specific 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.''; } ############################################## @@ -2295,7 +2583,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)); } ######################################### @@ -2303,9 +2591,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; } @@ -2342,9 +2630,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; @@ -2366,10 +2654,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 { @@ -2391,7 +2677,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'; } @@ -2402,8 +2688,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}) { @@ -2455,7 +2741,7 @@ other decorations will be returned. =cut sub bodytag { - my ($title,$function,$addentries,$bodyonly,$domain,$forcereg)=@_; + my ($title,$function,$addentries,$bodyonly,$domain,$forcereg,$customtitle,$notopbar)=@_; $title=&mt($title); $function = &get_users_function() if (!$function); my $img=&designparm($function.'.img',$domain); @@ -2469,16 +2755,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 @@ -2488,49 +2774,135 @@ sub bodytag { if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; } # construct main body tag my $bodytag = < + END + &Apache::lontexconvert::jsMath_reset(); + if ($env{'environment.texengine'} eq 'jsMath') { + $bodytag.=&Apache::lontexconvert::jsMath_header(); + } + 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') { + if ($notopbar) { + $bodytag .= $titletable; + } else { + $bodytag .= &Apache::lonmenu::menubuttons($forcereg,'web',$forcereg,$titletable); + } + } else { + if ($notopbar) { + $bodytag .= $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(< + @@ -2539,11 +2911,42 @@ $upperleft -
$upperleft $messages 
- $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'}  
$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=''; + $endbodytag=&Apache::lontexconvert::jsMath_process()."\n".$endbodytag; + return $endbodytag; +} + +############################################### =pod @@ -2557,13 +2960,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'; } @@ -2572,12 +2975,332 @@ sub get_users_function { ############################################### +=pod + +=item check_user_status + +Determines current status of supplied role for a +specific user. Roles can be active, previous or future. + +Inputs: +user's domain, user's username, course's domain, +course's number, optional section/group. + +Outputs: +role status: active, previous or future. + +=cut + +sub check_user_status { + my ($udom,$uname,$cdom,$crs,$role,$secgrp) = @_; + my %userinfo = &Apache::lonnet::dump('roles',$udom,$uname); + my @uroles = keys %userinfo; + my $srchstr; + my $active_chk = 'none'; + if (@uroles > 0) { + if (($role eq 'cc') || ($secgrp eq '') || (!defined($secgrp))) { + $srchstr = '/'.$cdom.'/'.$crs.'_'.$role; + } else { + $srchstr = '/'.$cdom.'/'.$crs.'/'.$secgrp.'_'.$role; } + if (grep/^$srchstr$/,@uroles) { + my $role_end = 0; + my $role_start = 0; + $active_chk = 'active'; + if ($userinfo{$srchstr} =~ m/^($role)_(\d+)/) { + $role_end = $2; + if ($userinfo{$srchstr} =~ m/^($role)_($role_end)_(\d+)$/) { + $role_start = $3; + } + } + if ($role_start > 0) { + if (time < $role_start) { + $active_chk = 'future'; + } + } + if ($role_end > 0) { + if (time > $role_end) { + $active_chk = 'previous'; + } + } + } + } + return $active_chk; +} + +############################################### + +=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 $numsections = 0; + + if (!defined($possible_roles) || (grep/^st$/,@$possible_roles)) { + my ($classlist) = &Apache::loncoursedata::get_classlist($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; +} + +############################################### + +=pod + +=item get_group_settings + +Uses TokeParser to extract group information from the +XML used to describe course groups. + +Input: +Scalar containing XML (as retrieved from &lonnet::get_coursegroups). + +Output: +Hash containing group information as key=values for (a), and +hash of hashes for (b) + +Keys (in two categories): +(a) groupname, creator, creation, modified, startdate,enddate. +Corresponding values are name of the group, creator of the group +(username:domain), UNIX time for date group was created, and +settings were last modified, and default start and end access +times for group members. + +(b) functions returned in hash of hashes. +Outer hash key is functions. +Inner hash keys are chat,discussion,email,files,homepage,roster. +Corresponding values are either on or off, depending on +whther this type of functionality is available for the group. + +=cut + +############################################### + +sub get_group_settings { + my ($groupinfo)=@_; + my $parser=HTML::TokeParser->new(\$groupinfo); + my $token; + my $tool = ''; + my %content=(); + while ($token=$parser->get_token) { + if ($token->[0] eq 'S') { + my $entry=$token->[1]; + if ($entry eq 'functions') { + %{$content{$entry}} = (); + $tool = $entry; + } else { + my $value=$parser->get_text('/'.$entry); + if ($entry eq 'name') { + if ($tool eq 'functions') { + my $function = $token->[2]{id}; + $content{$tool}{$function} = $value; + } + } elsif ($entry eq 'groupname') { + $content{$entry}=&Apache::lonnet::unescape($value); + } else { + $content{$entry}=$value; + } + } + } elsif ($token->[0] eq 'E') { + if ($token->[1] eq 'functions') { + $tool = ''; + } + } + } + return %content; +} + +sub check_group_access { + my ($group) = @_; + my $access = 1; + my $now = time; + my ($start,$end) = split(/\./,$env{'user.role.gr/'.$env{'request.course,id'}.'/'.$group}); + if (($end!=0) && ($end<$now)) { $access = 0; } + if (($start!=0) && ($start>$now)) { $access=0; } + return $access; +} + +############################################### + +=pod + +=item get_course_users + +Retrieves usernames:domains for users in the specified course +with specific role(s), and access status. + +Incoming parameters: +1. course domain +2. course number +3. access status: users must have - either active, +previous, future, or all. +4. reference to array of permissible roles +5. reference to array of section restrictions (optional) +6. reference to results object (hash of hashes). +7. reference to optional userdata hash +Keys of top level hash are roles. +Keys of inner hashes are username:domain, with +values set to access type. +Optional userdata hash returns an array with arguments in the +same order as loncoursedata::get_classlist() for student data. + +Entries for end, start, section and status are blank because +of the possibility of multiple values for non-student roles. + +=cut + +############################################### + +sub get_course_users { + my ($cdom,$cnum,$types,$roles,$sections,$users,$userdata) = @_; + my %idx = (); + + $idx{udom} = &Apache::loncoursedata::CL_SDOM(); + $idx{uname} = &Apache::loncoursedata::CL_SNAME(); + $idx{end} = &Apache::loncoursedata::CL_END(); + $idx{start} = &Apache::loncoursedata::CL_START(); + $idx{id} = &Apache::loncoursedata::CL_ID(); + $idx{section} = &Apache::loncoursedata::CL_SECTION(); + $idx{fullname} = &Apache::loncoursedata::CL_FULLNAME(); + $idx{status} = &Apache::loncoursedata::CL_STATUS(); + + if (grep(/^st$/,@{$roles})) { + my ($classlist,$keylist)=&Apache::loncoursedata::get_classlist($cdom,$cnum); + my $now = time; + foreach my $student (keys(%{$classlist})) { + my $match = 0; + if ((ref($sections) eq 'ARRAY') && (@{$sections} > 0)) { + unless(grep(/^\Q$$classlist{$student}[$idx{section}]\E$/, + @{$sections})) { + next; + } + } + if (defined($$types{'active'})) { + if ($$classlist{$student}[$idx{status}] eq 'Active') { + push(@{$$users{st}{$student}},'active'); + $match = 1; + } + } + if (defined($$types{'previous'})) { + if ($$classlist{$student}[$idx{end}] <= $now) { + push(@{$$users{st}{$student}},'previous'); + $match = 1; + } + } + if (defined($$types{'future'})) { + if (($$classlist{$student}[$idx{start}] > $now) && ($$classlist{$student}[$idx{end}] > $now) || ($$classlist{$student}[$idx{end}] == 0) || ($$classlist{$student}[$idx{end}] eq '')) { + push(@{$$users{st}{$student}},'future'); + $match = 1; + } + } + if ($match && defined($userdata)) { + $$userdata{$student} = $$classlist{$student}; + } + } + } + if ((@{$roles} > 0) && (@{$roles} ne "st")) { + my @coursepersonnel = &Apache::lonnet::getkeys('nohist_userroles',$cdom,$cnum); + foreach my $person (@coursepersonnel) { + my $match = 0; + my ($role,$user) = ($person =~ /^([^:]*):([^:]+:[^:]+)/); + $user =~ s/:$//; + if (($role) && (grep(/^\Q$role\E$/,@{$roles}))) { + my ($uname,$udom,$usec) = split(/:/,$user); + if ($usec ne '' && (ref($sections) eq 'ARRAY') && + @{$sections} > 0) { + unless(grep(/^\Q$usec\E$/,@{$sections})) { + next; + } + } + if ($uname ne '' && $udom ne '') { + my $status = &check_user_status($udom,$uname,$cdom,$cnum,$role); + foreach my $type (keys(%{$types})) { + if ($status eq $type) { + @{$$users{$role}{$user}} = $type; + $match = 1; + } + } + if ($match && defined($userdata) && + !exists($$userdata{$uname.':'.$udom})) { + &get_user_info($udom,$uname,\%idx,$userdata); + } + } + } + } + if (grep(/^ow$/,@{$roles})) { + if ((defined($cdom)) && (defined($cnum))) { + my %csettings = &Apache::lonnet::get('environment',['internal.courseowner'],$cdom,$cnum); + if ( defined($csettings{'internal.courseowner'}) ) { + my $owner = $csettings{'internal.courseowner'}; + @{$$users{'ow'}{$owner.':'.$cdom}} = 'any'; + if (defined($userdata) && + !exists($$userdata{$owner.':'.$cdom})) { + &get_user_info($cdom,$owner,\%idx,$userdata); + } + } + } + } + } + return; +} + +sub get_user_info { + my ($udom,$uname,$idx,$userdata) = @_; + $$userdata{$uname.':'.$udom}[$$idx{fullname}] = + &plainname($uname,$udom,'lastname'); + $$userdata{$uname.':'.$udom}[$$idx{uname}] = $uname; + $$userdata{$uname.':'.$udom}[$$idx{uname}] = $udom; + return; +} + +############################################### + 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; @@ -2602,8 +3325,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; } @@ -2635,7 +3358,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'); @@ -2645,14 +3368,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 @@ -2665,8 +3388,7 @@ sub get_unprocessed_cgi { if (!defined($possible_names) || (grep {$_ eq $name} @$possible_names)) { $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) }; } } } @@ -2680,12 +3402,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 @@ -2697,16 +3419,19 @@ 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) = @_; + &no_cache($r); + if ($env{'browser.mathml'} && $type eq 'text/html') { $type='text/xml'; } unless ($charset) { $charset=&Apache::lonlocal::current_encoding; } @@ -2722,7 +3447,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. @@ -2730,18 +3455,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; } } @@ -2749,7 +3474,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 @@ -2759,12 +3484,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); @@ -2782,25 +3507,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); } } @@ -2812,8 +3537,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 @@ -2822,13 +3547,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 @@ -2837,14 +3562,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; } } @@ -2852,30 +3582,35 @@ 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 takeleft { + my $index=shift; + return substr('0000'.$index,-4,4); +} + 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=$_; $field=~s/^(\"|\')//; $field=~s/(\"|\')$//; - $components{$i}=$field; + $components{&takeleft($i)}=$field; $i++; } - } elsif ($ENV{'form.upfiletype'} eq 'tab') { + } elsif ($env{'form.upfiletype'} eq 'tab') { my $i=0; foreach (split(/\t/,$record)) { my $field=$_; $field=~s/^(\"|\')//; $field=~s/(\"|\')$//; - $components{$i}=$field; + $components{&takeleft($i)}=$field; $i++; } } else { @@ -2893,7 +3628,7 @@ sub record_sep { $field=~s/^\s*$delimiter//; $field=~s/$delimiter\s*$//; } - $components{$i}=$field; + $components{&takeleft($i)}=$field; $i++; } } @@ -3002,7 +3737,7 @@ sub csv_print_select_table { $r->print(''); foreach (sort({$a <=> $b} keys(%sone))) { $r->print(''); } $r->print(''."\n"); @@ -3046,13 +3781,13 @@ sub csv_samples_select_table { foreach (@$d) { my ($value,$display,$defaultcol)=@{ $_ }; $r->print(''); } $r->print(''); - if (defined($sone{$_})) { $r->print($sone{$_}."
\n"); } - if (defined($stwo{$_})) { $r->print($stwo{$_}."
\n"); } - if (defined($sthree{$_})) { $r->print($sthree{$_}."
\n"); } + if (defined($sone{$_})) { $r->print($sone{$_}."
\n"); } + if (defined($stwo{$_})) { $r->print($stwo{$_}."
\n"); } + if (defined($sthree{$_})) { $r->print($sthree{$_}."
\n"); } $r->print(''); $i++; } @@ -3141,7 +3876,7 @@ the routine &Apache::lonnet::transfer_pr my $uniq=0; sub get_cgi_id { $uniq=($uniq+1)%100000; - return (time.'_'.$uniq); + return (time.'_'.$$.'_'.$uniq); } ############################################################ @@ -3177,6 +3912,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: @@ -3197,13 +3935,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) { @@ -3213,7 +3966,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; @@ -3231,15 +3992,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++; @@ -3262,6 +4014,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 ''; } @@ -3496,8 +4253,8 @@ Inputs: sub chartlink { my ($linktext, $sname, $sdomain) = @_; my $link = ''.$linktext.''; } @@ -3538,34 +4295,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; } @@ -3574,7 +4331,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); @@ -3585,20 +4342,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}) ]; } } @@ -3631,9 +4388,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