--- loncom/interface/loncommon.pm 2004/04/21 20:46:58 1.189 +++ loncom/interface/loncommon.pm 2006/03/21 21:01:22 1.318 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # a pile of common routines # -# $Id: loncommon.pm,v 1.189 2004/04/21 20:46:58 matthew Exp $ +# $Id: loncommon.pm,v 1.318 2006/03/21 21:01:22 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,27 +131,42 @@ BEGIN { close($fh); } } - -# -------------------------------------------------------------- domain designs - - my $filename; - my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors'; - opendir(DIR,$designdir); - while ($filename=readdir(DIR)) { - my ($domain)=($filename=~/^(\w+)\./); +# ------------------------------------------------------------------ source copyrights { - my $designfile = $designdir.'/'.$filename; - if ( open (my $fh,"<$designfile") ) { + my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}. + '/source_copyright.tab'; + if ( open (my $fh,"<$sourcecopyrightfile") ) { while (<$fh>) { next if /^\#/; chomp; - my ($key,$val)=(split(/\=/,$_)); - if ($val) { $designhash{$domain.'.'.$key}=$val; } + my ($key,$val)=(split(/\s+/,$_,2)); + $scprtag{$key}=$val; } close($fh); } } +# -------------------------------------------------------------- domain designs + + my $filename; + 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); + } + } + } closedir(DIR); @@ -235,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'; } @@ -303,9 +330,12 @@ 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'}) + || &Apache::lonnet::allowed('srm',$env{'request.course.id'}. + '/'.$env{'request.course.sec'}) + )) + || ($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 +810,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 +821,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 +855,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 +869,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 +973,10 @@ format. sub csv_translate { my $text = shift; $text =~ s/\"/\"\"/g; - $text =~ s/\n//g; + $text =~ s/\n/ /g; return $text; } - ############################################################### ############################################################### @@ -755,6 +1000,10 @@ Currently supported formats: =item h3 +=item h4 + +=item i + =item date =back @@ -777,8 +1026,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 +1038,83 @@ sub define_excel_formats { =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. +=item * create_workbook -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. +Create an Excel worksheet. If it fails, output message on the +request object and return undefs. -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. +Inputs: Apache request object -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 @@ -907,21 +1157,49 @@ sub domain_select { } &get_domains; if ($multiple) { $domains{''}=&mt('Any domain'); - return &multiple_select_form($name,$value,%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,%hash)=@_; + my ($name,$value,$size,$hash,$order)=@_; my %selected = map { $_ => 1 } ref($value)?@{$value}:($value); my $output=''; - my $size =(scalar keys %hash<4?scalar keys %hash:4); + if (! defined($size)) { + $size = 4; + if (scalar(keys(%$hash))<4) { + $size = scalar(keys(%$hash)); + } + } $output.="\n\n"; return $output; @@ -951,7 +1229,7 @@ sub select_form { } foreach (@keys) { $selectform.="\n"; } $selectform.=""; @@ -988,7 +1266,7 @@ sub select_level_form { my $selectform = ""; @@ -1018,7 +1296,7 @@ sub select_dom_form { my $selectdomain = ""; @@ -1117,9 +1395,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=''; @@ -1315,10 +1595,11 @@ sub authform_nochange{ kerb_def_dom => 'MSU.EDU', @_, ); - my $result = &mt('[_1] Do not change login data', + my $result = ''; return $result; } @@ -1350,14 +1631,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; } @@ -1382,9 +1664,9 @@ sub authform_internal{ my $jscall = "javascript:changed_radio('int',$args{'formname'});"; my $result.=&mt ('[_1] Internally authenticated (with initial password [_2])', - '', - ''); return $result; } @@ -1409,9 +1691,9 @@ sub authform_local{ my $jscall = "javascript:changed_radio('loc',$in{'formname'});"; my $result.=&mt('[_1] Local Authentication with argument [_2]', - '', - ''); return $result; } @@ -1425,9 +1707,9 @@ sub authform_filesystem{ my $jscall = "javascript:changed_radio('fsys',$in{'formname'});"; my $result.= &mt ('[_1] Filesystem Authenticated (with initial password [_2])', - '', - ''); return $result; } @@ -1634,23 +1916,28 @@ 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 %names=&Apache::lonnet::get('environment', - ['firstname','middlename','lastname','generation'], - $udom,$uname); - my $name=$names{'firstname'}.' '.$names{'middlename'}.' '. - $names{'lastname'}.' '.$names{'generation'}; + my ($uname,$udom,$first)=@_; + my %names=&getnames($uname,$udom); + 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; } return $name; } @@ -1673,8 +1960,7 @@ 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=&getnames($uname,$udom); my $name=$names{'nickname'}; if ($name) { $name='"'.$name.'"'; @@ -1687,6 +1973,20 @@ sub nickname { return $name; } +sub getnames { + my ($uname,$udom)=@_; + my $id=$uname.':'.$udom; + my ($names,$cached)=&Apache::lonnet::is_cached_new('namescache',$id); + if ($cached) { + return %{$names}; + } else { + my %loadnames=&Apache::lonnet::get('environment', + ['firstname','middlename','lastname','generation','nickname'], + $udom,$uname); + &Apache::lonnet::do_cache_new('namescache',$id,\%loadnames); + return %loadnames; + } +} # ------------------------------------------------------------------ Screenname @@ -1700,17 +2000,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 @@ -1723,8 +2027,8 @@ sub noteswrapper { sub aboutmewrapper { my ($link,$username,$domain,$target)=@_; - return "$link"; + return ''.$link.''; } # ------------------------------------------------------------ Syllabus Wrapper @@ -1735,7 +2039,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 @@ -1807,6 +2129,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 @@ -1902,8 +2248,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; } } @@ -1912,24 +2258,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'}}) { @@ -2108,7 +2454,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; @@ -2148,7 +2494,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 @@ -2156,15 +2502,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.''; } ############################################## @@ -2194,7 +2589,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)); } ######################################### @@ -2202,9 +2597,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; } @@ -2241,9 +2636,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; @@ -2265,10 +2660,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 { @@ -2290,7 +2683,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'; } @@ -2301,8 +2694,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}) { @@ -2344,6 +2737,13 @@ Inputs: =item * $forcereg, if page should register as content page (relevant for text interface only) +=item * $customtitle, overrides the $title in some way ???? + +=item * $notopbar, if true, keep the 'what is this' info but remove the + navigational links + +=item * $bgcolor, used to override the bg coor on a webpage to a specific value + =back Returns: A uniform header for LON-CAPA web pages. @@ -2354,11 +2754,12 @@ other decorations will be returned. =cut sub bodytag { - my ($title,$function,$addentries,$bodyonly,$domain,$forcereg)=@_; + my ($title,$function,$addentries,$bodyonly,$domain,$forcereg,$customtitle, + $notopbar,$bgcolor)=@_; $title=&mt($title); $function = &get_users_function() if (!$function); my $img=&designparm($function.'.img',$domain); - my $pgbg=&designparm($function.'.pgbg',$domain); + my $pgbg= $bgcolor || &designparm($function.'.pgbg',$domain); my $tabbg=&designparm($function.'.tabbg',$domain); my $font=&designparm($function.'.font',$domain); my $link=&designparm($function.'.link',$domain); @@ -2368,16 +2769,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 @@ -2387,33 +2788,122 @@ 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.')'; + } + # Explicit link to get inline menu + my $menu='
 '.&mt('Switch to Inline Menu Mode').''; + # return(< @@ -2423,13 +2913,13 @@ $upperleft - $title - +$titleinfo $dc_info $menu + - $ENV{'environment.firstname'} - $ENV{'environment.middlename'} - $ENV{'environment.lastname'} - $ENV{'environment.generation'} + $env{'environment.firstname'} + $env{'environment.middlename'} + $env{'environment.lastname'} + $env{'environment.generation'}   @@ -2438,14 +2928,257 @@ $upperleft $realm  -
