--- loncom/interface/loncommon.pm 2006/04/11 18:43:46 1.330 +++ loncom/interface/loncommon.pm 2006/12/08 20:09:29 1.489 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # a pile of common routines # -# $Id: loncommon.pm,v 1.330 2006/04/11 18:43:46 albertel Exp $ +# $Id: loncommon.pm,v 1.489 2006/12/08 20:09:29 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -61,6 +61,11 @@ use POSIX qw(strftime mktime); use Apache::lonmenu(); use Apache::lonlocal; use HTML::Entities; +use Apache::lonhtmlcommon(); +use Apache::loncoursedata(); +use Apache::lontexconvert(); +use Apache::lonclonecourse(); +use LONCAPA qw(:DEFAULT :match); my $readit; @@ -73,7 +78,7 @@ my %language; my %supported_language; my %cprtag; my %scprtag; -my %fe; my %fd; +my %fe; my %fd; my %fm; my %category_extensions; # ---------------------------------------------- Designs @@ -104,10 +109,10 @@ BEGIN { my $langtabfile = $Apache::lonnet::perlvar{'lonTabDir'}. '/language.tab'; if ( open(my $fh,"<$langtabfile") ) { - while (<$fh>) { - next if /^\#/; - chomp; - my ($key,$two,$country,$three,$enc,$val,$sup)=(split(/\t/,$_)); + while (my $line = <$fh>) { + next if ($line=~/^\#/); + chomp($line); + my ($key,$two,$country,$three,$enc,$val,$sup)=(split(/\t/,$line)); $language{$key}=$val.' - '.$enc; if ($sup) { $supported_language{$key}=$sup; @@ -121,24 +126,24 @@ BEGIN { my $copyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}. '/copyright.tab'; if ( open (my $fh,"<$copyrightfile") ) { - while (<$fh>) { - next if /^\#/; - chomp; - my ($key,$val)=(split(/\s+/,$_,2)); + while (my $line = <$fh>) { + next if ($line=~/^\#/); + chomp($line); + my ($key,$val)=(split(/\s+/,$line,2)); $cprtag{$key}=$val; } close($fh); } } -# ------------------------------------------------------------------ source copyrights +# ----------------------------------------------------------- source copyrights { my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}. '/source_copyright.tab'; if ( open (my $fh,"<$sourcecopyrightfile") ) { - while (<$fh>) { - next if /^\#/; - chomp; - my ($key,$val)=(split(/\s+/,$_,2)); + while (my $line = <$fh>) { + next if ($line =~ /^\#/); + chomp($line); + my ($key,$val)=(split(/\s+/,$line,2)); $scprtag{$key}=$val; } close($fh); @@ -152,14 +157,14 @@ BEGIN { opendir(DIR,$designdir); while ($filename=readdir(DIR)) { if ($filename!~/\.tab$/) { next; } - my ($domain)=($filename=~/^(\w+)\./); + my ($domain)=($filename=~/^($match_domain)\./); { my $designfile = $designdir.'/'.$filename; if ( open (my $fh,"<$designfile") ) { - while (<$fh>) { - next if /^\#/; - chomp; - my ($key,$val)=(split(/\=/,$_)); + while (my $line = <$fh>) { + next if ($line =~ /^\#/); + chomp($line); + my ($key,$val)=(split(/\=/,$line)); if ($val) { $designhash{$domain.'.'.$key}=$val; } } close($fh); @@ -175,10 +180,10 @@ BEGIN { my $categoryfile = $Apache::lonnet::perlvar{'lonTabDir'}. '/filecategories.tab'; if ( open (my $fh,"<$categoryfile") ) { - while (<$fh>) { - next if /^\#/; - chomp; - my ($extension,$category)=(split(/\s+/,$_,2)); + while (my $line = <$fh>) { + next if ($line =~ /^\#/); + chomp($line); + my ($extension,$category)=(split(/\s+/,$line,2)); push @{$category_extensions{lc($category)}},$extension; } close($fh); @@ -190,13 +195,14 @@ BEGIN { my $typesfile = $Apache::lonnet::perlvar{'lonTabDir'}. '/filetypes.tab'; if ( open (my $fh,"<$typesfile") ) { - while (<$fh>) { - next if (/^\#/); - chomp; - my ($ending,$emb,$descr)=split(/\s+/,$_,3); + while (my $line = <$fh>) { + next if ($line =~ /^\#/); + chomp($line); + my ($ending,$emb,$mime,$descr)=split(/\s+/,$line,4); if ($descr ne '') { $fe{$ending}=lc($emb); $fd{$ending}=$descr; + if ($mime ne 'unk') { $fm{$ending}=$mime; } } } close($fh); @@ -251,7 +257,7 @@ of the element the selection from the se sub browser_and_searcher_javascript { my ($mode)=@_; if (!defined($mode)) { $mode='edit'; } - my $resurl=&lastresurl(); + my $resurl=&escape_single(&lastresurl()); return < -1) { + var domid = getIndexByName(formid,udom); + if (domid > -1) { + if (document.forms[formid].elements[domid].type == 'select-one') { + domainfilter=document.forms[formid].elements[domid].options[document.forms[formid].elements[domid].selectedIndex].value; + } + if (document.forms[formid].elements[domid].type == 'hidden') { + domainfilter=document.forms[formid].elements[domid].value; + } + } } - var domainfilter='$domainfilter'; if (domainfilter != null) { if (domainfilter != '') { url += 'domainfilter='+domainfilter+'&'; @@ -401,29 +415,108 @@ sub coursebrowser_javascript { url += 'form=' + formname + '&cnumelement='+uname+ '&cdomelement='+udom+ '&cnameelement='+desc; - if (extra_element !=null && extra_element != '' && formname == 'rolechoice') { - url += '&roleelement='+extra_element; - if (domainfilter == null || domainfilter == '') { - url += '&domainfilter='+extra_element; + if (extra_element !=null && extra_element != '') { + if (formname == 'rolechoice') { + url += '&roleelement='+extra_element; + if (domainfilter == null || domainfilter == '') { + url += '&domainfilter='+extra_element; + } } + else { + if (formname == 'portform') { + url += '&setroles='+extra_element; + } + } } if (multflag !=null && multflag != '') { url += '&multiple='+multflag; } + if (crstype == 'Course/Group') { + if (formname == 'cu') { + crstype = document.cu.crstype.options[document.cu.crstype.selectedIndex].value; + if (crstype == "") { + alert("$crs_or_grp_alert"); + return; + } + } + } + if (crstype !=null && crstype != '') { + url += '&type='+crstype; + } var title = 'Course_Browser'; var options = 'scrollbars=1,resizable=1,menubar=0'; options += ',width=700,height=600'; stdeditbrowser = open(url,title,options,'1'); stdeditbrowser.focus(); } - + + function getFormIdByName(formname) { + for (var i=0;i".&mt('Select Course').""; + '","'.$udomele.'","'.$desc.'","'.$extra_element.'","'.$multflag.'","'.$selecttype.'");'."'>".&mt('Select [_1]',$selecttype).""; } sub check_uncheck_jscript { @@ -654,14 +747,14 @@ sub help_open_topic { { $template .= "". - "
$text"; + "$text"; } # Add the graphic my $title = &mt('Online Help'); my $helpicon=&lonhttpdurl("/adm/help/gif/smallHelp.gif"); $template .= <<"ENDTEMPLATE"; - (Help: $topic) + (Help: $topic) ENDTEMPLATE if ($text ne '') { $template.='
' }; return $template; @@ -688,44 +781,109 @@ sub helpLatexCheatsheet { .''; } -sub help_open_menu { - my ($color,$topic,$component_help,$function,$faq,$bug,$stayOnPage,$width,$height,$text) = @_; - $text = "" if (not defined $text); - $stayOnPage = 0 if (not defined $stayOnPage); - if ($env{'browser.interface'} eq 'textual' || - $env{'environment.remote'} eq 'off' ) { - $stayOnPage=1; +sub general_help { + my $helptopic='Student_Intro'; + if ($env{'request.role'}=~/^(ca|au)/) { + $helptopic='Authoring_Intro'; + } elsif ($env{'request.role'}=~/^cc/) { + $helptopic='Course_Coordination_Intro'; } - $width = 620 if (not defined $width); - $height = 600 if (not defined $height); - my $link=''; - my $title = &mt('Get help'); + return $helptopic; +} + +sub update_help_link { + my ($topic,$component_help,$faq,$bug,$stayOnPage) = @_; my $origurl = $ENV{'REQUEST_URI'}; $origurl=~s|^/~|/priv/|; my $timestamp = time; - foreach (\$color,\$function,\$topic,\$component_help,\$faq,\$bug,\$origurl) { - $$_ = &Apache::lonnet::escape($$_); + foreach my $datum (\$topic,\$component_help,\$faq,\$bug,\$origurl) { + $$datum = &escape($$datum); } - if (!$stayOnPage) { - $link = "javascript:helpMenu('open')"; - } else { - $link = "javascript:helpMenu('display')"; + + my $banner_link = "/adm/helpmenu?page=banner&topic=$topic&component_help=$component_help&faq=$faq&bug=$bug&origurl=$origurl&stamp=$timestamp&stayonpage=$stayOnPage"; + my $output .= <<"ENDOUTPUT"; + +ENDOUTPUT + return $output; +} + +# now just updates the help link and generates a blue icon +sub help_open_menu { + my ($topic,$component_help,$faq,$bug,$stayOnPage,$width,$height,$text) + = @_; + + $stayOnPage = 0 if (not defined $stayOnPage); + if ($env{'browser.interface'} eq 'textual' || + $env{'environment.remote'} eq 'off' ) { + $stayOnPage=1; } - my $banner_link = "/adm/helpmenu?page=banner&color=$color&function=$function&topic=$topic&component_help=$component_help&faq=$faq&bug=$bug&origurl=$origurl&stamp=$timestamp&stayonpage=$stayOnPage"; - my $details_link = "/adm/helpmenu?page=body&color=$color&function=$function&topic=$topic&component_help=$component_help&faq=$faq&bug=$bug&origurl=$origurl&stamp=$timestamp"; - my $template; - if ($text ne "") { - $template .= - "". - "
$text"; + my $output; + if ($component_help) { + if (!$text) { + $output=&help_open_topic($component_help,undef,$stayOnPage, + $width,$height); + } else { + my $help_text; + $help_text=&unescape($topic); + $output='
'. + &help_open_topic($component_help,$help_text,$stayOnPage, + $width,$height).'
'; + } } + my $banner_link = &update_help_link($topic,$component_help,$faq,$bug,$stayOnPage); + return $output.$banner_link; +} + +sub top_nav_help { + my ($text) = @_; + + $text = &mt($text); + + my $stayOnPage = + ($env{'browser.interface'} eq 'textual' || + $env{'environment.remote'} eq 'off' ); + my $link= ($stayOnPage) ? "javascript:helpMenu('display')" + : "javascript:helpMenu('open')"; + my $banner_link = &update_help_link(undef,undef,undef,undef,$stayOnPage); + + my $title = &mt('Get help'); + + return <<"END"; +$banner_link + $text +END +} + +sub help_menu_js { + my ($text) = @_; + + my $stayOnPage = + ($env{'browser.interface'} eq 'textual' || + $env{'environment.remote'} eq 'off' ); + + my $width = 620; + my $height = 600; + my $helptopic=&general_help(); + my $details_link = '/adm/help/'.$helptopic.'.hlp'; my $nothing=&Apache::lonhtmlcommon::javascript_nothing(); - my $html=&Apache::lonxml::xmlbegin(); - my $helpicon=&lonhttpdurl("/adm/lonIcons/helpgateway.gif"); - $template .= <<"ENDTEMPLATE"; - - (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; } @@ -789,8 +930,8 @@ sub help_open_bug { $topic=~s/\W+/\+/g; my $link=''; my $template=''; - my $url=$Apache::lonnet::perlvar{'BugzillaHost'}.'enter_bug.cgi?product=LON-CAPA&bug_file_loc='. - &Apache::lonnet::escape($ENV{'REQUEST_URI'}).'&component='.$topic; + my $url=$Apache::lonnet::perlvar{'BugzillaHost'}.'enter_bug.cgi?product=LON-CAPA&bug_file_loc='. + &escape($ENV{'REQUEST_URI'}).'&component='.$topic; if (!$stayOnPage) { $link = "javascript:void(open('$url', 'Bugzilla', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))"; @@ -804,14 +945,14 @@ sub help_open_bug { { $template .= "". - "
$text"; + "$text"; } # 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; @@ -849,14 +990,14 @@ sub help_open_faq { { $template .= "". - "
$text"; + "$text"; } # 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; @@ -1141,8 +1282,8 @@ sub get_domains { # The code below was stolen from "The Perl Cookbook", p 102, 1st ed. my @domains; my %seen; - foreach (sort values(%Apache::lonnet::hostdom)) { - push (@domains,$_) unless $seen{$_}++; + foreach my $dom (sort(values(%Apache::lonnet::hostdom))) { + push(@domains,$dom) unless $seen{$dom}++; } return @domains; } @@ -1196,7 +1337,7 @@ sub multiple_select_form { my @order = ref($order) ? @$order : sort(keys(%$hash)); foreach my $key (@order) { - $output.='\n"; } @@ -1226,15 +1367,34 @@ sub select_form { } else { @keys=sort(keys(%hash)); } - foreach (@keys) { - $selectform.="\n"; + foreach my $key (@keys) { + $selectform.= + '\n"; } $selectform.=""; return $selectform; } +# For display filters + +sub display_filter { + if (!$env{'form.show'}) { $env{'form.show'}=10; } + if (!$env{'form.displayfilter'}) { $env{'form.displayfilter'}='currentfolder'; } + return ' '. + &mt('Filter [_1]', + &select_form($env{'form.displayfilter'}, + 'displayfilter', + ('currentfolder' => 'Current folder/page', + 'containing' => 'Containing phrase', + 'none' => 'None'))). + ''; +} + sub gradeleveldescription { my $gradelevel=shift; my %gradelevels=(0 => 'Not specified', @@ -1293,10 +1453,10 @@ sub select_dom_form { my @domains = get_domains(); if ($includeempty) { @domains=('',@domains); } my $selectdomain = ""; return $selectdomain; @@ -1318,9 +1478,9 @@ given $domain. sub get_library_servers { my $domain = shift; my %library_servers; - foreach (keys(%Apache::lonnet::libserv)) { - if ($Apache::lonnet::hostdom{$_} eq $domain) { - $library_servers{$_} = $Apache::lonnet::hostname{$_}; + foreach my $hostid (keys(%Apache::lonnet::libserv)) { + if ($Apache::lonnet::hostdom{$hostid} eq $domain) { + $library_servers{$hostid} = $Apache::lonnet::hostname{$hostid}; } } return %library_servers; @@ -1342,9 +1502,10 @@ sub home_server_option_list { my $domain = shift; my %servers = &get_library_servers($domain); my $result = ''; - foreach (sort keys(%servers)) { + foreach my $hostid (sort(keys(%servers))) { $result.= - '\n"; + '\n"; } return $result; } @@ -1834,8 +1995,8 @@ sub initialize_keywords { } untie %thesaurus_db; # Remove special values from %Keywords. - foreach ('total.count','average.count') { - delete($Keywords{$_}) if (exists($Keywords{$_})); + foreach my $value ('total.count','average.count') { + delete($Keywords{$value}) if (exists($Keywords{$value})); } return 1; } @@ -1890,12 +2051,20 @@ sub get_related_words { return (); } my @Words=(); + my $count=0; if (exists($thesaurus_db{$keyword})) { - $_ = $thesaurus_db{$keyword}; - (undef,@Words) = split/:/; # The first element is the number of times - # the word appears. We do not need it now. - for (my $i=0;$i<=$#Words;$i++) { - ($Words[$i],undef)= split/\,/,$Words[$i]; + # The first element is the number of times + # the word appears. We do not need it now. + my (undef,@RelatedWords) = (split(/:/,$thesaurus_db{$keyword})); + my (undef,$mostfrequentcount)=split(/\,/,$RelatedWords[0]); + my $threshold=$mostfrequentcount/10; + foreach my $possibleword (@RelatedWords) { + my ($word,$wordcount)=split(/\,/,$possibleword); + if ($wordcount>$threshold) { + push(@Words,$word); + $count++; + if ($count>10) { last; } + } } } untie %thesaurus_db; @@ -1936,7 +2105,7 @@ sub plainname { $name=~s/^\s+//; $name=~s/\s+$//; $name=~s/\s+/ /g; - if ($name !~ /\S/) { $name=$uname.'@'.$udom; } + if ($name !~ /\S/) { $name=$uname.':'.$udom; } return $name; } @@ -1974,6 +2143,9 @@ sub nickname { sub getnames { my ($uname,$udom)=@_; + if ($udom eq 'public' && $uname eq 'public') { + return ('lastname' => &mt('Public')); + } my $id=$uname.':'.$udom; my ($names,$cached)=&Apache::lonnet::is_cached_new('namescache',$id); if ($cached) { @@ -1987,6 +2159,27 @@ sub getnames { } } +sub getemails { + my ($uname,$udom)=@_; + if ($udom eq 'public' && $uname eq 'public') { + return; + } + if (!$udom) { $udom=$env{'user.domain'}; } + if (!$uname) { $uname=$env{'user.name'}; } + my $id=$uname.':'.$udom; + my ($names,$cached)=&Apache::lonnet::is_cached_new('emailscache',$id); + if ($cached) { + return %{$names}; + } else { + my %loadnames=&Apache::lonnet::get('environment', + ['notification','critnotification', + 'permanentemail'], + $udom,$uname); + &Apache::lonnet::do_cache_new('emailscache',$id,\%loadnames); + return %loadnames; + } +} + # ------------------------------------------------------------------ Screenname =pod @@ -2009,10 +2202,11 @@ sub screenname { # ------------------------------------------------------------- Message Wrapper sub messagewrapper { - my ($link,$username,$domain)=@_; + my ($link,$username,$domain,$subject,$text)=@_; return - ''.$link.''; } # --------------------------------------------------------------- Notes Wrapper @@ -2026,8 +2220,11 @@ sub noteswrapper { sub aboutmewrapper { my ($link,$username,$domain,$target)=@_; + if (!defined($username) && !defined($domain)) { + return; + } return ''.$link.''; + ($target?' target="$target"':'').' title="'.&mt("View this user's personal page").'">'.$link.''; } # ------------------------------------------------------------ Syllabus Wrapper @@ -2056,7 +2253,9 @@ sub track_student_link { $target = ''; } if ($start) { $link.='&start='.$start; } - return qq{$linktext}; + + return qq{$linktext}. + &help_open_topic('View_recent_activity'); } =pod @@ -2172,7 +2371,8 @@ category =cut sub filecategorytypes { - return @{$category_extensions{lc($_[0])}}; + my ($cat) = @_; + return @{$category_extensions{lc($cat)}}; } =pod @@ -2187,6 +2387,10 @@ sub fileembstyle { return $fe{lc(shift(@_))}; } +sub filemimetype { + return $fm{lc(shift(@_))}; +} + sub filecategoryselect { my ($name,$value)=@_; @@ -2243,13 +2447,13 @@ sub fileextensions { sub display_languages { my %languages=(); - foreach (&preferred_languages()) { - $languages{$_}=1; + foreach my $lang (&preferred_languages()) { + $languages{$lang}=1; } &get_unprocessed_cgi($ENV{'QUERY_STRING'},['displaylanguage']); if ($env{'form.displaylanguage'}) { - foreach (split(/\s*(\,|\;|\:)\s*/,$env{'form.displaylanguage'})) { - $languages{$_}=1; + foreach my $lang (split(/\s*(\,|\;|\:)\s*/,$env{'form.displaylanguage'})) { + $languages{$lang}=1; } } return %languages; @@ -2262,7 +2466,8 @@ sub preferred_languages { $env{'course.'.$env{'request.course.id'}.'.languages'})); } if ($env{'environment.languages'}) { - @languages=split(/\s*(\,|\;|\:)\s*/,$env{'environment.languages'}); + @languages=(@languages, + split(/\s*(\,|\;|\:)\s*/,$env{'environment.languages'})); } my $browser=(split(/\;/,$ENV{'HTTP_ACCEPT_LANGUAGE'}))[0]; if ($browser) { @@ -2284,11 +2489,11 @@ sub preferred_languages { } # turn "en-ca" into "en-ca,en" my @genlanguages; - foreach (@languages) { - unless ($_=~/\w/) { next; } - push (@genlanguages,$_); - if ($_=~/(\-|\_)/) { - push (@genlanguages,(split(/(\-|\_)/,$_))[0]); + foreach my $lang (@languages) { + unless ($lang=~/\w/) { next; } + push (@genlanguages,$lang); + if ($lang=~/(\-|\_)/) { + push(@genlanguages,(split(/(\-|\_)/,$lang))[0]); } } return @genlanguages; @@ -2344,14 +2549,14 @@ sub get_previous_attempt { my %lasthash=(); my $version; for ($version=1;$version<=$returnhash{'version'};$version++) { - foreach (sort(split(/\:/,$returnhash{$version.':keys'}))) { - $lasthash{$_}=$returnhash{$version.':'.$_}; + foreach my $key (sort(split(/\:/,$returnhash{$version.':keys'}))) { + $lasthash{$key}=$returnhash{$version.':'.$key}; } } $prevattempts='
'; $prevattempts.=''; - foreach (sort(keys %lasthash)) { - my ($ign,@parts) = split(/\./,$_); + foreach my $key (sort(keys(%lasthash))) { + my ($ign,@parts) = split(/\./,$key); if ($#parts > 0) { my $data=$parts[-1]; pop(@parts); @@ -2367,27 +2572,27 @@ sub get_previous_attempt { if ($getattempt eq '') { for ($version=1;$version<=$returnhash{'version'};$version++) { $prevattempts.=''; - foreach (sort(keys %lasthash)) { + foreach my $key (sort(keys(%lasthash))) { my $value; - if ($_ =~ /timestamp/) { - $value=scalar(localtime($returnhash{$version.':'.$_})); + if ($key =~ /timestamp/) { + $value=scalar(localtime($returnhash{$version.':'.$key})); } else { - $value=$returnhash{$version.':'.$_}; + $value=$returnhash{$version.':'.$key}; } - $prevattempts.=''; + $prevattempts.=''; } } } $prevattempts.=''; - foreach (sort(keys %lasthash)) { + foreach my $key (sort(keys(%lasthash))) { my $value; - if ($_ =~ /timestamp/) { - $value=scalar(localtime($lasthash{$_})); + if ($key =~ /timestamp/) { + $value=scalar(localtime($lasthash{$key})); } else { - $value=$lasthash{$_}; + $value=$lasthash{$key}; } - $value=&Apache::lonnet::unescape($value); - if ($_ =~/$regexp$/ && (defined &$gradesub)) {$value = &$gradesub($value)} + $value=&unescape($value); + if ($key =~/$regexp$/ && (defined &$gradesub)) {$value = &$gradesub($value)} $prevattempts.=''; } $prevattempts.='
History
Transaction '.$version.''.&Apache::lonnet::unescape($value).' '.&unescape($value).' 
Current'.$value.' 
'; @@ -2419,14 +2624,14 @@ sub relative_to_absolute { } } $thisdir=~s-/[^/]*$--; - foreach (@rlinks) { - unless (($_=~/^http:\/\//i) || - ($_=~/^\//) || - ($_=~/^javascript:/i) || - ($_=~/^mailto:/i) || - ($_=~/^\#/)) { - my $newlocation=&Apache::lonnet::hreflocation($thisdir,$_); - $output=~s/(\"|\'|\=\s*)$_(\"|\'|\s|\>)/$1$newlocation$2/; + foreach my $link (@rlinks) { + unless (($link=~/^http:\/\//i) || + ($link=~/^\//) || + ($link=~/^javascript:/i) || + ($link=~/^mailto:/i) || + ($link=~/^\#/)) { + my $newlocation=&Apache::lonnet::hreflocation($thisdir,$link); + $output=~s/(\"|\'|\=\s*)\Q$link\E(\"|\'|\s|\>)/$1$newlocation$2/; } } # -------------------------------------------------- Deal with Applet codebases @@ -2504,11 +2709,11 @@ sub submlink { my ($text,$uname,$udom,$symb,$target)=@_; if (!($uname && $udom)) { (my $cursymb, my $courseid,$udom,$uname)= - &Apache::lonxml::whichuser($symb); + &Apache::lonnet::whichuser($symb); if (!$symb) { $symb=$cursymb; } } if (!$symb) { $symb=&Apache::lonnet::symbread(); } - $symb=&Apache::lonnet::escape($symb); + $symb=&escape($symb); if ($target) { $target="target=\"$target\""; } return ' 1 } @{$roles}; } + my %courses; my $now=time; - foreach (keys %env) { - if ($_=~/^user\.role\.\w+\.\/(\w+)\/(\w+)/) { - my ($starttime,$endtime)=$env{$_}; - my $active=1; - if ($starttime) { - if ($now<$starttime) { $active=0; } + if (!defined($uname)) { + $uname = $env{'user.name'}; + } + if (!defined($udom)) { + $udom = $env{'user.domain'}; + } + if (($uname ne $env{'user.name'}) || ($udom ne $env{'user.domain'})) { + my %roleshash = &Apache::lonnet::dump('roles',$udom,$uname); + if (!%roles) { + %roles = ( + cc => 1, + in => 1, + ep => 1, + ta => 1, + cr => 1, + st => 1, + ); + } + foreach my $entry (keys(%roleshash)) { + my ($trole,$tend,$tstart) = split(/_/,$roleshash{$entry}); + if ($trole =~ /^cr/) { + next if (!exists($roles{$trole}) && !exists($roles{'cr'})); + } else { + next if (!exists($roles{$trole})); } - if ($endtime) { - if ($now>$endtime) { $active=0; } + if ($tend) { + next if ($tend < $now); + } + if ($tstart) { + next if ($tstart > $now); + } + my ($cdom,$cnum,$sec,$cnumpart,$secpart,$role,$realsec); + (undef,$cdom,$cnumpart,$secpart) = split(/\//,$entry); + if ($secpart eq '') { + ($cnum,$role) = split(/_/,$cnumpart); + $sec = 'none'; + $realsec = ''; + } else { + $cnum = $cnumpart; + ($sec,$role) = split(/_/,$secpart); + $realsec = $sec; + } + $courses{$cdom.'_'.$cnum}{$sec} = $trole.'/'.$cdom.'/'.$cnum.'/'.$realsec; + } + } else { + foreach my $key (keys(%env)) { + if ( $key=~m{^user\.role\.(\w+)\./($match_domain)/($match_courseid)/?(\w*)$} || + $key=~m{^user\.role\.(cr/$match_domain/$match_username/\w+)\./($match_domain)/($match_courseid)/?(\w*)$}) { + my ($role,$cdom,$cnum,$sec) = ($1,$2,$3,$4); + next if ($role eq 'ca' || $role eq 'aa'); + next if (%roles && !exists($roles{$role})); + my ($starttime,$endtime)=split(/\./,$env{$key}); + my $active=1; + if ($starttime) { + if ($now<$starttime) { $active=0; } + } + if ($endtime) { + if ($now>$endtime) { $active=0; } + } + if ($active) { + if ($sec eq '') { + $sec = 'none'; + } + $courses{$cdom.'_'.$cnum}{$sec} = + $role.'/'.$cdom.'/'.$cnum.'/'.$sec; + } } - if ($active) { $courses{$1.'_'.$2}=1; } } } - return keys %courses; + return %courses; } ############################################### + +sub blockcheck { + my ($setters,$activity,$uname,$udom) = @_; + # Retrieve active course roles - course coordinator, instructor, exam proctor, ta, student or custom role. + + my %live_courses = &findallcourses(undef,$uname,$udom); + + # Retrieve blocking times and identity of blocker for active courses + # of specified user, unless user has 'evb' privilege. + + my $startblock = 0; + my $endblock = 0; + + foreach my $course (keys(%live_courses)) { + my ($cdom,$cnum); + if ((defined($env{'course.'.$course.'.domain'})) && (defined($env{'course.'.$course.'.num'}))) { + $cdom = $env{'course.'.$course.'.domain'}; + $cnum = $env{'course.'.$course.'.num'}; + } else { + ($cdom,$cnum) = split(/_/,$course); + } + my $no_ownblock = 0; + my $no_userblock = 0; + foreach my $sec (keys(%{$live_courses{$course}})) { + my $checkrole = 'cm./'.$cdom.'/'.$cnum; + if ($sec ne 'none') { + $checkrole .= '/'.$sec; + } + if ((defined($uname) && ($uname ne $env{'user.name'})) || + (defined($udom) && ($udom ne $env{'user.domain'}))) { + my ($trole,$tdom,$tnum,$tsec); + my $entry = $live_courses{$course}{$sec}; + if ($entry =~ /^cr/) { + ($trole,$tdom,$tnum,$tsec) = + ($entry =~ m|^(cr/$match_domain/$match_username/\w+)\./($match_domain)/($match_username)/?(\w*)$|); + } else { + ($trole,$tdom,$tnum,$tsec) = split(/\//,$entry); + } + my ($spec,$area,$trest,%allroles,%userroles); + $area = '/'.$tdom.'/'.$tnum; + $trest = $tnum; + if ($tsec ne '') { + $area .= '/'.$tsec; + $trest .= '/'.$tsec; + } + $spec = $trole.'.'.$area; + if ($trole =~ /^cr/) { + &Apache::lonnet::custom_roleprivs(\%allroles,$trole, + $tdom,$spec,$trest,$area); + } else { + &Apache::lonnet::standard_roleprivs(\%allroles,$trole, + $tdom,$spec,$trest,$area); + } + my ($author,$adv) = &Apache::lonnet::set_userprivs(\%userroles,\%allroles); + if ($userroles{'user.priv.'.$checkrole} =~ /evb\&([^\:]*)/) { + if ($1) { + $no_userblock = 1; + last; + } + } + } else { + if (&Apache::lonnet::allowed('evb',undef,undef,$checkrole)) { + $no_ownblock = 1; + last; + } + } + } + # if they have the evb priv and are currently not playing student + next if (($no_ownblock) && + ($env{'request.role'} !~ m{^st\./$cdom/$cnum})); + next if ($no_userblock); + + $setters->{$course} = {}; + $setters->{$course}{'staff'} = []; + $setters->{$course}{'times'} = []; + my %records = &Apache::lonnet::dump('comm_block',$cdom,$cnum); + foreach my $record (keys(%records)) { + my ($start,$end) = ($record =~ m/^(\d+)____(\d+)$/); + if ($start <= time && $end >= time) { + my ($staff_name,$staff_dom,$title,$blocks) = + &parse_block_record($records{$record}); + if ($blocks->{$activity} eq 'on') { + push(@{$$setters{$course}{'staff'}}, [$staff_name,$staff_dom]); push(@{$$setters{$course}{'times'}}, [$start,$end]); + if ( ($startblock == 0) || ($startblock > $1) ) { + $startblock = $1; + } + if ( ($endblock == 0) || ($endblock < $2) ) { + $endblock = $2; + } + } + } + } + } + return ($startblock,$endblock); +} + +sub parse_block_record { + my ($record) = @_; + my ($setuname,$setudom,$title,$blocks); + if (ref($record) eq 'HASH') { + ($setuname,$setudom) = split(/:/,$record->{'setter'}); + $title = &unescape($record->{'event'}); + $blocks = $record->{'blocks'}; + } else { + my @data = split(/:/,$record,3); + if (scalar(@data) eq 2) { + $title = $data[1]; + ($setuname,$setudom) = split(/@/,$data[0]); + } else { + ($setuname,$setudom,$title) = @data; + } + $blocks = { 'com' => 'on' }; + } + return ($setuname,$setudom,$title,$blocks); +} + +sub build_block_table { + my ($startblock,$endblock,$setters) = @_; + my %lt = &Apache::lonlocal::texthash( + 'cacb' => 'Currently active communication blocks', + 'cour' => 'Course', + 'dura' => 'Duration', + 'blse' => 'Block set by' + ); + my $output; + $output = '
'.$lt{'cacb'}.':
'; + $output .= &start_data_table(); + $output .= ' + + '.$lt{'cour'}.' + '.$lt{'dura'}.' + '.$lt{'blse'}.' + +'; + foreach my $course (keys(%{$setters})) { + my %courseinfo=&Apache::lonnet::coursedescription($course); + for (my $i=0; $i<@{$$setters{$course}{staff}}; $i++) { + my ($uname,$udom) = @{$$setters{$course}{staff}[$i]}; + my $fullname = &aboutmewrapper(&plainname($uname,$udom),$uname,$udom); + my ($openblock,$closeblock) = @{$$setters{$course}{times}[$i]}; + $openblock = &Apache::lonlocal::locallocaltime($openblock); + $closeblock= &Apache::lonlocal::locallocaltime($closeblock); + $output .= &Apache::loncommon::start_data_table_row(). + ''.$courseinfo{'description'}.''. + ''.$openblock.' to '.$closeblock.''. + ''.$fullname.'.'. + &Apache::loncommon::end_data_table_row(); + } + } + $output .= &end_data_table(); +} + ############################################### =pod @@ -2679,6 +3100,7 @@ Returns: value of designparamter $which =cut + ############################################## sub designparm { my ($which,$domain)=@_; @@ -2693,11 +3115,11 @@ sub designparm { return '#CCCCCC'; } } - if ($env{'environment.color.'.$which}) { + if (exists($env{'environment.color.'.$which})) { return $env{'environment.color.'.$which}; } $domain=&determinedomain($domain); - if ($designhash{$domain.'.'.$which}) { + if (exists($designhash{$domain.'.'.$which})) { return $designhash{$domain.'.'.$which}; } else { return $designhash{'default.'.$which}; @@ -2743,7 +3165,15 @@ Inputs: =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 +=item * $bgcolor, used to override the bgcolor on a webpage to a specific value + +=item * $notitle, if true keep the nav controls, but remove the title bar + +=item * $no_inline_link, if true and in remote mode, don't show the + 'Switch To Inline Menu' link + +=item * $args, optional argument valid values are + no_auto_mt_title -> prevents &mt()ing the title arg =back @@ -2756,130 +3186,153 @@ other decorations will be returned. sub bodytag { my ($title,$function,$addentries,$bodyonly,$domain,$forcereg,$customtitle, - $notopbar,$bgcolor)=@_; - $title=&mt($title); + $notopbar,$bgcolor,$notitle,$no_inline_link,$args)=@_; + + if (!$args->{'no_auto_mt_title'}) { $title = &mt($title); } + $function = &get_users_function() if (!$function); - my $img=&designparm($function.'.img',$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); - my $alink=&designparm($function.'.alink',$domain); - my $vlink=&designparm($function.'.vlink',$domain); - my $sidebg=&designparm($function.'.sidebg',$domain); -# Accessibility font enhance - my $addstyle=''; - if ($env{'browser.fontenhance'} eq 'on') { - $addstyle=' font-size: x-large;'; - } + my $img = &designparm($function.'.img',$domain); + my $font = &designparm($function.'.font',$domain); + my $pgbg = $bgcolor || &designparm($function.'.pgbg',$domain); + + my %design = ( 'style' => 'margin-top: 0px', + 'bgcolor' => $pgbg, + 'text' => $font, + 'alink' => &designparm($function.'.alink',$domain), + 'vlink' => &designparm($function.'.vlink',$domain), + 'link' => &designparm($function.'.link',$domain),); + @design{keys(%$addentries)} = @$addentries{keys(%$addentries)}; + # role and realm - my ($role,$realm) - =&Apache::lonnet::plaintext((split(/\./,$env{'request.role'}))[0]); + my ($role,$realm) = split(/\./,$env{'request.role'},2); + if ($role eq 'ca') { + my ($rdom,$rname) = ($realm =~ m{^/($match_domain)/($match_username)$}); + $realm = &plainname($rname,$rdom).':'.$rdom; + } # realm if ($env{'request.course.id'}) { - $realm= - $env{'course.'.$env{'request.course.id'}.'.description'}; + if ($env{'request.role'} !~ /^cr/) { + $role = &Apache::lonnet::plaintext($role,&course_type()); + } + $realm = $env{'course.'.$env{'request.course.id'}.'.description'}; + } else { + $role = &Apache::lonnet::plaintext($role); } - unless ($realm) { $realm=' '; } + + if (!$realm) { $realm=' '; } # Set messages my $messages=&domainlogo($domain); # Port for miniserver my $lonhttpdPort=$Apache::lonnet::perlvar{'lonhttpdPort'}; if (!defined($lonhttpdPort)) { $lonhttpdPort='8080'; } - my $extra_body_attr = &make_attr_string($forcereg,$addentries); + my $extra_body_attr = &make_attr_string($forcereg,\%design); # construct main body tag - my $bodytag = < -h1, h2, h3, th { font-family: Arial, Helvetica, sans-serif } -a:focus { color: red; background: yellow } -table.thinborder { border-collapse: collapse; } -table.thinborder tr th, table.thinborder tr td { border-style: solid; border-width: 1px} -form, .inline { display: inline; } -.center { text-align: center; } -.filename {font-family: monospace;} - - -END + my $bodytag = "". + &Apache::lontexconvert::init_math_support(); - $bodytag .= &Apache::lontexconvert::init_math_support(); - - my $upperleft=''.$function.''; - if ($bodyonly) { + if ($bodyonly + || ($env{'request.state'} eq 'construct' + && $env{'environment.remote'} ne 'off' )) { return $bodytag; } elsif ($env{'browser.interface'} eq 'textual') { # Accessibility - return $bodytag.&Apache::lonmenu::menubuttons($forcereg,'web', - $forcereg). - '

LON-CAPA: '.$title.'

'; - } elsif ($env{'environment.remote'} eq 'off') { -# No Remote - my $roleinfo=(< - - $env{'environment.firstname'} - $env{'environment.middlename'} - $env{'environment.lastname'} - $env{'environment.generation'} -   -
-$role  -
-$realm  + $bodytag.=&Apache::lonmenu::menubuttons($forcereg,$forcereg); + if (!$notitle) { + $bodytag.='

LON-CAPA: '.$title.'

'; + } + return $bodytag; + } + + my $name = &plainname($env{'user.name'},$env{'user.domain'}); + if ($env{'user.name'} eq 'public' && $env{'user.domain'} eq 'public') { + undef($role); + } else { + $name = &aboutmewrapper($name,$env{'user.name'},$env{'user.domain'}); + } + + my $roleinfo=(< +
+ $name +   +
+
+$role  +
+
+$realm  +
ENDROLE - my $titleinfo = ''.$title.''; - if ($customtitle) { - $titleinfo = $customtitle; - } + 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 =~ s/\s+$//; + $dc_info = '('.$dc_info.')'; + } + + if ($env{'environment.remote'} eq 'off') { + # No Remote if ($env{'request.state'} eq 'construct') { + $forcereg=1; + } + + if (!$customtitle && $env{'request.state'} eq 'construct') { + # this is for resources; directories have customtitle, and crumbs + # and select recent are created in lonpubdir.pm 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); - } + 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(); + } + + my $titletable; + if (!$notitle) { + $titletable = + ''. + "".$roleinfo. + '
$titleinfo $dc_info
'; + } + if ($notopbar) { + $bodytag .= $titletable; } else { - if ($notopbar) { - $bodytag .= $titletable; + if ($env{'request.state'} eq 'construct') { + $bodytag .= &Apache::lonmenu::menubuttons($forcereg,$forcereg, + $titletable); } else { - $bodytag .= &Apache::lonmenu::menubuttons($forcereg,'web',$forcereg). - $titletable; + $bodytag .= &Apache::lonmenu::menubuttons($forcereg,$forcereg). + $titletable; } } return $bodytag; @@ -2888,48 +3341,27 @@ ENDROLE # # 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.')'; - } + + my $upperleft=''.$function.''; + # Explicit link to get inline menu - my $menu='
 '.&mt('Switch to Inline Menu Mode').''; + my $menu= ($no_inline_link?'' + :'
'.&mt('Switch to Inline Menu Mode').''); # + if ($notitle) { + return $bodytag; + } return(< - -$upperleft -$messages  + + + - - + +$roleinfo - - - -
-$titleinfo $dc_info $menu - - - $env{'environment.firstname'} - $env{'environment.middlename'} - $env{'environment.lastname'} - $env{'environment.generation'} -   -
$titleinfo $dc_info $menu
-$role  -
$realm 

+ ENDBODY } @@ -2943,11 +3375,44 @@ sub make_attr_string { } if ($register) { - $attr_ref->{'onload'} = &Apache::lonmenu::loadevents(). - $attr_ref->{'onload'}; - $attr_ref->{'onunload'} = &Apache::lonmenu::unloadevents(). - $attr_ref->{'onunload'}; + my ($on_load,$on_unload); + foreach my $key (keys(%{$attr_ref})) { + if (lc($key) eq 'onload') { + $on_load.=$attr_ref->{$key}.';'; + delete($attr_ref->{$key}); + + } elsif (lc($key) eq 'onunload') { + $on_unload.=$attr_ref->{$key}.';'; + delete($attr_ref->{$key}); + } + } + $attr_ref->{'onload'} = + &Apache::lonmenu::loadevents(). $on_load; + $attr_ref->{'onunload'}= + &Apache::lonmenu::unloadevents().$on_unload; } + +# Accessibility font enhance + if ($env{'browser.fontenhance'} eq 'on') { + my $style; + foreach my $key (keys(%{$attr_ref})) { + if (lc($key) eq 'style') { + $style.=$attr_ref->{$key}.';'; + delete($attr_ref->{$key}); + } + } + $attr_ref->{'style'}=$style.'; font-size: x-large;'; + } + + if ($env{'browser.blackwhite'} eq 'on') { + delete($attr_ref->{'font'}); + delete($attr_ref->{'link'}); + delete($attr_ref->{'alink'}); + delete($attr_ref->{'vlink'}); + delete($attr_ref->{'bgcolor'}); + delete($attr_ref->{'background'}); + } + my $attr_string; foreach my $attr (keys(%$attr_ref)) { $attr_string .= " $attr=\"".$attr_ref->{$attr}.'" '; @@ -2993,6 +3458,598 @@ sub endbodytag { =over 4 +=item * &standard_css() + +Returns a style sheet + +Inputs: (all optional) + domain -> force to color decorate a page for a specific + domain + function -> force usage of a specific rolish color scheme + bgcolor -> override the default page bgcolor + +=back + +=cut + +sub standard_css { + my ($function,$domain,$bgcolor) = @_; + $function = &get_users_function() if (!$function); + my $img = &designparm($function.'.img', $domain); + my $tabbg = &designparm($function.'.tabbg', $domain); + my $font = &designparm($function.'.font', $domain); + my $sidebg = &designparm($function.'.sidebg',$domain); + my $pgbg_or_bgcolor = + $bgcolor || + &designparm($function.'.pgbg', $domain); + my $pgbg = &designparm($function.'.pgbg', $domain); + my $alink = &designparm($function.'.alink', $domain); + my $vlink = &designparm($function.'.vlink', $domain); + my $link = &designparm($function.'.link', $domain); + + my $sans = 'Arial,Helvetica,sans-serif'; + my $mono = 'monospace'; + my $data_table_head = $tabbg; + my $data_table_light = '#EEEEEE'; + my $data_table_dark = '#DDDDDD'; + my $data_table_darker = '#CCCCCC'; + my $data_table_highlight = '#FFFF00'; + my $mail_new = '#FFBB77'; + my $mail_new_hover = '#DD9955'; + my $mail_read = '#BBBB77'; + my $mail_read_hover = '#999944'; + my $mail_replied = '#AAAA88'; + my $mail_replied_hover = '#888855'; + my $mail_other = '#99BBBB'; + my $mail_other_hover = '#669999'; + my $table_header = '#DDDDDD'; + my $feedback_link_bg = '#BBBBBB'; + + my $border = ($env{'browser.type'} eq 'explorer') ? '0px 2px 0px 2px' + : '0px 3px 0px 4px'; + + return < array ref of + 1- seconds before redirect occurs + 2- url to redirect to + 3- whether the side effect should occur (side effect of setting $env{'internal.head.redirect'} to the url redirected too) + domain -> force to color decorate a page for a specific + domain + function -> force usage of a specific rolish color scheme + bgcolor -> override the default page bgcolor + no_auto_mt_title + -> prevent &mt()ing the title arg + =back =cut @@ -3015,29 +4080,51 @@ Inputs: $title - optional title for the sub headtag { my ($title,$head_extra,$args) = @_; + my $function = $args->{'function'} || &get_users_function(); + my $domain = $args->{'domain'} || &determinedomain(); + my $bgcolor = $args->{'bgcolor'} || &designparm($function.'.pgbg',$domain); + my $url = join(':',$env{'user.name'},$env{'user.domain'}, + $Apache::lonnet::perlvar{'lonVersion'}, + #time(), + $env{'environment.color.timestamp'}, + $function,$domain,$bgcolor); + + $url = '/adm/css/'.&escape($url).'.css'; + my $result = ''. - &Apache::lonxml::fontsettings(). - &Apache::lonhtmlcommon::htmlareaheaders(); + &font_settings(); + if (!$args->{'frameset'}) { + $result .= &Apache::lonhtmlcommon::htmlareaheaders(); + } if ($args->{'force_register'}) { $result .= &Apache::lonmenu::registerurl(1); } + if (!$args->{'no_nav_bar'} + && !$args->{'only_body'} + && !$args->{'frameset'}) { + $result .= &help_menu_js(); + } if (ref($args->{'redirect'})) { - my ($time,$url) = @{$args->{'redirect'}}; + my ($time,$url,$inhibit_continue) = @{$args->{'redirect'}}; $url = &Apache::lonenc::check_encrypt($url); - $env{'internal.head.redirect'} = $url; + if (!$inhibit_continue) { + $env{'internal.head.redirect'} = $url; + } $result.=< - + ADDMETA } if (!defined($title)) { $title = 'The LearningOnline Network with CAPA'; } - - $result .= ' LON-CAPA '.&mt($title).''.$head_extra; + if (!$args->{'no_auto_mt_title'}) { $title = &mt($title); } + $result .= ' LON-CAPA '.$title.'' + .'' + .$head_extra; return $result; } @@ -3045,6 +4132,66 @@ ADDMETA =over 4 +=item * &font_settings() + +Returns neccessary to set the proper encoding + +Inputs: none + +=back + +=cut + +sub font_settings { + my $headerstring=''; + if (($env{'browser.os'} eq 'mac') && (!$env{'browser.mathml'})) { + $headerstring.= + ''; + } elsif (!$env{'browser.mathml'} && $env{'browser.unicode'}) { + $headerstring.= + ''; + } + return $headerstring; +} + +=pod + +=over 4 + +=item * &xml_begin() + +Returns the needed doctype and + +Inputs: none + +=back + +=cut + +sub xml_begin { + my $output=''; + + &Apache::lonhtmlcommon::init_htmlareafields(); + + if ($env{'browser.mathml'}) { + $output='' + #.''."\n" +# .'] >' + .'' + .''; + } else { + $output=''; + } + return $output; +} + +=pod + +=over 4 + =item * &endheadtag() Returns a uniform for LON-CAPA web pages. @@ -3069,6 +4216,7 @@ Returns a uniform complete .. + =back =cut @@ -3110,6 +4258,16 @@ Inputs: $title - optional title for the is not auto translated like the $title is frameset -> if true will start with a rather than + no_title -> if true the title bar won't be shown + skip_phases -> hash ref of + head -> skip the generation + body -> skip all generation + + no_inline_link -> if true and in remote mode, don't show the + 'Switch To Inline Menu' link + + no_auto_mt_title -> prevent &mt()ing the title arg + =back =cut @@ -3118,28 +4276,39 @@ sub start_page { my ($title,$head_extra,$args) = @_; #&Apache::lonnet::logthis("start_page ".join(':',caller(0))); my %head_args; - foreach my $arg ('redirect','force_register') { + foreach my $arg ('redirect','force_register','domain','function', + 'bgcolor','frameset','no_nav_bar','only_body', + 'no_auto_mt_title') { if (defined($args->{$arg})) { $head_args{$arg} = $args->{$arg}; } } $env{'internal.start_page'}++; - my $result = - &Apache::lonxml::xmlbegin(). - &headtag($title,$head_extra,\%head_args).&endheadtag(); - if ($args->{'frameset'}) { - my $attr_string = &make_attr_string($args->{'force_register'}, - $args->{'add_entries'}); - $result .= "\n\n"; - } else { - $result .= - &bodytag($title, - $args->{'function'}, $args->{'add_entries'}, - $args->{'only_body'}, $args->{'domain'}, - $args->{'force_register'}, $args->{'body_title'}, - $args->{'no_nav_bar'}, $args->{'bgcolor'}); + my $result; + if (! exists($args->{'skip_phases'}{'head'}) ) { + $result.= + &xml_begin(). + &headtag($title,$head_extra,\%head_args).&endheadtag(); } + + if (! exists($args->{'skip_phases'}{'body'}) ) { + if ($args->{'frameset'}) { + my $attr_string = &make_attr_string($args->{'force_register'}, + $args->{'add_entries'}); + $result .= "\n\n"; + } else { + $result .= + &bodytag($title, + $args->{'function'}, $args->{'add_entries'}, + $args->{'only_body'}, $args->{'domain'}, + $args->{'force_register'}, $args->{'body_title'}, + $args->{'no_nav_bar'}, $args->{'bgcolor'}, + $args->{'no_title'}, $args->{'no_inline_link'}, + $args); + } + } + if ($args->{'js_ready'}) { $result = &js_ready($result); } @@ -3165,15 +4334,22 @@ Inputs: $args - additional optio a html attribute frameset -> if true will start with a rather than -=back =cut sub end_page { my ($args) = @_; - #&Apache::lonnet::logthis("end_page ".join(':',caller(0))); $env{'internal.end_page'}++; my $result; + if ($args->{'discussion'}) { + my ($target,$parser); + if (ref($args->{'discussion'})) { + ($target,$parser) =($args->{'discussion'}{'target'}, + $args->{'discussion'}{'parser'}); + } + $result .= &Apache::lonxml::xmlend($target,$parser); + } + if ($args->{'frameset'}) { $result .= ''; } else { @@ -3184,9 +4360,11 @@ sub end_page { if ($args->{'js_ready'}) { $result = &js_ready($result); } + if ($args->{'html_encode'}) { $result = &html_encode($result); } + return $result; } @@ -3203,7 +4381,7 @@ sub js_ready { $result =~ s/[\n\r]/ /xmsg; $result =~ s/\\/\\\\/xmsg; $result =~ s/'/\\'/xmsg; - $result =~ s{}{}xmsg; + $result =~ s{'."\n"; + } + + sub end_data_table { + undef($row_count); + return ''."\n";; + } + + sub start_data_table_row { + my ($add_class) = @_; + $row_count++; + my $css_class = ($row_count % 2)?'':'LC_even_row'; + $css_class = (join(' ',$css_class,$add_class)); + return ''."\n";; + } + + sub continue_data_table_row { + my ($add_class) = @_; + my $css_class = ($row_count % 2)?'':'LC_even_row'; + $css_class = (join(' ',$css_class,$add_class)); + return ''."\n";; + } + + sub end_data_table_row { + return ''."\n";; + } + + sub start_data_table_empty_row { + $row_count++; + return ''."\n";; + } + + sub end_data_table_empty_row { + return ''."\n";; + } + + sub start_data_table_header_row { + return ''."\n";; + } + + sub end_data_table_header_row { + return ''."\n";; + } +} + ############################################### =pod -=over 4 - -=item get_users_function +=item * &get_users_function() Used by &bodytag to determine the current users primary role. Returns either 'student','coordinator','admin', or 'author'. @@ -3278,14 +4506,14 @@ sub get_users_function { =pod -=item check_user_status +=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. +course's number, optional section ID. Outputs: role status: active, previous or future. @@ -3293,33 +4521,35 @@ role status: active, previous or future. =cut sub check_user_status { - my ($udom,$uname,$cdom,$crs,$role,$secgrp) = @_; + my ($udom,$uname,$cdom,$crs,$role,$sec) = @_; my %userinfo = &Apache::lonnet::dump('roles',$udom,$uname); my @uroles = keys %userinfo; my $srchstr; my $active_chk = 'none'; + my $now = time; if (@uroles > 0) { - if (($role eq 'cc') || ($secgrp eq '') || (!defined($secgrp))) { + if (($role eq 'cc') || ($sec eq '') || (!defined($sec))) { $srchstr = '/'.$cdom.'/'.$crs.'_'.$role; } else { - $srchstr = '/'.$cdom.'/'.$crs.'/'.$secgrp.'_'.$role; } - if (grep/^$srchstr$/,@uroles) { + $srchstr = '/'.$cdom.'/'.$crs.'/'.$sec.'_'.$role; + } + if (grep/^\Q$srchstr\E$/,@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 ($userinfo{$srchstr} =~ m/^\Q$role\E_(\d+)/) { + $role_end = $1; + if ($userinfo{$srchstr} =~ m/^\Q$role\E_\Q$role_end\E_(\d+)$/) { + $role_start = $1; } } if ($role_start > 0) { - if (time < $role_start) { + if ($now < $role_start) { $active_chk = 'future'; } } if ($role_end > 0) { - if (time > $role_end) { + if ($now > $role_end) { $active_chk = 'previous'; } } @@ -3332,36 +4562,68 @@ sub check_user_status { =pod -=item get_sections +=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. +Incoming parameters: + +1. domain +2. course number +3. reference to array containing roles for which sections should +be gathered (optional). +4. reference to array containing status types for which sections +should be gathered (optional). + +If the third argument is undefined, sections are gathered for any role. +If the fourth argument is undefined, sections are gathered for any status. +Permissible values are 'active' or 'future' or 'previous'. -Returns number of sections. +Returns section hash (keys are section IDs, values are +number of users in each section), subject to the +optional roles filter, optional status filter =cut ############################################### sub get_sections { - my ($cdom,$cnum,$sectioncount,$possible_roles) = @_; - if (!($cdom && $cnum)) { return 0; } - my $numsections = 0; + my ($cdom,$cnum,$possible_roles,$possible_status) = @_; + if (!defined($cdom) || !defined($cnum)) { + my $cid = $env{'request.course.id'}; - if (!defined($possible_roles) || (grep/^st$/,@$possible_roles)) { + return if (!defined($cid)); + + $cdom = $env{'course.'.$cid.'.domain'}; + $cnum = $env{'course.'.$cid.'.num'}; + } + + my %sectioncount; + my $now = time; + + 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 $start_index = &Apache::loncoursedata::CL_START(); + my $end_index = &Apache::loncoursedata::CL_END(); + my $status; + while (my ($student,$data) = each(%$classlist)) { + my ($section,$stu_status,$start,$end) = ($data->[$sec_index], + $data->[$status_index], + $data->[$start_index], + $data->[$end_index]); + if ($stu_status eq 'Active') { + $status = 'active'; + } elsif ($end < $now) { + $status = 'previous'; + } elsif ($start > $now) { + $status = 'future'; + } + if ($section ne '-1' && $section !~ /^\s*$/) { + if ((!defined($possible_status)) || (($status ne '') && + (grep/^\Q$status\E$/,@{$possible_status}))) { + $sectioncount{$section}++; + } } } } @@ -3370,172 +4632,41 @@ sub get_sections { if ($user !~ /^(\w{2})/) { next; } my ($role) = ($user =~ /^(\w{2})/); if ($possible_roles && !(grep(/^$role$/,@$possible_roles))) { next; } - my $section; + my ($section,$status); 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); + my ($end,$start) = ($courseroles{$user} =~ /^([^:]*):([^:]*)$/); + if ($end == -1 && $start == -1) { + next; #deleted role } - $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; - } + if (!defined($possible_status)) { + $sectioncount{$section}++; + } else { + if ((!$end || $end >= $now) && (!$start || $start <= $now)) { + $status = 'active'; + } elsif ($end < $now) { + $status = 'future'; + } elsif ($start > $now) { + $status = 'previous'; } - } elsif ($token->[0] eq 'E') { - if ($token->[1] eq 'functions' || $token->[1] eq 'autosec') { - $tool = ''; - } elsif ($token->[1] eq 'role') { - $role = ''; + if (($status ne '') && (grep/^\Q$status\E$/,@{$possible_status})) { + $sectioncount{$section}++; } - } } - 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; + return %sectioncount; } ############################################### =pod - -=item get_course_users - + +=item * &get_course_users() + Retrieves usernames:domains for users in the specified course with specific role(s), and access status. @@ -3558,12 +4689,13 @@ Entries for end, start, section and stat 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 = (); + my %seclists; $idx{udom} = &Apache::loncoursedata::CL_SDOM(); $idx{uname} = &Apache::loncoursedata::CL_SNAME(); @@ -3579,12 +4711,28 @@ sub get_course_users { my $now = time; foreach my $student (keys(%{$classlist})) { my $match = 0; + my $secmatch = 0; + my $section = $$classlist{$student}[$idx{section}]; + if ($section eq '') { + $section = 'none'; + } if ((ref($sections) eq 'ARRAY') && (@{$sections} > 0)) { - unless(grep(/^\Q$$classlist{$student}[$idx{section}]\E$/, - @{$sections})) { - next; + if (grep(/^all$/,@{$sections})) { + $secmatch = 1; + } elsif ($$classlist{$student}[$idx{section}] eq '') { + if (grep(/^none$/,@{$sections})) { + $secmatch = 1; + } + } else { + if (grep(/^\Q$section\E$/,@{$sections})) { + $secmatch = 1; + } } - } + if (!$secmatch) { + next; + } + } + push(@{$seclists{$student}},$section); if (defined($$types{'active'})) { if ($$classlist{$student}[$idx{status}] eq 'Active') { push(@{$$users{st}{$student}},'active'); @@ -3603,36 +4751,69 @@ sub get_course_users { $match = 1; } } - if ($match && defined($userdata)) { + if ($match && ref($userdata) eq 'HASH') { $$userdata{$student} = $$classlist{$student}; } } } - if ((@{$roles} > 0) && (@{$roles} ne "st")) { - my @coursepersonnel = &Apache::lonnet::getkeys('nohist_userroles',$cdom,$cnum); - foreach my $person (@coursepersonnel) { + if ((@{$roles} > 1) || ((@{$roles} == 1) && ($$roles[0] ne "st"))) { + my %coursepersonnel = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum); + my $now = time; + foreach my $person (sort(keys(%coursepersonnel))) { my $match = 0; - my ($role,$user) = ($person =~ /^([^:]*):([^:]+:[^:]+)/); + my $secmatch = 0; + my $status; + my ($role,$user,$usec) = ($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; - } + my ($end,$start) = split(/:/,$coursepersonnel{$person}); + if ($end == -1 || $start == -1) { + next; + } + if (($role) && ((grep(/^\Q$role\E$/,@{$roles})) || + (grep(/^cr$/,@{$roles}) && $role =~ /^cr\//))) { + my ($uname,$udom) = split(/:/,$user); + if ((ref($sections) eq 'ARRAY') && (@{$sections} > 0)) { + if (grep(/^all$/,@{$sections})) { + $secmatch = 1; + } elsif ($usec eq '') { + if (grep(/^none$/,@{$sections})) { + $secmatch = 1; + } + } else { + if (grep(/^\Q$usec\E$/,@{$sections})) { + $secmatch = 1; + } + } + if (!$secmatch) { + next; + } + } + if ($usec eq '') { + $usec = 'none'; } if ($uname ne '' && $udom ne '') { - my $status = &check_user_status($udom,$uname,$cdom,$cnum,$role); + if ($end < $now) { + $status = 'previous'; + } elsif ($start > $now) { + $status = 'future'; + } else { + $status = 'active'; + } foreach my $type (keys(%{$types})) { if ($status eq $type) { - @{$$users{$role}{$user}} = $type; + if (!grep(/^\Q$type\E$/,@{$$users{$role}{$user}})) { + push(@{$$users{$role}{$user}},$type); + } $match = 1; } } - if ($match && defined($userdata) && - !exists($$userdata{$uname.':'.$udom})) { - &get_user_info($udom,$uname,\%idx,$userdata); + if (($match) && (ref($userdata) eq 'HASH')) { + if (!exists($$userdata{$uname.':'.$udom})) { + &get_user_info($udom,$uname,\%idx,$userdata); + } + if (!grep(/^\Q$usec\E$/,@{$seclists{$uname.':'.$udom}})) { + push(@{$seclists{$uname.':'.$udom}},$usec); + } } } } @@ -3642,14 +4823,24 @@ sub get_course_users { 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 ($owner !~ /^[^:]+:[^:]+$/) { + $owner = $owner.':'.$cdom; + } + @{$$users{'ow'}{$owner}} = 'any'; if (defined($userdata) && !exists($$userdata{$owner.':'.$cdom})) { &get_user_info($cdom,$owner,\%idx,$userdata); + if (!grep(/^none$/,@{$seclists{$owner.':'.$cdom}})) { + push(@{$seclists{$owner.':'.$cdom}},'none'); + } } } } } + foreach my $user (keys(%seclists)) { + @{$seclists{$user}} = (sort {$a <=> $b} @{$seclists{$user}}); + $$userdata{$user}[$idx{section}] = join(',',@{$seclists{$user}}); + } } return; } @@ -3665,88 +4856,129 @@ sub get_user_info { ############################################### -sub get_posted_cgi { - my $r=shift; +=pod - my $buffer; - 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; - foreach $pair (@pairs) { - my ($name,$value) = split(/=/,$pair); - $value =~ tr/+/ /; - $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; - $name =~ tr/+/ /; - $name =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg; - &add_to_env("form.$name",$value); - } +=item * &get_user_quota() + +Retrieves quota assigned for storage of portfolio files for a user + +Incoming parameters: +1. user's username +2. user's domain + +Returns: +1. Disk quota (in Mb) assigned to student. + +If a value has been stored in the user's environment, +it will return that, otherwise it returns the default +for users in the domain. + +=cut + +############################################### + + +sub get_user_quota { + my ($uname,$udom) = @_; + my $quota; + if (!defined($udom)) { + $udom = $env{'user.domain'}; + } + if (!defined($uname)) { + $uname = $env{'user.name'}; + } + if (($udom eq '' || $uname eq '') || + ($udom eq 'public') && ($uname eq 'public')) { + $quota = 0; } else { - my $contentsep=$1; - my @lines = split (/\n/,$buffer); - my $name=''; - my $value=''; - my $fname=''; - my $fmime=''; - my $i; - for ($i=0;$i<=$#lines;$i++) { - if ($lines[$i]=~/^$contentsep/) { - if ($name) { - chomp($value); - if ($fname) { - $env{"form.$name.filename"}=$fname; - $env{"form.$name.mimetype"}=$fmime; - } else { - $value=~s/\s+$//s; - } - &add_to_env("form.$name",$value); - } - if ($i<$#lines) { - $i++; - $lines[$i]=~ - /Content\-Disposition\:\s*form\-data\;\s*name\=\"([^\"]+)\"/i; - $name=$1; - $value=''; - if ($lines[$i]=~/filename\=\"([^\"]+)\"/i) { - $fname=$1; - if - ($lines[$i+1]=~/Content\-Type\:\s*([\w\-\/]+)/i) { - $fmime=$1; - $i++; - } else { - $fmime=''; - } - } else { - $fname=''; - $fmime=''; - } - $i++; - } - } else { - $value.=$lines[$i]."\n"; - } - } + if ($udom eq $env{'user.domain'} && $uname eq $env{'user.name'}) { + $quota = $env{'environment.portfolioquota'}; + } else { + my %userenv = &Apache::lonnet::dump('environment',$udom,$uname); + my ($tmp) = keys(%userenv); + if ($tmp !~ /^(con_lost|error|no_such_host)/i) { + $quota = $userenv{'portfolioquota'}; + } else { + undef(%userenv); + } + } + if ($quota eq '') { + $quota = &default_quota($udom); + } } -# -# Digested POSTed values -# -# Remember the way this was originally done (GET or POST) -# - $env{'request.method'}=$ENV{'REQUEST_METHOD'}; -# -# There may also be stuff in the query string -# Tell subsequent handlers that this was GET, not POST, so they can access query string. -# Also, unset POSTed content length to cover all tracks. -# + return $quota; +} + +############################################### + +=pod + +=item * &default_quota() + +Retrieves default quota assigned for storage of user portfolio files + +Incoming parameters: +1. domain + +Returns: +1. Default disk quota (in Mb) for user portfolios in the domain. + +If a value has been stored in the domain's configuration db, +it will return that, otherwise it returns 20 (for backwards +compatibility with domains which have not set up a configuration +db file; the original statically defined portfolio quota was 20 Mb). + +=cut + +############################################### -# This does not work, because M_GET is not defined (if it's defined, it is just 0). -# Commenting out for now ... not sure if harm is done. -# $r->method_number(M_GET); - $r->method('GET'); - $r->headers_in->unset('Content-length'); +sub default_quota { + my ($udom) = @_; + my %defaults = &Apache::lonnet::get_dom('configuration', + ['portfolioquota'],$udom); + if ($defaults{'portfolioquota'} ne '') { + return $defaults{'portfolioquota'}; + } else { + return '20'; + } +} + +sub get_secgrprole_info { + my ($cdom,$cnum,$needroles,$type) = @_; + my %sections_count = &get_sections($cdom,$cnum); + my @sections = (sort {$a <=> $b} keys(%sections_count)); + my %curr_groups = &Apache::longroup::coursegroups($cdom,$cnum); + my @groups = sort(keys(%curr_groups)); + my $allroles = []; + my $rolehash; + my $accesshash = { + active => 'Currently has access', + future => 'Will have future access', + previous => 'Previously had access', + }; + if ($needroles) { + $rolehash = {'all' => 'all'}; + my %user_roles = &Apache::lonnet::dump('nohist_userroles',$cdom,$cnum); + if (&Apache::lonnet::error(%user_roles)) { + undef(%user_roles); + } + foreach my $item (keys(%user_roles)) { + my ($role)=split(/\:/,$item,2); + if ($role eq 'cr') { next; } + if ($role =~ /^cr/) { + $$rolehash{$role} = (split('/',$role))[3]; + } else { + $$rolehash{$role} = &Apache::lonnet::plaintext($role,$type); + } + } + foreach my $key (sort(keys(%{$rolehash}))) { + push(@{$allroles},$key); + } + push (@{$allroles},'st'); + $$rolehash{'st'} = &Apache::lonnet::plaintext('st',$type); + } + return (\@sections,\@groups,$allroles,$rolehash,$accesshash); } =pod @@ -3767,9 +4999,9 @@ will result in $env{'form.uname'} and $e sub get_unprocessed_cgi { my ($query,$possible_names)= @_; # $Apache::lonxml::debug=1; - foreach (split(/&/,$query)) { - my ($name, $value) = split(/=/,$_); - $name = &Apache::lonnet::unescape($name); + foreach my $pair (split(/&/,$query)) { + my ($name, $value) = split(/=/,$pair); + $name = &unescape($name); 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; @@ -3886,7 +5118,7 @@ sub get_env_multiple { =pod -=back +=back =head1 CSV Upload/Handling functions @@ -3985,8 +5217,7 @@ sub record_sep { if ($env{'form.upfiletype'} eq 'xml') { } elsif ($env{'form.upfiletype'} eq 'space') { my $i=0; - foreach (split(/\s+/,$record)) { - my $field=$_; + foreach my $field (split(/\s+/,$record)) { $field=~s/^(\"|\')//; $field=~s/(\"|\')$//; $components{&takeleft($i)}=$field; @@ -3994,15 +5225,19 @@ sub record_sep { } } elsif ($env{'form.upfiletype'} eq 'tab') { my $i=0; - foreach (split(/\t/,$record)) { - my $field=$_; + foreach my $field (split(/\t/,$record)) { $field=~s/^(\"|\')//; $field=~s/(\"|\')$//; $components{&takeleft($i)}=$field; $i++; } } else { - my @allfields=split(/\,/,$record); + my @allfields; + if ($env{'form.upfiletype'} eq 'semisv') { + @allfields=split(/;/,$record); + } else { + @allfields=split(/\,/,$record); + } my $i=0; my $j; for ($j=0;$j<=$#allfields;$j++) { @@ -4040,6 +5275,7 @@ the file type. sub upfile_select_html { my %Types = ( csv => &mt('CSV (comma separated values, spreadsheet)'), + semisv => &mt('Semicolon separated values'), space => &mt('Space separated'), tab => &mt('Tabulator separated'), # xml => &mt('HTML/XML'), @@ -4089,14 +5325,14 @@ sub csv_print_samples { my $samples = &get_samples($records,3); $r->print(&mt('Samples').'
'); - foreach (sort({$a <=> $b} keys(%{ $samples->[0] }))) { - $r->print(''); } + foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) { + $r->print(''); } $r->print(''); foreach my $hash (@$samples) { $r->print(''); - foreach (sort({$a <=> $b} keys(%{ $samples->[0] }))) { + foreach my $sample (sort({$a <=> $b} keys(%{ $samples->[0] }))) { $r->print(''); } $r->print(''); @@ -4129,17 +5365,17 @@ sub csv_print_select_table { '
'.&mt('Column [_1]',($_+1)).''.&mt('Column [_1]',($sample+1)).'
'); - if (defined($$hash{$_})) { $r->print($$hash{$_}); } + if (defined($$hash{$sample})) { $r->print($$hash{$sample}); } $r->print('
'. ''. ''."\n"); - foreach (@$d) { - my ($value,$display,$defaultcol)=@{ $_ }; + foreach my $array_ref (@$d) { + my ($value,$display,$defaultcol)=@{ $array_ref }; $r->print(''); $r->print(''."\n"); $i++; @@ -4400,9 +5636,9 @@ sub DrawBarGraph { $Title = '' if (! defined($Title)); $xlabel = '' if (! defined($xlabel)); $ylabel = '' if (! defined($ylabel)); - $ValuesHash{$id.'.title'} = &Apache::lonnet::escape($Title); - $ValuesHash{$id.'.xlabel'} = &Apache::lonnet::escape($xlabel); - $ValuesHash{$id.'.ylabel'} = &Apache::lonnet::escape($ylabel); + $ValuesHash{$id.'.title'} = &escape($Title); + $ValuesHash{$id.'.xlabel'} = &escape($xlabel); + $ValuesHash{$id.'.ylabel'} = &escape($ylabel); $ValuesHash{$id.'.y_max_value'} = $Max; $ValuesHash{$id.'.NumBars'} = $NumBars; $ValuesHash{$id.'.NumSets'} = $NumSets; @@ -4482,9 +5718,9 @@ sub DrawXYGraph { $ylabel = '' if (! defined($ylabel)); my %ValuesHash = ( - $id.'.title' => &Apache::lonnet::escape($Title), - $id.'.xlabel' => &Apache::lonnet::escape($xlabel), - $id.'.ylabel' => &Apache::lonnet::escape($ylabel), + $id.'.title' => &escape($Title), + $id.'.xlabel' => &escape($xlabel), + $id.'.ylabel' => &escape($ylabel), $id.'.y_max_value'=> $Max, $id.'.labels' => join(',',@$Xlabels), $id.'.PlotType' => 'XY', @@ -4579,9 +5815,9 @@ sub DrawXYYGraph { $ylabel = '' if (! defined($ylabel)); my %ValuesHash = ( - $id.'.title' => &Apache::lonnet::escape($Title), - $id.'.xlabel' => &Apache::lonnet::escape($xlabel), - $id.'.ylabel' => &Apache::lonnet::escape($ylabel), + $id.'.title' => &escape($Title), + $id.'.xlabel' => &escape($xlabel), + $id.'.ylabel' => &escape($ylabel), $id.'.labels' => join(',',@$Xlabels), $id.'.PlotType' => 'XY', $id.'.NumSets' => 2, @@ -4653,7 +5889,7 @@ Inputs: sub chartlink { my ($linktext, $sname, $sdomain) = @_; my $link = ''.$linktext.''; } @@ -4683,6 +5919,7 @@ a hash ref describing the data to be sto 'chartoutputmode' => 'scalar', 'chartoutputdata' => 'scalar', 'Section' => 'array', + 'Group' => 'array', 'StudentData' => 'array', 'Maps' => 'array'); @@ -4716,11 +5953,11 @@ sub store_course_settings { if (ref($env{'form.'.$setting})) { $stored_form = join(',', map { - &Apache::lonnet::escape($_); + &escape($_); } sort(@{$env{'form.'.$setting}})); } else { $stored_form = - &Apache::lonnet::escape($env{'form.'.$setting}); + &escape($env{'form.'.$setting}); } # Determine if the array contents are the same. if ($stored_form ne $env{$envname}) { @@ -4754,7 +5991,7 @@ sub restore_course_settings { } elsif ($type eq 'array') { $env{'form.'.$setting} = [ map { - &Apache::lonnet::unescape($_); + &unescape($_); } split(',',$env{$envname}) ]; } @@ -4765,15 +6002,399 @@ sub restore_course_settings { ############################################################ ############################################################ -sub propath { - my ($udom,$uname)=@_; - $udom=~s/\W//g; - $uname=~s/\W//g; - my $subdir=$uname.'__'; - $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/; - my $proname="$Apache::lonnet::perlvar{'lonUsersDir'}/$udom/$subdir/$uname"; - return $proname; -} +sub commit_customrole { + my ($udom,$uname,$url,$three,$four,$five,$start,$end) = @_; + my $output = &mt('Assigning custom role').' "'.$five.'" by '.$four.'@'.$three.' in '.$url. + ($start?', '.&mt('starting').' '.localtime($start):''). + ($end?', ending '.localtime($end):'').': '. + &Apache::lonnet::assigncustomrole( + $udom,$uname,$url,$three,$four,$five,$end,$start). + '
'; + return $output; +} + +sub commit_standardrole { + my ($udom,$uname,$url,$three,$start,$end,$one,$two,$sec) = @_; + my $output; + my $logmsg; + if ($three eq 'st') { + my $result = &commit_studentrole(\$logmsg,$udom,$uname,$url,$three,$start,$end,$one,$two,$sec); + if (($result =~ /^error/) || ($result eq 'not_in_class') || ($result eq 'unknown_course')) { + $output = "Error: $result\n"; + } else { + $output = &mt('Assigning').' '.$three.' in '.$url. + ($start?', '.&mt('starting').' '.localtime($start):''). + ($end?', '.&mt('ending').' '.localtime($end):''). + ': '.$result.'
'. + &mt('Add to classlist').': ok
'; + } + } else { + $output = &mt('Assigning').' '.$three.' in '.$url. + ($start?', '.&mt('starting').' '.localtime($start):''). + ($end?', '.&mt('ending').' '.localtime($end):'').': '. + &Apache::lonnet::assignrole( + $udom,$uname,$url,$three,$end,$start). + '
'; + } + return $output; +} + +sub commit_studentrole { + my ($logmsg,$udom,$uname,$url,$three,$start,$end,$one,$two,$sec) = @_; + my $linefeed = '
'."\n"; + my $result; + if (defined($one) && defined($two)) { + my $cid=$one.'_'.$two; + my $oldsec=&Apache::lonnet::getsection($udom,$uname,$cid); + my $secchange = 0; + my $expire_role_result; + my $modify_section_result; + unless ($oldsec eq '-1') { + unless ($sec eq $oldsec) { + $secchange = 1; + my $uurl='/'.$cid; + $uurl=~s/\_/\//g; + if ($oldsec) { + $uurl.='/'.$oldsec; + } + $expire_role_result = &Apache::lonnet::assignrole($udom,$uname,$uurl,'st',time); + $result = $expire_role_result; + } + } + if (($expire_role_result eq 'ok') || ($secchange == 0)) { + $modify_section_result = &Apache::lonnet::modify_student_enrollment($udom,$uname,undef,undef,undef,undef,undef,$sec,$end,$start,'','',$cid); + if ($modify_section_result =~ /^ok/) { + if ($secchange == 1) { + $$logmsg .= "Section for $uname switched from old section: $oldsec to new section: $sec".$linefeed; + } elsif ($oldsec eq '-1') { + $$logmsg .= "New student role for $uname in section $sec in course $cid".$linefeed; + } else { + $$logmsg .= "Student $uname assigned to unchanged section $sec in course $cid".$linefeed; + } + } else { + $$logmsg .= "Error when attempting section change for $uname from old section $oldsec to new section: $sec in course $cid -error: $modify_section_result".$linefeed; + } + $result = $modify_section_result; + } elsif ($secchange == 1) { + $$logmsg .= "Error when attempting to expire role for $uname in old section $oldsec in course $cid -error: $expire_role_result".$linefeed; + } + } else { + $$logmsg .= "Incomplete course id defined. Addition of user $uname from domain $udom to course $one\_$two, section $sec not completed.$linefeed"; + $result = "error: incomplete course id\n"; + } + return $result; +} + +############################################################ +############################################################ + +sub construct_course { + my ($args,$logmsg,$courseid,$crsudom,$crsunum,$udom,$uname) = @_; + my $outcome; + +# +# Open course +# + my $crstype = lc($args->{'crstype'}); + my %cenv=(); + $$courseid=&Apache::lonnet::createcourse($args->{'course_domain'}, + $args->{'cdescr'}, + $args->{'curl'}, + $args->{'course_home'}, + $args->{'nonstandard'}, + $args->{'crscode'}, + $args->{'ccuname'}.':'. + $args->{'ccdomain'}, + $args->{'crstype'}); + + # Note: The testing routines depend on this being output; see + # Utils::Course. This needs to at least be output as a comment + # if anyone ever decides to not show this, and Utils::Course::new + # will need to be suitably modified. + $outcome .= &mt('New LON-CAPA [_1] ID: [_2]
',$crstype,$$courseid); +# +# Check if created correctly +# + ($$crsudom,$$crsunum)= &LONCAPA::split_courseid($$courseid); + my $crsuhome=&Apache::lonnet::homeserver($$crsunum,$$crsudom); + $outcome .= &mt('Created on').': '.$crsuhome.'
'; +# +# Are we cloning? +# + my $cloneid=''; + if (($args->{'clonecourse'}) && ($args->{'clonedomain'})) { + $cloneid='/'.$args->{'clonedomain'}.'/'.$args->{'clonecourse'}; + my ($clonecrsudom,$clonecrsunum)= &LONCAPA::split_courseid($cloneid); + my $clonehome=&Apache::lonnet::homeserver($clonecrsunum,$clonecrsudom); + if ($clonehome eq 'no_host') { + $outcome .= + '
'.&mt('Attempting to clone non-existing [_1]',$crstype).' '.$cloneid.''; + } else { + $outcome .= + '
'.&mt('Cloning [_1] from [_2]',$crstype,$clonehome).''; + my %oldcenv=&Apache::lonnet::dump('environment',$$crsudom,$$crsunum); +# Copy all files + &Apache::lonclonecourse::copycoursefiles($cloneid,$$courseid); +# Restore URL + $cenv{'url'}=$oldcenv{'url'}; +# Restore title + $cenv{'description'}=$oldcenv{'description'}; +# restore grading mode + if (defined($oldcenv{'grading'})) { + $cenv{'grading'}=$oldcenv{'grading'}; + } +# Mark as cloned + $cenv{'clonedfrom'}=$cloneid; + delete($cenv{'default_enrollment_start_date'}); + delete($cenv{'default_enrollment_end_date'}); + } + } +# +# Set environment (will override cloned, if existing) +# + my @sections = (); + my @xlists = (); + if ($args->{'crstype'}) { + $cenv{'type'}=$args->{'crstype'}; + } + if ($args->{'crsid'}) { + $cenv{'courseid'}=$args->{'crsid'}; + } + if ($args->{'crscode'}) { + $cenv{'internal.coursecode'}=$args->{'crscode'}; + } + if ($args->{'crsquota'} ne '') { + $cenv{'internal.coursequota'}=$args->{'crsquota'}; + } else { + $cenv{'internal.coursequota'}=$args->{'crsquota'} = 20; + } + if ($args->{'ccuname'}) { + $cenv{'internal.courseowner'} = $args->{'ccuname'}. + ':'.$args->{'ccdomain'}; + } else { + $cenv{'internal.courseowner'} = $args->{'curruser'}; + } + + my @badclasses = (); # Used to accumulate sections/crosslistings that did not pass classlist access check for course owner. + if ($args->{'crssections'}) { + $cenv{'internal.sectionnums'} = ''; + if ($args->{'crssections'} =~ m/,/) { + @sections = split/,/,$args->{'crssections'}; + } else { + $sections[0] = $args->{'crssections'}; + } + if (@sections > 0) { + foreach my $item (@sections) { + my ($sec,$gp) = split/:/,$item; + my $class = $args->{'crscode'}.$sec; + my $addcheck = &Apache::lonnet::auto_new_course($$crsunum,$$crsudom,$class,$cenv{'internal.courseowner'}); + $cenv{'internal.sectionnums'} .= $item.','; + unless ($addcheck eq 'ok') { + push @badclasses, $class; + } + } + $cenv{'internal.sectionnums'} =~ s/,$//; + } + } +# do not hide course coordinator from staff listing, +# even if privileged + $cenv{'nothideprivileged'}=$args->{'ccuname'}.':'.$args->{'ccdomain'}; +# add crosslistings + if ($args->{'crsxlist'}) { + $cenv{'internal.crosslistings'}=''; + if ($args->{'crsxlist'} =~ m/,/) { + @xlists = split/,/,$args->{'crsxlist'}; + } else { + $xlists[0] = $args->{'crsxlist'}; + } + if (@xlists > 0) { + foreach my $item (@xlists) { + my ($xl,$gp) = split/:/,$item; + my $addcheck = &Apache::lonnet::auto_new_course($$crsunum,$$crsudom,$xl,$cenv{'internal.courseowner'}); + $cenv{'internal.crosslistings'} .= $item.','; + unless ($addcheck eq 'ok') { + push @badclasses, $xl; + } + } + $cenv{'internal.crosslistings'} =~ s/,$//; + } + } + if ($args->{'autoadds'}) { + $cenv{'internal.autoadds'}=$args->{'autoadds'}; + } + if ($args->{'autodrops'}) { + $cenv{'internal.autodrops'}=$args->{'autodrops'}; + } +# check for notification of enrollment changes + my @notified = (); + if ($args->{'notify_owner'}) { + if ($args->{'ccuname'} ne '') { + push(@notified,$args->{'ccuname'}.':'.$args->{'ccdomain'}); + } + } + if ($args->{'notify_dc'}) { + if ($uname ne '') { + push(@notified,$uname.'@'.$udom); + } + } + if (@notified > 0) { + my $notifylist; + if (@notified > 1) { + $notifylist = join(',',@notified); + } else { + $notifylist = $notified[0]; + } + $cenv{'internal.notifylist'} = $notifylist; + } + if (@badclasses > 0) { + my %lt=&Apache::lonlocal::texthash( + 'tclb' => 'The courses listed below were included as sections or crosslistings affiliated with your new LON-CAPA course. However, if automated course roster updates are enabled for this class, these particular sections/crosslistings will not contribute towards enrollment, because the user identified as the course owner for this LON-CAPA course', + 'dnhr' => 'does not have rights to access enrollment in these classes', + 'adby' => 'as determined by the policies of your institution on access to official classlists' + ); + $outcome .= ''.$lt{'tclb'}.' ('.$cenv{'internal.courseowner'}.') - '.$lt{'dnhr'}.' ('.$lt{'adby'}.').
    '."\n"; + foreach (@badclasses) { + $outcome .= "
  • $_
    • \n"; + } + $outcome .= "


\n"; + } + if ($args->{'no_end_date'}) { + $args->{'endaccess'} = 0; + } + $cenv{'internal.autostart'}=$args->{'enrollstart'}; + $cenv{'internal.autoend'}=$args->{'enrollend'}; + $cenv{'default_enrollment_start_date'}=$args->{'startaccess'}; + $cenv{'default_enrollment_end_date'}=$args->{'endaccess'}; + if ($args->{'showphotos'}) { + $cenv{'internal.showphotos'}=$args->{'showphotos'}; + } + $cenv{'internal.authtype'} = $args->{'authtype'}; + $cenv{'internal.autharg'} = $args->{'autharg'}; + if ( ($cenv{'internal.authtype'} =~ /^krb/) && ($cenv{'internal.autoadds'} == 1)) { + if (! defined($cenv{'internal.autharg'}) || $cenv{'internal.autharg'} eq '') { + $outcome .= ''. + &mt('As you did not include the default Kerberos domain to be used for authentication in this class, the institutional data used by the automated enrollment process must include the Kerberos domain for each new student').'

'; + } + } + if (($args->{'ccdomain'}) && ($args->{'ccuname'})) { + if ($args->{'setpolicy'}) { + $cenv{'policy.email'}=$args->{'ccuname'}.':'.$args->{'ccdomain'}; + } + if ($args->{'setcontent'}) { + $cenv{'question.email'}=$args->{'ccuname'}.':'.$args->{'ccdomain'}; + } + } + if ($args->{'reshome'}) { + $cenv{'reshome'}=$args->{'reshome'}.'/'; + $cenv{'reshome'}=~s/\/+$/\//; + } +# +# course has keyed access +# + if ($args->{'setkeys'}) { + $cenv{'keyaccess'}='yes'; + } +# if specified, key authority is not course, but user +# only active if keyaccess is yes + if ($args->{'keyauth'}) { + my ($user,$domain) = split(':',$args->{'keyauth'}); + $user = &LONCAPA::clean_username($user); + $domain = &LONCAPA::clean_username($domain); + if ($user ne '' && $domain ne '') { + $cenv{'keyauth'}=$user.':'.$domain; + } + } + + if ($args->{'disresdis'}) { + $cenv{'pch.roles.denied'}='st'; + } + if ($args->{'disablechat'}) { + $cenv{'plc.roles.denied'}='st'; + } + + # Record we've not yet viewed the Course Initialization Helper for this + # course + $cenv{'course.helper.not.run'} = 1; + # + # Use new Randomseed + # + $cenv{'rndseed'}=&Apache::lonnet::latest_rnd_algorithm_id();; + $cenv{'receiptalg'}=&Apache::lonnet::latest_receipt_algorithm_id();; + # + # The encryption code and receipt prefix for this course + # + $cenv{'internal.encseed'}=$Apache::lonnet::perlvar{'lonReceipt'}.$$.time.int(rand(9999)); + $cenv{'internal.encpref'}=100+int(9*rand(99)); + # + # By default, use standard grading + if (!defined($cenv{'grading'})) { $cenv{'grading'} = 'standard'; } + + $outcome .= ('
'.&mt('Setting environment').': '. + &Apache::lonnet::put('environment',\%cenv,$$crsudom,$$crsunum).'
'); +# +# Open all assignments +# + if ($args->{'openall'}) { + my $storeunder=$$crsudom.'_'.$$crsunum.'.0.opendate'; + my %storecontent = ($storeunder => time, + $storeunder.'.type' => 'date_start'); + + $outcome .= &mt('Opening all assignments').': '.&Apache::lonnet::cput + ('resourcedata',\%storecontent,$$crsudom,$$crsunum).'
'; + } +# +# Set first page +# + unless (($args->{'nonstandard'}) || ($args->{'firstres'} eq 'blank') + || ($cloneid)) { + use LONCAPA::map; + $outcome .= &mt('Setting first resource').': '; + + my $map = '/uploaded/'.$$crsudom.'/'.$$crsunum.'/default.sequence'; + my ($errtext,$fatal)=&LONCAPA::map::mapread($map); + + $outcome .= ($fatal?$errtext:'read ok').' - '; + my $title; my $url; + if ($args->{'firstres'} eq 'syl') { + $title='Syllabus'; + $url='/public/'.$$crsudom.'/'.$$crsunum.'/syllabus'; + } else { + $title='Navigate Contents'; + $url='/adm/navmaps'; + } + + $LONCAPA::map::resources[1]=$title.':'.$url.':false:start:res'; + (my $outtext,$errtext) = &LONCAPA::map::storemap($map,1); + + if ($errtext) { $fatal=2; } + $outcome .= ($fatal?$errtext:'write ok').'
'; + } + return $outcome; +} + +############################################################ +############################################################ + +sub course_type { + my ($cid) = @_; + if (!defined($cid)) { + $cid = $env{'request.course.id'}; + } + if (defined($env{'course.'.$cid.'.type'})) { + return $env{'course.'.$cid.'.type'}; + } else { + return 'Course'; + } +} + +sub group_term { + my $crstype = &course_type(); + my %names = ( + 'Course' => 'group', + 'Group' => 'team', + ); + return $names{$crstype}; +} sub icon { my ($file)=@_; @@ -4827,9 +6448,174 @@ sub escape_double { sub escape_url { my ($url) = @_; my @urlslices = split(/\//, $url,-1); - my $lastitem = &Apache::lonnet::escape(pop(@urlslices)); + my $lastitem = &escape(pop(@urlslices)); return join('/',@urlslices).'/'.$lastitem; } + +# -------------------------------------------------------- Initliaze user login +sub init_user_environment { + my ($r, $username, $domain, $authhost, $form, $args) = @_; + my $lonids=$Apache::lonnet::perlvar{'lonIDsDir'}; + + my $public=($username eq 'public' && $domain eq 'public'); + +# See if old ID present, if so, remove + + my ($filename,$cookie,$userroles); + my $now=time; + + if ($public) { + my $max_public=100; + my $oldest; + my $oldest_time=0; + for(my $next=1;$next<=$max_public;$next++) { + if (-e $lonids."/publicuser_$next.id") { + my $mtime=(stat($lonids."/publicuser_$next.id"))[9]; + if ($mtime<$oldest_time || !$oldest_time) { + $oldest_time=$mtime; + $oldest=$next; + } + } else { + $cookie="publicuser_$next"; + last; + } + } + if (!$cookie) { $cookie="publicuser_$oldest"; } + } else { + # if this isn't a robot, kill any existing non-robot sessions + if (!$args->{'robot'}) { + opendir(DIR,$lonids); + while ($filename=readdir(DIR)) { + if ($filename=~/^$username\_\d+\_$domain\_$authhost\.id$/) { + unlink($lonids.'/'.$filename); + } + } + closedir(DIR); + } +# Give them a new cookie + my $id = ($args->{'robot'} ? 'robot'.$args->{'robot'} + : $now); + $cookie="$username\_$id\_$domain\_$authhost"; + +# Initialize roles + + $userroles=&Apache::lonnet::rolesinit($domain,$username,$authhost); + } +# ------------------------------------ Check browser type and MathML capability + + my ($httpbrowser,$clientbrowser,$clientversion,$clientmathml, + $clientunicode,$clientos) = &decode_user_agent($r); + +# -------------------------------------- Any accessibility options to remember? + if (($form->{'interface'}) && ($form->{'remember'} eq 'true')) { + foreach my $option ('imagesuppress','appletsuppress', + 'embedsuppress','fontenhance','blackwhite') { + if ($form->{$option} eq 'true') { + &Apache::lonnet::put('environment',{$option => 'on'}, + $domain,$username); + } else { + &Apache::lonnet::del('environment',[$option], + $domain,$username); + } + } + } +# ------------------------------------------------------------- Get environment + + my %userenv = &Apache::lonnet::dump('environment',$domain,$username); + my ($tmp) = keys(%userenv); + if ($tmp !~ /^(con_lost|error|no_such_host)/i) { + # default remote control to off + if ($userenv{'remote'} ne 'on') { $userenv{'remote'} = 'off'; } + } else { + undef(%userenv); + } + if (($userenv{'interface'}) && (!$form->{'interface'})) { + $form->{'interface'}=$userenv{'interface'}; + } + $env{'environment.remote'}=$userenv{'remote'}; + if ($userenv{'texengine'} eq 'ttm') { $clientmathml=1; } + +# --------------- Do not trust query string to be put directly into environment + foreach my $option ('imagesuppress','appletsuppress', + 'embedsuppress','fontenhance','blackwhite', + 'interface','localpath','localres') { + $form->{$option}=~s/[\n\r\=]//gs; + } +# --------------------------------------------------------- Write first profile + + { + my %initial_env = + ("user.name" => $username, + "user.domain" => $domain, + "user.home" => $authhost, + "browser.type" => $clientbrowser, + "browser.version" => $clientversion, + "browser.mathml" => $clientmathml, + "browser.unicode" => $clientunicode, + "browser.os" => $clientos, + "server.domain" => $Apache::lonnet::perlvar{'lonDefDomain'}, + "request.course.fn" => '', + "request.course.uri" => '', + "request.course.sec" => '', + "request.role" => 'cm', + "request.role.adv" => $env{'user.adv'}, + "request.host" => $ENV{'REMOTE_ADDR'},); + + if ($form->{'localpath'}) { + $initial_env{"browser.localpath"} = $form->{'localpath'}; + $initial_env{"browser.localres"} = $form->{'localres'}; + } + + if ($public) { + $initial_env{"environment.remote"} = "off"; + } + if ($form->{'interface'}) { + $form->{'interface'}=~s/\W//gs; + $initial_env{"browser.interface"} = $form->{'interface'}; + $env{'browser.interface'}=$form->{'interface'}; + foreach my $option ('imagesuppress','appletsuppress', + 'embedsuppress','fontenhance','blackwhite') { + if (($form->{$option} eq 'true') || + ($userenv{$option} eq 'on')) { + $initial_env{"browser.$option"} = "on"; + } + } + } + + $env{'user.environment'} = "$lonids/$cookie.id"; + + if (tie(my %disk_env,'GDBM_File',"$lonids/$cookie.id", + &GDBM_WRCREAT(),0640)) { + &_add_to_env(\%disk_env,\%initial_env); + &_add_to_env(\%disk_env,\%userenv,'environment.'); + &_add_to_env(\%disk_env,$userroles); + if (ref($args->{'extra_env'})) { + &_add_to_env(\%disk_env,$args->{'extra_env'}); + } + untie(%disk_env); + } else { + &Apache::lonnet::logthis("WARNING: ". + 'Could not create environment storage in lonauth: '.$!.''); + return 'error: '.$!; + } + } + $env{'request.role'}='cm'; + $env{'request.role.adv'}=$env{'user.adv'}; + $env{'browser.type'}=$clientbrowser; + + return $cookie; + +} + +sub _add_to_env { + my ($idf,$env_data,$prefix) = @_; + while (my ($key,$value) = each(%$env_data)) { + $idf->{$prefix.$key} = $value; + $env{$prefix.$key} = $value; + } +} + + =pod =back
'.&mt('Attribute').''.&mt('Column').'
'.$display.'