+
ENDBODY } ############################################### +############################################### =pod +=back + +=head1 HTML Helpers + +=over 4 + +=item * &endbodytag() + +Returns a uniform footer for LON-CAPA web pages. + +Inputs: none + +=back + +=cut + +sub endbodytag { + my $endbodytag=''; + $endbodytag=&Apache::lontexconvert::jsMath_process()."\n".$endbodytag; + if ( exists( $env{'internal.head.redirect'} ) ) { + $endbodytag= + "
". + &mt('Continue').''. + $endbodytag; + } + return $endbodytag; +} + +=pod + +=over 4 + +=item * &headtag() + +Returns a uniform footer for LON-CAPA web pages. + +Inputs: $title - optional title for the head + $head_extra - optional extra HTML to put inside the + $args - optional arguments + redirect - array ref of seconds before redirect occurs + url to redirect to + (side effect of setting + $env{'internal.head.redirect'} to the url + redirected too) +=back + +=cut + +sub headtag { + my ($title,$head_extra,$args) = @_; + + my $result = + ''. + &Apache::lonxml::fontsettings(). + &Apache::lonhtmlcommon::htmlareaheaders(); + + if (ref($args->{'redirect'})) { + my ($time,$url) = @{$args->{'redirect'}}; + $url = &Apache::lonenc::check_encrypt($url); + $env{'internal.head.redirect'} = $url; + $result.=< + +ADDMETA + } + if (!defined($title)) { + $title = 'The LearningOnline Network with CAPA'; + } + + $result .= ' LON-CAPA '.&mt($title).''.$head_extra; + + return $result; +} + +=pod + +=over 4 + +=item * &endheadtag() + +Returns a uniform for LON-CAPA web pages. + +Inputs: none + +=back + +=cut + +sub endheadtag { + return ''; +} + +=pod + +=over 4 + +=item * &head() + +Returns a uniform complete .. section for LON-CAPA web pages. + +Inputs: $title - optional title for the page + $head_extra - optional extra HTML to put inside the +=back + +=cut + +sub head { + my ($title,$head_extra) = @_; + return &headtag($title,$head_extra).&endheadtag(); +} + +=pod + +=over 4 + +=item * &start_page() + +Returns a complete .. section for LON-CAPA web pages. + +Inputs: $title - optional title for the page + $head_extra - optional extra HTML to incude inside the + $args - additional optional args supported are: + only_body -> is true will set &bodytag() onlybodytag + arg on + no_nav_bar -> is true will set &bodytag() notopbar arg on + add_entries -> additional attributes to add to the + domain -> force to color decorate a page for a + specific domain + function -> force usage of a specific rolish color + scheme + redirect -> see &headtag() + bgcolor -> override the default page bg color + js_ready -> return a string ready for being used in + a javascript writeln + force_register -> if is true will turn on the &bodytag() + $forcereg arg + +=back + +=cut + +sub start_page { + my ($title,$head_extra,$args) = @_; + #&Apache::lonnet::logthis("start_page ".join(':',caller(0))); + my %head_args; + if (defined($args->{'redirect'})) { + $head_args{'redirect'} = $args->{'redirect'}; + } + $env{'internal.start_page'}++; + my $result = + &Apache::lonxml::xmlbegin(). + &headtag($title,$head_extra,\%head_args).&endheadtag(). + &bodytag($title, + $args->{'function'}, $args->{'add_entries'}, + $args->{'only_body'}, $args->{'domain'}, + $args->{'force_register'}, undef, + $args->{'no_nav_bar'}, $args->{'bgcolor'}); + if ($args->{'js_ready'}) { + $result = &js_ready($result); + } + return $result; +} + +=pod + +=over 4 + +=item * &head() + +Returns a complete section for LON-CAPA web pages. + +Inputs: $args - additional optional args supported are: + js_ready -> return a string ready for being used in + a javascript writeln +=back + +=cut + +sub end_page { + my ($args) = @_; + #&Apache::lonnet::logthis("end_page ".join(':',caller(0))); + $env{'internal.end_page'}++; + my $result = &endbodytag()."\n"; + if ($args->{'js_ready'}) { + $result = &js_ready($result); + } + return $result; +} + +sub js_ready { + my ($result) = @_; + $result = &HTML::Entities::encode($result,'<>&"'); + + $result =~ s/[\n\r]/ /g; + $result =~ s/'/\\'/g; + + return $result; +} + +sub validate_page { + if ( exists($env{'internal.start_page'}) + && $env{'internal.start_page'} > 1) { + &Apache::lonnet::logthis('start_page called multiple times '. + $env{'internal.start_page'}.' '. + $ENV{'request.filename'}); + } + if ( exists($env{'internal.end_page'}) + && $env{'internal.end_page'} > 1) { + &Apache::lonnet::logthis('end_page called multiple times '. + $env{'internal.end_page'}.' '. + $env{'request.filename'}); + } + if ( exists($env{'internal.start_page'}) + && ! exists($env{'internal.end_page'})) { + &Apache::lonnet::logthis('start_page called without end_page '. + $env{'request.filename'}); + } + if ( ! exists($env{'internal.start_page'}) + && exists($env{'internal.end_page'})) { + &Apache::lonnet::logthis('end_page called without start_page'. + $env{'request.filename'}); + } +} + +sub simple_error_page { + my ($r,$title,$msg) = @_; + my $page = + &Apache::loncommon::start_page($title). + &mt($msg). + &Apache::loncommon::end_page(); + if (ref($r)) { + $r->print($page); + return; + } + return $page; +} +############################################### + +=pod + +=over 4 + =item get_users_function Used by &bodytag to determine the current users primary role. @@ -2456,13 +3189,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'; } @@ -2471,12 +3204,402 @@ 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 coursegroups + +Retrieve information about groups in a course, + +Input: +1. Reference to hash to populate with group information. +2. Optional course domain +3. Optional course number +4. Optional group name + +Course domain and number will be taken from user's +environment if not supplied. Optional group name will' +be passed to lonnet::get_coursegroups() as a regexp to +use in the call to the dump function. + +Output +Returns number of groups in the course (subject to the +optional group name filter). + +Side effects: +Populates the referenced curr_groups hash, with key, +value pairs. Keys are group names, corresponding values +are scalars containing group information in XML. This +can be sent to &get_group_settings() to be parsed. + +=cut + +############################################### + +sub coursegroups { + my ($curr_groups,$cdom,$cnum,$group) = @_; + my $numgroups; + if (!defined($cdom) || !defined($cnum)) { + my $cid = $env{'request.course.id'}; + $cdom = $env{'course.'.$cid.'.domain'}; + $cnum = $env{'course.'.$cid.'.num'}; + } + %{$curr_groups} = &Apache::lonnet::get_coursegroups($cdom,$cnum,$group); + my ($tmp) = keys(%{$curr_groups}); + if ($tmp=~/^error:/) { + unless ($tmp eq 'error: 2 tie(GDBM) Failed while attempting dump') { + &logthis('Error retrieving groups: '.$tmp.' in '.$cnum.':'. + $cdom); + } + $numgroups = 0; + } else { + $numgroups = keys(%{$curr_groups}); + } + return $numgroups; +} + +############################################### + +=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 &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 +whether 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 $role = ''; + my %content=(); + while ($token=$parser->get_token) { + if ($token->[0] eq 'S') { + my $entry=$token->[1]; + if ($entry eq 'functions' || $entry eq 'autosec') { + %{$content{$entry}} = (); + $tool = $entry; + } elsif ($entry eq 'role') { + if ($tool eq 'autosec') { + $role = $token->[2]{id}; + } + } 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); + } elsif (($entry eq 'roles') || ($entry eq 'types') || + ($entry eq 'sectionpick') || ($entry eq 'defpriv')) { + push(@{$content{$entry}},$value); + } elsif ($entry eq 'section') { + if ($tool eq 'autosec' && $role ne '') { + push(@{$content{$tool}{$role}},$value); + } + } else { + $content{$entry}=$value; + } + } + } elsif ($token->[0] eq 'E') { + if ($token->[1] eq 'functions' || $token->[1] eq 'autosec') { + $tool = ''; + } elsif ($token->[1] eq 'role') { + $role = ''; + } + + } + } + 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{udom}] = $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; @@ -2501,8 +3624,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; } @@ -2534,7 +3657,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'); @@ -2544,14 +3667,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 @@ -2564,8 +3687,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) }; } } } @@ -2579,12 +3701,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 @@ -2596,16 +3718,22 @@ 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 ($r) { + # Note that printout.pl calls this with undef for $r. + &no_cache($r); + } + if ($env{'browser.mathml'} && $type eq 'text/html') { $type='text/xml'; } unless ($charset) { $charset=&Apache::lonlocal::current_encoding; } @@ -2621,7 +3749,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. @@ -2629,18 +3757,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; } } @@ -2648,7 +3776,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 @@ -2658,12 +3786,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); @@ -2681,25 +3809,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); } } @@ -2711,8 +3839,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 @@ -2721,13 +3849,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 @@ -2736,14 +3864,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; } } @@ -2751,30 +3884,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 { @@ -2792,7 +3930,7 @@ sub record_sep { $field=~s/^\s*$delimiter//; $field=~s/$delimiter\s*$//; } - $components{$i}=$field; + $components{&takeleft($i)}=$field; $i++; } } @@ -2829,6 +3967,22 @@ sub upfile_select_html { return $Str; } +sub get_samples { + my ($records,$toget) = @_; + my @samples=({}); + my $got=0; + foreach my $rec (@$records) { + my %temp = &record_sep($rec); + if (! grep(/\S/, values(%temp))) { next; } + if (%temp) { + $samples[$got]=\%temp; + $got++; + if ($got == $toget) { last; } + } + } + return \@samples; +} + ###################################################### ###################################################### @@ -2846,18 +4000,15 @@ Apache Request ref, $records is an array ###################################################### sub csv_print_samples { my ($r,$records) = @_; - my (%sone,%stwo,%sthree); - %sone=&record_sep($$records[0]); - if (defined($$records[1])) {%stwo=&record_sep($$records[1]);} - if (defined($$records[2])) {%sthree=&record_sep($$records[2]);} - # + my $samples = &get_samples($records,3); + $r->print(&mt('Samples').'
'); - foreach (sort({$a <=> $b} keys(%sone))) { + foreach (sort({$a <=> $b} keys(%{ $samples->[0] }))) { $r->print(''); } $r->print(''); - foreach my $hash (\%sone,\%stwo,\%sthree) { + foreach my $hash (@$samples) { $r->print(''); - foreach (sort({$a <=> $b} keys(%sone))) { + foreach (sort({$a <=> $b} keys(%{ $samples->[0] }))) { $r->print(''); @@ -2886,8 +4037,8 @@ $d is an array of 2 element arrays (inte ###################################################### sub csv_print_select_table { my ($r,$records,$d) = @_; - my $i=0;my %sone; - %sone=&record_sep($$records[0]); + my $i=0; + my $samples = &get_samples($records,1); $r->print(&mt('Associate columns with student attributes.')."\n". '
'.&mt('Column [_1]',($_+1)).'
'); if (defined($$hash{$_})) { $r->print($$hash{$_}); } $r->print('
'. ''. @@ -2899,9 +4050,9 @@ sub csv_print_select_table { $r->print(''."\n"); @@ -2930,28 +4081,27 @@ $d is an array of 2 element arrays (inte ###################################################### sub csv_samples_select_table { my ($r,$records,$d) = @_; - my %sone; my %stwo; my %sthree; my $i=0; # + my $samples = &get_samples($records,3); $r->print('
'.&mt('Attribute').'
'); - %sone=&record_sep($$records[0]); - if (defined($$records[1])) {%stwo=&record_sep($$records[1]);} - if (defined($$records[2])) {%sthree=&record_sep($$records[2]);} - # - foreach (sort keys %sone) { + + foreach my $key (sort(keys(%{ $samples->[0] }))) { $r->print(''); $i++; } @@ -3040,7 +4190,7 @@ the routine &Apache::lonnet::transfer_pr my $uniq=0; sub get_cgi_id { $uniq=($uniq+1)%100000; - return (time.'_'.$uniq); + return (time.'_'.$$.'_'.$uniq); } ############################################################ @@ -3076,6 +4226,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: @@ -3096,13 +4249,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) { @@ -3112,7 +4280,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; @@ -3130,15 +4306,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++; @@ -3161,6 +4328,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 ''; } @@ -3395,8 +4567,8 @@ Inputs: sub chartlink { my ($linktext, $sname, $sdomain) = @_; my $link = ''.$linktext.''; } @@ -3437,34 +4609,35 @@ 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 $udom = $env{'user.domain'}; + my $uname = $env{'user.name'}; 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})) { + my $basename = join('.','internal',$courseid,$prefix,$setting); + my $envname = 'environment.'.$basename; + 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; } @@ -3472,8 +4645,7 @@ sub store_course_settings { } } my $put_result = &Apache::lonnet::put('environment',\%SaveHash, - $coursedom, - $ENV{'course.'.$courseid.'.num'}); + $udom,$uname); if ($put_result !~ /^(ok|delayed)/) { &Apache::lonnet::logthis('unable to save form parameters, '. 'got error:'.$put_result); @@ -3484,20 +4656,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})); - my $envname = 'course.'.$courseid.'.internal.'.$prefix. + next if (exists($env{'form.'.$setting})); + my $envname = 'environment.internal.'.$courseid.'.'.$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}) ]; } } @@ -3530,9 +4702,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
'. &mt('Field').''.&mt('Samples').'
'); - if (defined($sone{$_})) { $r->print($sone{$_}."
\n"); } - if (defined($stwo{$_})) { $r->print($stwo{$_}."
\n"); } - if (defined($sthree{$_})) { $r->print($sthree{$_}."
\n"); } + foreach my $line (0..2) { + if (defined($samples->[$line]{$key})) { + $r->print($samples->[$line]{$key}."
\n"); + } + } $r->print('