--- loncom/interface/loncommon.pm 2020/11/12 01:18:26 1.1075.2.149 +++ loncom/interface/loncommon.pm 2015/02/25 19:22:24 1.1206 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # a pile of common routines # -# $Id: loncommon.pm,v 1.1075.2.149 2020/11/12 01:18:26 raeburn Exp $ +# $Id: loncommon.pm,v 1.1206 2015/02/25 19:22:24 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -71,18 +71,13 @@ use Apache::lonuserutils(); use Apache::lonuserstate(); use Apache::courseclassifier(); use LONCAPA qw(:DEFAULT :match); -use HTTP::Request; use DateTime::TimeZone; -use DateTime::Locale; -use Encode(); +use DateTime::Locale::Catalog; +use Text::Aspell; use Authen::Captcha; use Captcha::reCAPTCHA; -use JSON::DWIW; -use LWP::UserAgent; use Crypt::DES; use DynaLoader; # for Crypt::DES version -use File::Copy(); -use File::Path(); # ---------------------------------------------- Designs use vars qw(%defaultdesign); @@ -167,6 +162,7 @@ sub ssi_with_retries { # ----------------------------------------------- Filetypes/Languages/Copyright my %language; my %supported_language; +my %supported_codes; my %latex_language; # For choosing hyphenation in my %latex_language_bykey; # for choosing hyphenation from metadata my %cprtag; @@ -197,18 +193,19 @@ BEGIN { { my $langtabfile = $Apache::lonnet::perlvar{'lonTabDir'}. '/language.tab'; - if ( open(my $fh,'<',$langtabfile) ) { + if ( open(my $fh,"<$langtabfile") ) { while (my $line = <$fh>) { next if ($line=~/^\#/); chomp($line); - my ($key,$two,$country,$three,$enc,$val,$sup,$latex)=(split(/\t/,$line)); + my ($key,$code,$country,$three,$enc,$val,$sup,$latex)=(split(/\t/,$line)); $language{$key}=$val.' - '.$enc; if ($sup) { $supported_language{$key}=$sup; + $supported_codes{$key} = $code; } if ($latex) { $latex_language_bykey{$key} = $latex; - $latex_language{$two} = $latex; + $latex_language{$code} = $latex; } } close($fh); @@ -218,7 +215,7 @@ BEGIN { { my $copyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}. '/copyright.tab'; - if ( open (my $fh,'<',$copyrightfile) ) { + if ( open (my $fh,"<$copyrightfile") ) { while (my $line = <$fh>) { next if ($line=~/^\#/); chomp($line); @@ -232,7 +229,7 @@ BEGIN { { my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}. '/source_copyright.tab'; - if ( open (my $fh,'<',$sourcecopyrightfile) ) { + if ( open (my $fh,"<$sourcecopyrightfile") ) { while (my $line = <$fh>) { next if ($line =~ /^\#/); chomp($line); @@ -246,7 +243,7 @@ BEGIN { # -------------------------------------------------------------- default domain designs my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors'; my $designfile = $designdir.'/default.tab'; - if ( open (my $fh,'<',$designfile) ) { + if ( open (my $fh,"<$designfile") ) { while (my $line = <$fh>) { next if ($line =~ /^\#/); chomp($line); @@ -260,12 +257,12 @@ BEGIN { { my $categoryfile = $Apache::lonnet::perlvar{'lonTabDir'}. '/filecategories.tab'; - if ( open (my $fh,'<',$categoryfile) ) { + if ( open (my $fh,"<$categoryfile") ) { while (my $line = <$fh>) { next if ($line =~ /^\#/); chomp($line); my ($extension,$category)=(split(/\s+/,$line,2)); - push(@{$category_extensions{lc($category)}},$extension); + push @{$category_extensions{lc($category)}},$extension; } close($fh); } @@ -275,7 +272,7 @@ BEGIN { { my $typesfile = $Apache::lonnet::perlvar{'lonTabDir'}. '/filetypes.tab'; - if ( open (my $fh,'<',$typesfile) ) { + if ( open (my $fh,"<$typesfile") ) { while (my $line = <$fh>) { next if ($line =~ /^\#/); chomp($line); @@ -428,7 +425,7 @@ sub studentbrowser_javascript { -OFFLOAD - } - } - } - } - } } if (!defined($title)) { $title = 'The LearningOnline Network with CAPA'; @@ -8105,21 +7708,14 @@ OFFLOAD if (!$args->{'frameset'}) { $result .= ' /'; } - $result .= '>' + $result .= '>' .$inhibitprint .$head_extra; - my $clientmobile; - if (($env{'user.name'} eq '') && ($env{'user.domain'} eq '')) { - (undef,undef,undef,undef,undef,undef,$clientmobile) = &decode_user_agent(); - } else { - $clientmobile = $env{'browser.mobile'}; - } - if ($clientmobile) { + if ($env{'browser.mobile'}) { $result .= ' '; } - $result .= ''."\n"; return $result.''; } @@ -8138,12 +7734,12 @@ sub font_settings { my $headerstring=''; if ((!$env{'browser.mathml'} && $env{'browser.unicode'}) || ((ref($args) eq 'HASH') && ($args->{'browser.unicode'}))) { - $headerstring.= - '{'frameset'}) { - $headerstring.= ' /'; + $headerstring.= ' /'; } - $headerstring .= '>'."\n"; + $headerstring .= '>'."\n"; } return $headerstring; } @@ -8296,19 +7892,14 @@ $args - additional optional args support 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 + inherit_jsmath -> when creating popup window in a page, + should it have jsmath forced on by the + current page bread_crumbs -> Array containing breadcrumbs bread_crumbs_component -> if exists show it as headline else show only the breadcrumbs - bread_crumbs_nomenu -> if true will pass false as the value of $menulink - to lonhtmlcommon::breadcrumbs - group -> includes the current group, if page is for a - specific group - use_absolute -> for request for external resource or syllabus, this - will contain https:// if server uses - https (as per hosts.tab), but request is for http - hostname -> hostname, originally from $r->hostname(), (optional). + group -> includes the current group, if page is for a + specific group =back @@ -8338,8 +7929,8 @@ sub start_page { $args->{'function'}, $args->{'add_entries'}, $args->{'only_body'}, $args->{'domain'}, $args->{'force_register'}, $args->{'no_nav_bar'}, - $args->{'bgcolor'}, $args->{'no_inline_link'}, - $args, \@advtools); + $args->{'bgcolor'}, $args, + \@advtools); } } @@ -8372,24 +7963,13 @@ sub start_page { if (@advtools > 0) { &Apache::lonmenu::advtools_crumbs(@advtools); } - my $menulink; - # if arg: bread_crumbs_nomenu is true pass 0 as $menulink item. - if (exists($args->{'bread_crumbs_nomenu'})) { - $menulink = 0; - } else { - undef($menulink); - } + #if bread_crumbs_component exists show it as headline else show only the breadcrumbs if(exists($args->{'bread_crumbs_component'})){ - $result .= &Apache::lonhtmlcommon::breadcrumbs($args->{'bread_crumbs_component'},'',$menulink); + $result .= &Apache::lonhtmlcommon::breadcrumbs($args->{'bread_crumbs_component'}); }else{ - $result .= &Apache::lonhtmlcommon::breadcrumbs('','',$menulink); + $result .= &Apache::lonhtmlcommon::breadcrumbs(); } - } elsif (($env{'environment.remote'} eq 'on') && - ($env{'form.inhibitmenu'} ne 'yes') && - ($env{'request.noversionuri'} =~ m{^/res/}) && - ($env{'request.noversionuri'} !~ m{^/res/adm/pages/})) { - $result .= '

'; } return $result; } @@ -8485,13 +8065,13 @@ var modalWindow = { }; var openMyModal = function(source,width,height,scrolling,transparency,style) { - source = source.replace(/'/g,"'"); + source = source.replace("'","'"); modalWindow.windowId = "myModal"; modalWindow.width = width; modalWindow.height = height; modalWindow.content = ""; modalWindow.open(); - }; + }; // END LON-CAPA Internal --> // ]]> @@ -8510,7 +8090,8 @@ sub modal_link { $target_attr = 'target="'.$target.'"'; } return <<"ENDLINK"; -$linktext + + $linktext ENDLINK } @@ -8536,7 +8117,7 @@ sub modal_adhoc_inner { my ($funcname,$width,$height,$content)=@_; my $innerwidth=$width-20; $content=&js_ready( - &start_page('Dialog',undef,{'only_body'=>1,'bgcolor'=>'#FFFFFF'}). + &start_page('Dialog',undef,{'only_body'=>1,'bgcolor'=>'#FFFFFF'}). &start_scrollbox($width.'px',$innerwidth.'px',$height.'px','myModal','#FFFFFF',undef,1). $content. &end_scrollbox(). @@ -8613,9 +8194,8 @@ sub end_togglebox { } sub LCprogressbar_script { - my ($id,$number_to_do)=@_; - if ($number_to_do) { - return(< // ENDPROGRESS - } else { - return(< -// - -ENDPROGRESS - } } sub LCprogressbarUpdate_script { return(< .ui-progressbar { position:relative; } -.progress-label {position: absolute; width: 100%; text-align: center; top: 1px; font-weight: bold; text-shadow: 1px 1px 0 #fff;margin: 0; line-height: 200%; } .pblabel { position: absolute; width: 100%; text-align: center; line-height: 1.9em; } @@ -8676,54 +8234,37 @@ my $LCidcnt; my $LCcurrentid; sub LCprogressbar { - my ($r,$number_to_do,$preamble)=@_; + my ($r)=(@_); $LClastpercent=0; $LCidcnt++; $LCcurrentid=$$.'_'.$LCidcnt; - my ($starting,$content); - if ($number_to_do) { - $starting=&mt('Starting'); - $content=(< $starting ENDPROGBAR - } else { - $starting=&mt('Loading...'); - $LClastpercent='false'; - $content=(< -
$starting
- -ENDPROGBAR - } - &r_print($r,$content.&LCprogressbar_script($LCcurrentid,$number_to_do)); + &r_print($r,$content.&LCprogressbar_script($LCcurrentid)); } sub LCprogressbarUpdate { - my ($r,$val,$text,$number_to_do)=@_; - if ($number_to_do) { - unless ($val) { - if ($LClastpercent) { - $val=$LClastpercent; - } else { - $val=0; - } - } - if ($val<0) { $val=0; } - if ($val>100) { $val=0; } - $LClastpercent=$val; - unless ($text) { $text=$val.'%'; } - } else { - $val = 'false'; + my ($r,$val,$text)=@_; + unless ($val) { + if ($LClastpercent) { + $val=$LClastpercent; + } else { + $val=0; + } } + if ($val<0) { $val=0; } + if ($val>100) { $val=0; } + $LClastpercent=$val; + unless ($text) { $text=$val.'%'; } $text=&js_ready($text); &r_print($r,< // ENDUPDATE @@ -9221,7 +8762,7 @@ sub get_sections { } } - if ($check_students) { + if ($check_students) { my ($classlist) = &Apache::loncoursedata::get_classlist($cdom,$cnum); my $sec_index = &Apache::loncoursedata::CL_SECTION(); my $status_index = &Apache::loncoursedata::CL_STATUS(); @@ -9617,8 +9158,8 @@ sub get_user_quota { if ($quota eq '' || wantarray) { if ($quotaname eq 'course') { my %domdefs = &Apache::lonnet::get_domain_defaults($udom); - if (($crstype eq 'official') || ($crstype eq 'unofficial') || - ($crstype eq 'community') || ($crstype eq 'textbook')) { + if (($crstype eq 'official') || ($crstype eq 'unofficial') || + ($crstype eq 'community') || ($crstype eq 'textbook')) { $defquota = $domdefs{$crstype.'quota'}; } if ($defquota eq '') { @@ -9802,6 +9343,8 @@ sub excess_filesize_warning { ############################################### + + sub get_secgrprole_info { my ($cdom,$cnum,$needroles,$type) = @_; my %sections_count = &get_sections($cdom,$cnum); @@ -9840,24 +9383,8 @@ sub get_secgrprole_info { } sub user_picker { - my ($dom,$srch,$forcenewuser,$caller,$cancreate,$usertype,$context,$fixeddom,$noinstd) = @_; + my ($dom,$srch,$forcenewuser,$caller,$cancreate,$usertype,$context) = @_; my $currdom = $dom; - my @alldoms = &Apache::lonnet::all_domains(); - if (@alldoms == 1) { - my %domsrch = &Apache::lonnet::get_dom('configuration', - ['directorysrch'],$alldoms[0]); - my $domdesc = &Apache::lonnet::domain($alldoms[0],'description'); - my $showdom = $domdesc; - if ($showdom eq '') { - $showdom = $dom; - } - if (ref($domsrch{'directorysrch'}) eq 'HASH') { - if ((!$domsrch{'directorysrch'}{'available'}) && - ($domsrch{'directorysrch'}{'lcavailable'} eq '0')) { - return (&mt('LON-CAPA directory search is not available in domain: [_1]',$showdom),0); - } - } - } my %curr_selected = ( srchin => 'dom', srchby => 'lastname', @@ -9878,7 +9405,7 @@ sub user_picker { } $srchterm = $srch->{'srchterm'}; } - my %html_lt=&Apache::lonlocal::texthash( + my %lt=&Apache::lonlocal::texthash( 'usr' => 'Search criteria', 'doma' => 'Domain/institution to search', 'uname' => 'username', @@ -9891,8 +9418,6 @@ sub user_picker { 'exact' => 'is', 'contains' => 'contains', 'begins' => 'begins with', - ); - my %js_lt=&Apache::lonlocal::texthash( 'youm' => "You must include some text to search for.", 'thte' => "The text you are searching for must contain at least two characters when using a 'begins' type search.", 'thet' => "The text you are searching for must contain at least three characters when using a 'contains' type search.", @@ -9902,16 +9427,7 @@ sub user_picker { 'whse' => "When searching by last,first you must include at least one character in the first name.", 'thfo' => "The following need to be corrected before the search can be run:", ); - &html_escape(\%html_lt); - &js_escape(\%js_lt); - my $domform; - my $allow_blank = 1; - if ($fixeddom) { - $allow_blank = 0; - $domform = &select_dom_form($currdom,'srchdomain',$allow_blank,1,undef,[$currdom]); - } else { - $domform = &select_dom_form($currdom,'srchdomain',$allow_blank,1); - } + my $domform = &select_dom_form($currdom,'srchdomain',1,1); my $srchinsel = ' \n"; @@ -9938,10 +9453,10 @@ sub user_picker { foreach my $option ('lastname','lastfirst','uname') { if ($curr_selected{'srchby'} eq $option) { $srchbysel .= ' - '; + '; } else { $srchbysel .= ' - '; + '; } } $srchbysel .= "\n \n"; @@ -9950,10 +9465,10 @@ sub user_picker { foreach my $option ('begins','contains','exact') { if ($curr_selected{'srchtype'} eq $option) { $srchtypesel .= ' - '; + '; } else { $srchtypesel .= ' - '; + '; } } $srchtypesel .= "\n \n"; @@ -10038,46 +9553,46 @@ function validateEntry(callingForm) { if (srchterm == "") { checkok = 0; - msg += "$js_lt{'youm'}\\n"; + msg += "$lt{'youm'}\\n"; } if (srchtype== 'begins') { if (srchterm.length < 2) { checkok = 0; - msg += "$js_lt{'thte'}\\n"; + msg += "$lt{'thte'}\\n"; } } if (srchtype== 'contains') { if (srchterm.length < 3) { checkok = 0; - msg += "$js_lt{'thet'}\\n"; + msg += "$lt{'thet'}\\n"; } } if (srchin == 'instd') { if (srchdomain == '') { checkok = 0; - msg += "$js_lt{'yomc'}\\n"; + msg += "$lt{'yomc'}\\n"; } } if (srchin == 'dom') { if (srchdomain == '') { checkok = 0; - msg += "$js_lt{'ymcd'}\\n"; + msg += "$lt{'ymcd'}\\n"; } } if (srchby == 'lastfirst') { if (srchterm.indexOf(",") == -1) { checkok = 0; - msg += "$js_lt{'whus'}\\n"; + msg += "$lt{'whus'}\\n"; } if (srchterm.indexOf(",") == srchterm.length -1) { checkok = 0; - msg += "$js_lt{'whse'}\\n"; + msg += "$lt{'whse'}\\n"; } } if (checkok == 0) { - alert("$js_lt{'thfo'}\\n"+msg); + alert("$lt{'thfo'}\\n"+msg); return; } if (checkok == 1) { @@ -10095,10 +9610,10 @@ $new_user_create END_BLOCK $output .= &Apache::lonhtmlcommon::start_pick_box(). - &Apache::lonhtmlcommon::row_title($html_lt{'doma'}). + &Apache::lonhtmlcommon::row_title($lt{'doma'}). $domform. &Apache::lonhtmlcommon::row_closure(). - &Apache::lonhtmlcommon::row_title($html_lt{'usr'}). + &Apache::lonhtmlcommon::row_title($lt{'usr'}). $srchbysel. $srchtypesel. ''. @@ -10106,165 +9621,61 @@ END_BLOCK &Apache::lonhtmlcommon::row_closure(1). &Apache::lonhtmlcommon::end_pick_box(). '
'; - return ($output,1); + return $output; } sub user_rule_check { my ($usershash,$checks,$alerts,$rulematch,$inst_results,$curr_rules,$got_rules) = @_; - my ($response,%inst_response); + my $response; if (ref($usershash) eq 'HASH') { - if (keys(%{$usershash}) > 1) { - my (%by_username,%by_id,%userdoms); - my $checkid; - if (ref($checks) eq 'HASH') { - if ((!defined($checks->{'username'})) && (defined($checks->{'id'}))) { - $checkid = 1; - } - } - foreach my $user (keys(%{$usershash})) { - my ($uname,$udom) = split(/:/,$user); - if ($checkid) { - if (ref($usershash->{$user}) eq 'HASH') { - if ($usershash->{$user}->{'id'} ne '') { - $by_id{$udom}{$usershash->{$user}->{'id'}} = $uname; - $userdoms{$udom} = 1; - if (ref($inst_results) eq 'HASH') { - $inst_results->{$uname.':'.$udom} = {}; - } - } - } - } else { - $by_username{$udom}{$uname} = 1; - $userdoms{$udom} = 1; - if (ref($inst_results) eq 'HASH') { - $inst_results->{$uname.':'.$udom} = {}; - } - } - } - foreach my $udom (keys(%userdoms)) { - if (!$got_rules->{$udom}) { - my %domconfig = &Apache::lonnet::get_dom('configuration', - ['usercreation'],$udom); - if (ref($domconfig{'usercreation'}) eq 'HASH') { - foreach my $item ('username','id') { - if (ref($domconfig{'usercreation'}{$item.'_rule'}) eq 'ARRAY') { - $$curr_rules{$udom}{$item} = - $domconfig{'usercreation'}{$item.'_rule'}; - } - } - } - $got_rules->{$udom} = 1; - } + foreach my $user (keys(%{$usershash})) { + my ($uname,$udom) = split(/:/,$user); + next if ($udom eq '' || $uname eq ''); + my ($id,$newuser); + if (ref($usershash->{$user}) eq 'HASH') { + $newuser = $usershash->{$user}->{'newuser'}; + $id = $usershash->{$user}->{'id'}; } - if ($checkid) { - foreach my $udom (keys(%by_id)) { - my ($outcome,$results) = &Apache::lonnet::get_multiple_instusers($udom,$by_id{$udom},'id'); - if ($outcome eq 'ok') { - foreach my $id (keys(%{$by_id{$udom}})) { - my $uname = $by_id{$udom}{$id}; - $inst_response{$uname.':'.$udom} = $outcome; - } - if (ref($results) eq 'HASH') { - foreach my $uname (keys(%{$results})) { - if (exists($inst_response{$uname.':'.$udom})) { - $inst_response{$uname.':'.$udom} = $outcome; - $inst_results->{$uname.':'.$udom} = $results->{$uname}; - } - } - } - } + my $inst_response; + if (ref($checks) eq 'HASH') { + if (defined($checks->{'username'})) { + ($inst_response,%{$inst_results->{$user}}) = + &Apache::lonnet::get_instuser($udom,$uname); + } elsif (defined($checks->{'id'})) { + ($inst_response,%{$inst_results->{$user}}) = + &Apache::lonnet::get_instuser($udom,undef,$id); } } else { - foreach my $udom (keys(%by_username)) { - my ($outcome,$results) = &Apache::lonnet::get_multiple_instusers($udom,$by_username{$udom}); - if ($outcome eq 'ok') { - foreach my $uname (keys(%{$by_username{$udom}})) { - $inst_response{$uname.':'.$udom} = $outcome; - } - if (ref($results) eq 'HASH') { - foreach my $uname (keys(%{$results})) { - $inst_results->{$uname.':'.$udom} = $results->{$uname}; - } - } - } - } + ($inst_response,%{$inst_results->{$user}}) = + &Apache::lonnet::get_instuser($udom,$uname); + return; } - } elsif (keys(%{$usershash}) == 1) { - my $user = (keys(%{$usershash}))[0]; - my ($uname,$udom) = split(/:/,$user); - if (($udom ne '') && ($uname ne '')) { - if (ref($usershash->{$user}) eq 'HASH') { - if (ref($checks) eq 'HASH') { - if (defined($checks->{'username'})) { - ($inst_response{$user},%{$inst_results->{$user}}) = - &Apache::lonnet::get_instuser($udom,$uname); - } elsif (defined($checks->{'id'})) { - if ($usershash->{$user}->{'id'} ne '') { - ($inst_response{$user},%{$inst_results->{$user}}) = - &Apache::lonnet::get_instuser($udom,undef, - $usershash->{$user}->{'id'}); - } else { - ($inst_response{$user},%{$inst_results->{$user}}) = - &Apache::lonnet::get_instuser($udom,$uname); - } + if (!$got_rules->{$udom}) { + my %domconfig = &Apache::lonnet::get_dom('configuration', + ['usercreation'],$udom); + if (ref($domconfig{'usercreation'}) eq 'HASH') { + foreach my $item ('username','id') { + if (ref($domconfig{'usercreation'}{$item.'_rule'}) eq 'ARRAY') { + $$curr_rules{$udom}{$item} = + $domconfig{'usercreation'}{$item.'_rule'}; } - } else { - ($inst_response{$user},%{$inst_results->{$user}}) = - &Apache::lonnet::get_instuser($udom,$uname); - return; - } - if (!$got_rules->{$udom}) { - my %domconfig = &Apache::lonnet::get_dom('configuration', - ['usercreation'],$udom); - if (ref($domconfig{'usercreation'}) eq 'HASH') { - foreach my $item ('username','id') { - if (ref($domconfig{'usercreation'}{$item.'_rule'}) eq 'ARRAY') { - $$curr_rules{$udom}{$item} = - $domconfig{'usercreation'}{$item.'_rule'}; - } - } - } - $got_rules->{$udom} = 1; } } - } else { - return; - } - } else { - return; - } - foreach my $user (keys(%{$usershash})) { - my ($uname,$udom) = split(/:/,$user); - next if (($udom eq '') || ($uname eq '')); - my $id; - if (ref($inst_results) eq 'HASH') { - if (ref($inst_results->{$user}) eq 'HASH') { - $id = $inst_results->{$user}->{'id'}; - } - } - if ($id eq '') { - if (ref($usershash->{$user})) { - $id = $usershash->{$user}->{'id'}; - } + $got_rules->{$udom} = 1; } foreach my $item (keys(%{$checks})) { if (ref($$curr_rules{$udom}) eq 'HASH') { if (ref($$curr_rules{$udom}{$item}) eq 'ARRAY') { if (@{$$curr_rules{$udom}{$item}} > 0) { - my %rule_check = &Apache::lonnet::inst_rulecheck($udom,$uname,$id,$item, - $$curr_rules{$udom}{$item}); + my %rule_check = &Apache::lonnet::inst_rulecheck($udom,$uname,$id,$item,$$curr_rules{$udom}{$item}); foreach my $rule (@{$$curr_rules{$udom}{$item}}) { if ($rule_check{$rule}) { $$rulematch{$user}{$item} = $rule; - if ($inst_response{$user} eq 'ok') { + if ($inst_response eq 'ok') { if (ref($inst_results) eq 'HASH') { if (ref($inst_results->{$user}) eq 'HASH') { if (keys(%{$inst_results->{$user}}) == 0) { $$alerts{$item}{$udom}{$uname} = 1; - } elsif ($item eq 'id') { - if ($inst_results->{$user}->{'id'} eq '') { - $$alerts{$item}{$udom}{$uname} = 1; - } } } } @@ -10421,7 +9832,7 @@ sub get_institutional_codes { foreach (@currxlists) { if (m/^([^:]+):(\w*)$/) { unless (grep/^$1$/,@{$allcourses}) { - push(@{$allcourses},$1); + push @{$allcourses},$1; $$LC_code{$1} = $2; } } @@ -10434,7 +9845,7 @@ sub get_institutional_codes { my $sec = $coursecode.$1; my $lc_sec = $2; unless (grep/^$sec$/,@{$allcourses}) { - push(@{$allcourses},$sec); + push @{$allcourses},$sec; $$LC_code{$sec} = $lc_sec; } } @@ -10532,9 +9943,7 @@ reservable_now - ref to hash of student_ Keys in inner hash are: (a) symb: either blank or symb to which slot use is restricted. - (b) endreserve: end date of reservation period. - (c) uniqueperiod: start,end dates when slot is to be uniquely - selected. + (b) endreserve: end date of reservation period. sorted_future - ref to array of student_schedulable slots reservable in the future, ordered by start date of reservation period. @@ -10545,8 +9954,6 @@ future_reservable - ref to hash of stude Keys in inner hash are: (a) symb: either blank or symb to which slot use is restricted. (b) startreserve: start date of reservation period. - (c) uniqueperiod: start,end dates when slot is to be uniquely - selected. =back @@ -10600,10 +10007,6 @@ sub get_future_slots { my $startreserve = $slots{$slot}->{'startreserve'}; my $endreserve = $slots{$slot}->{'endreserve'}; my $symb = $slots{$slot}->{'symb'}; - my $uniqueperiod; - if (ref($slots{$slot}->{'uniqueperiod'}) eq 'ARRAY') { - $uniqueperiod = join(',',@{$slots{$slot}->{'uniqueperiod'}}); - } if (($startreserve < $now) && (!$endreserve || $endreserve > $now)) { my $lastres = $endreserve; @@ -10612,15 +10015,13 @@ sub get_future_slots { } $reservable_now{$slot} = { symb => $symb, - endreserve => $lastres, - uniqueperiod => $uniqueperiod, + endreserve => $lastres }; } elsif (($startreserve > $now) && (!$endreserve || $endreserve > $startreserve)) { $future_reservable{$slot} = { symb => $symb, - startreserve => $startreserve, - uniqueperiod => $uniqueperiod, + startreserve => $startreserve }; } } @@ -10801,7 +10202,7 @@ sub ask_for_embedded_content { $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; $cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; } - if (($actionurl eq '/adm/portfolio') || + if (($actionurl eq '/adm/portfolio') || ($actionurl eq '/adm/coursegrp_portfolio')) { my $current_path='/'; if ($env{'form.currentpath'}) { @@ -10833,18 +10234,18 @@ sub ask_for_embedded_content { $toplevel = $url; if ($args->{'context'} eq 'paste') { ($cdom,$cnum) = ($url =~ m{^\Q/uploaded/\E($match_domain)/($match_courseid)/}); - ($path) = + ($path) = ($toplevel =~ m{^(\Q/uploaded/$cdom/$cnum/\E(?:docs|supplemental)/(?:default|\d+)/\d+)/}); $fileloc = &Apache::lonnet::filelocation('',$toplevel); $fileloc =~ s{^/}{}; } } - } elsif ($actionurl eq '/adm/dependencies') { + } elsif ($actionurl eq '/adm/dependencies') { if ($env{'request.course.id'} ne '') { if (ref($args) eq 'HASH') { $url = $args->{'docs_url'}; $title = $args->{'docs_title'}; - $toplevel = $url; + $toplevel = $url; unless ($toplevel =~ m{^/}) { $toplevel = "/$url"; } @@ -10923,8 +10324,8 @@ sub ask_for_embedded_content { my $dirptr = 16384; foreach my $path (keys(%subdependencies)) { $currsubfile{$path} = {}; - if (($actionurl eq '/adm/portfolio') || - ($actionurl eq '/adm/coursegrp_portfolio')) { + if (($actionurl eq '/adm/portfolio') || + ($actionurl eq '/adm/coursegrp_portfolio')) { my ($sublistref,$listerror) = &Apache::lonnet::dirlist($url.$path,$udom,$uname,$getpropath); if (ref($sublistref) eq 'ARRAY') { @@ -11066,7 +10467,7 @@ sub ask_for_embedded_content { $counter = scalar(keys(%existing)); $numpathchg = scalar(keys(%pathchanges)); return ($output,$counter,$numpathchg,\%existing); - } elsif (($actionurl eq "/public/$cdom/$cnum/syllabus") && + } elsif (($actionurl eq "/public/$cdom/$cnum/syllabus") && (ref($args) eq 'HASH') && ($args->{'context'} eq 'rewrites')) { $counter = scalar(keys(%existing)); $numpathchg = scalar(keys(%pathchanges)); @@ -11295,7 +10696,7 @@ sub ask_for_embedded_content { Performs clean-up of directories, subdirectories and filename in an embedded object, referenced in an HTML file which is being uploaded -to a course or portfolio, where +to a course or portfolio, where "Upload embedded images/multimedia files if HTML file" checkbox was checked. @@ -11314,7 +10715,7 @@ sub clean_path { @contents = ($embed_file); } my $lastidx = scalar(@contents)-1; - for (my $i=0; $i<=$lastidx; $i++) { + for (my $i=0; $i<=$lastidx; $i++) { $contents[$i]=~s{\\}{/}g; $contents[$i]=~s/\s+/\_/g; $contents[$i]=~s{[^/\w\.\-]}{}g; @@ -11653,7 +11054,7 @@ sub modify_html_refs { } my (%allfiles,%codebase,$output,$content); my @changes = &get_env_multiple('form.namechange'); - unless ((@changes > 0) || ($context eq 'syllabus')) { + unless ((@changes > 0) || ($context eq 'syllabus')) { if (wantarray) { return ('',0,0); } else { @@ -11685,7 +11086,7 @@ sub modify_html_refs { return; } } - if (open(my $fh,'<',$container)) { + if (open(my $fh,"<$container")) { $content = join('', <$fh>); close($fh); } else { @@ -11750,7 +11151,7 @@ sub modify_html_refs { } } } else { - if (open(my $fh,'>',$container)) { + if (open(my $fh,">$container")) { print $fh $content; close($fh); $output = '

'.&mt('Updated [quant,_1,reference] in [_2].', @@ -11788,7 +11189,7 @@ sub modify_html_refs { } } if ($rewrites) { - my $saveresult; + my $saveresult; my $url = &Apache::lonnet::store_edited_file($container,$content,$udom,$uname,\$saveresult); if ($url eq $container) { my ($fname) = ($container =~ m{/([^/]+)$}); @@ -12084,6 +11485,7 @@ function camtasiaToggle() { for (var i=0; i'.&mt('Not extracted.').'
'. - &mt('Unexpected file path.').'

'."\n"; - } - unless (($docudom =~ /^$match_domain$/) && ($docuname =~ /^$match_courseid$/)) { - return '

'.&mt('Not extracted.').'
'. - &mt('Unexpected course context.').'

'."\n"; - } - unless ($file eq &Apache::lonnet::clean_filename($file)) { - return '

'.&mt('Not extracted.').'
'. - &mt('Filename contained unexpected characters.').'

'."\n"; - } my ($dir,$error,$warning,$output); if ($file !~ /\.(zip|tar|bz2|gz|tar.gz|tar.bz2|tgz)$/i) { $error = &mt('Filename not a supported archive file type.'). @@ -12313,44 +11703,30 @@ sub process_decompression { } } my $numskip = scalar(@to_skip); - my $numoverwrite = scalar(@to_overwrite); - if (($numskip) && (!$numoverwrite)) { + if (($numskip > 0) && + ($numskip == $env{'form.archive_itemcount'})) { $warning = &mt('All items in the archive file already exist, and no overwriting of existing files has been requested.'); } elsif ($dir eq '') { $error = &mt('Directory containing archive file unavailable.'); } elsif (!$error) { my ($decompressed,$display); - if (($numskip) || ($numoverwrite)) { + if ($numskip > 0) { my $tempdir = time.'_'.$$.int(rand(10000)); mkdir("$dir/$tempdir",0755); - if (&File::Copy::move("$dir/$file","$dir/$tempdir/$file")) { - ($decompressed,$display) = - &decompress_uploaded_file($file,"$dir/$tempdir"); - foreach my $item (@to_skip) { - if (($item ne '') && ($item !~ /\.\./)) { - if (-f "$dir/$tempdir/$item") { - unlink("$dir/$tempdir/$item"); - } elsif (-d "$dir/$tempdir/$item") { - &File::Path::remove_tree("$dir/$tempdir/$item",{ safe => 1 }); - } - } - } - foreach my $item (@to_overwrite) { - if ((-e "$dir/$tempdir/$item") && (-e "$dir/$item")) { - if (($item ne '') && ($item !~ /\.\./)) { - if (-f "$dir/$item") { - unlink("$dir/$item"); - } elsif (-d "$dir/$item") { - &File::Path::remove_tree("$dir/$item",{ safe => 1 }); - } - &File::Copy::move("$dir/$tempdir/$item","$dir/$item"); - } + system("mv $dir/$file $dir/$tempdir/$file"); + ($decompressed,$display) = + &decompress_uploaded_file($file,"$dir/$tempdir"); + foreach my $item (@to_skip) { + if (($item ne '') && ($item !~ /\.\./)) { + if (-f "$dir/$tempdir/$item") { + unlink("$dir/$tempdir/$item"); + } elsif (-d "$dir/$tempdir/$item") { + system("rm -rf $dir/$tempdir/$item"); } } - if (&File::Copy::move("$dir/$tempdir/$file","$dir/$file")) { - &File::Path::remove_tree("$dir/$tempdir",{ safe => 1 }); - } } + system("mv $dir/$tempdir/* $dir"); + rmdir("$dir/$tempdir"); } else { ($decompressed,$display) = &decompress_uploaded_file($file,$dir); @@ -12368,7 +11744,8 @@ sub process_decompression { if (ref($newdirlistref) eq 'ARRAY') { foreach my $dir_line (@{$newdirlistref}) { my ($item,undef,undef,$testdir)=split(/\&/,$dir_line,5); - unless (($item =~ /^\.+$/) || ($item eq $file)) { + unless (($item =~ /^\.+$/) || ($item eq $file) || + ((@to_skip > 0) && (grep(/^\Q$item\E$/,@to_skip)))) { push(@newitems,$item); if ($dirptr&$testdir) { $is_dir{$item} = 1; @@ -12423,7 +11800,7 @@ sub process_decompression { $env{'form.archive_title_'.$i} = $env{'form.camtasia_foldername'}; $displayed{'folder'} = $i; } elsif ((($item eq "$contents[0]/index.html") && ($version == 6)) || - (($item eq "$contents[0]/$contents[0]".'.html') && ($version == 8))) { + (($item eq "$contents[0]/$contents[0]".'.html') && ($version == 8))) { $env{'form.archive_'.$i} = 'display'; $env{'form.archive_title_'.$i} = $env{'form.camtasia_moviename'}; $displayed{'web'} = $i; @@ -12853,7 +12230,7 @@ END sub process_extracted_files { my ($context,$docudom,$docuname,$destination,$dir_root,$hiddenelem) = @_; my $numitems = $env{'form.archive_count'}; - return if ((!$numitems) || ($numitems =~ /\D/)); + return unless ($numitems); my @ids=&Apache::lonnet::current_machine_ids(); my ($prefix,$pathtocheck,$dir,$ishome,$error,$warning,%toplevelitems,%is_dir, %folders,%containers,%mapinner,%prompttofetch); @@ -12866,7 +12243,7 @@ sub process_extracted_files { } else { $prefix = $Apache::lonnet::perlvar{'lonDocRoot'}; $pathtocheck = "$dir_root/$docudom/$docuname/$destination"; - $dir = "$dir_root/$docudom/$docuname"; + $dir = "$dir_root/$docudom/$docuname"; } my $currdir = "$dir_root/$destination"; (my $docstype,$mapinner{'0'}) = ($destination =~ m{^(docs|supplemental)/(\w+)/}); @@ -12875,7 +12252,7 @@ sub process_extracted_files { $folders{'0'} = $items[-2]; if ($env{'form.folderpath'} =~ /\:1$/) { $containers{'0'}='page'; - } else { + } else { $containers{'0'}='sequence'; } } @@ -12955,9 +12332,7 @@ sub process_extracted_files { '.'.$containers{$outer},1,1); $newseqid{$i} = $newidx; unless ($errtext) { - $result .= '
  • '.&mt('Folder: [_1] added to course', - &HTML::Entities::encode($docstitle,'<>&"')).. - '
  • '."\n"; + $result .= '
  • '.&mt('Folder: [_1] added to course',$docstitle).'
  • '."\n"; } } } else { @@ -12966,47 +12341,38 @@ sub process_extracted_files { my $url = '/uploaded/'.$docudom.'/'.$docuname.'/'. $docstype.'/'.$mapinner{$outer}.'/'.$newidx.'/'. $title; - if (($outer !~ /\D/) && ($mapinner{$outer} !~ /\D/) && ($newidx !~ /\D/)) { - if (!-e "$prefix$dir/$docstype/$mapinner{$outer}") { - mkdir("$prefix$dir/$docstype/$mapinner{$outer}",0755); - } - if (!-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx") { - mkdir("$prefix$dir/$docstype/$mapinner{$outer}/$newidx"); - } - if (-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx") { - if (rename("$prefix$path","$prefix$dir/$docstype/$mapinner{$outer}/$newidx/$title")) { - $newdest{$i} = "$prefix$dir/$docstype/$mapinner{$outer}/$newidx"; - unless ($ishome) { - my $fetch = "$newdest{$i}/$title"; - $fetch =~ s/^\Q$prefix$dir\E//; - $prompttofetch{$fetch} = 1; - } - } + if (!-e "$prefix$dir/$docstype/$mapinner{$outer}") { + mkdir("$prefix$dir/$docstype/$mapinner{$outer}",0755); + } + if (!-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx") { + mkdir("$prefix$dir/$docstype/$mapinner{$outer}/$newidx"); + } + if (-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx") { + system("mv $prefix$path $prefix$dir/$docstype/$mapinner{$outer}/$newidx/$title"); + $newdest{$i} = "$prefix$dir/$docstype/$mapinner{$outer}/$newidx"; + unless ($ishome) { + my $fetch = "$newdest{$i}/$title"; + $fetch =~ s/^\Q$prefix$dir\E//; + $prompttofetch{$fetch} = 1; } - $LONCAPA::map::resources[$newidx]= - $docstitle.':'.$url.':false:normal:res'; - push(@LONCAPA::map::order, $newidx); - my ($outtext,$errtext)= - &LONCAPA::map::storemap('/uploaded/'.$docudom.'/'. - $docuname.'/'.$folders{$outer}. - '.'.$containers{$outer},1,1); - unless ($errtext) { - if (-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx/$title") { - $result .= '
  • '.&mt('File: [_1] added to course', - &HTML::Entities::encode($docstitle,'<>&"')). - '
  • '."\n"; - } + } + $LONCAPA::map::resources[$newidx]= + $docstitle.':'.$url.':false:normal:res'; + push(@LONCAPA::map::order, $newidx); + my ($outtext,$errtext)= + &LONCAPA::map::storemap('/uploaded/'.$docudom.'/'. + $docuname.'/'.$folders{$outer}. + '.'.$containers{$outer},1,1); + unless ($errtext) { + if (-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx/$title") { + $result .= '
  • '.&mt('File: [_1] added to course',$docstitle).'
  • '."\n"; } - } else { - $warning .= &mt('Item extracted from archive: [_1] has unexpected path.', - &HTML::Entities::encode($path,'<>&"')).'
    '; } } } } } else { - $warning .= &mt('Item extracted from archive: [_1] has unexpected path.', - &HTML::Entities::encode($path,'<>&"')).'
    '; + $warning .= &mt('Item extracted from archive: [_1] has unexpected path.',$path).'
    '; } } for (my $i=1; $i<=$numitems; $i++) { @@ -13028,7 +12394,7 @@ sub process_extracted_files { } if ($itemidx eq '') { $itemidx = 0; - } + } if (grep(/^\Q$referrer{$i}\E$/,@archdirs)) { if ($mapinner{$referrer{$i}}) { $fullpath = "$prefix$dir/$docstype/$mapinner{$referrer{$i}}"; @@ -13067,9 +12433,7 @@ sub process_extracted_files { } if ($fullpath ne '') { if (-e "$prefix$path") { - unless (rename("$prefix$path","$fullpath/$title")) { - $warning .= &mt('Failed to rename dependency').'
    '; - } + system("mv $prefix$path $fullpath/$title"); } if (-e "$fullpath/$title") { my $showpath; @@ -13077,27 +12441,22 @@ sub process_extracted_files { $showpath = "$relpath/$title"; } else { $showpath = "/$title"; - } - $result .= '
  • '.&mt('[_1] included as a dependency', - &HTML::Entities::encode($showpath,'<>&"')). - '
  • '."\n"; - unless ($ishome) { - my $fetch = "$fullpath/$title"; - $fetch =~ s/^\Q$prefix$dir\E//; - $prompttofetch{$fetch} = 1; - } + } + $result .= '
  • '.&mt('[_1] included as a dependency',$showpath).'
  • '."\n"; + } + unless ($ishome) { + my $fetch = "$fullpath/$title"; + $fetch =~ s/^\Q$prefix$dir\E//; + $prompttofetch{$fetch} = 1; } } } } elsif ($env{'form.archive_'.$referrer{$i}} eq 'discard') { $warning .= &mt('[_1] is a dependency of [_2], which was discarded.', - &HTML::Entities::encode($path,'<>&"'), - &HTML::Entities::encode($env{'form.archive_content_'.$referrer{$i}},'<>&"')). - '
    '; + $path,$env{'form.archive_content_'.$referrer{$i}}).'
    '; } } else { - $warning .= &mt('Item extracted from archive: [_1] has unexpected path.', - &HTML::Entities::encode($path)).'
    '; + $warning .= &mt('Item extracted from archive: [_1] has unexpected path.',$path).'
    '; } } if (keys(%todelete)) { @@ -13371,15 +12730,12 @@ sub upfile_store { $env{'form.upfile'}=~s/\n+/\n/gs; $env{'form.upfile'}=~s/\n+$//gs; - my $datatoken = &valid_datatoken($env{'user.name'}.'_'.$env{'user.domain'}. - '_enroll_'.$env{'request.course.id'}.'_'. - time.'_'.$$); - return if ($datatoken eq ''); - + 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) ) { + if ( open(my $fh,">$datafile") ) { print $fh $env{'form.upfile'}; close($fh); } @@ -13389,22 +12745,21 @@ sub upfile_store { =pod -=item * &load_tmp_file($r,$datatoken) +=item * &load_tmp_file($r) Load uploaded file from tmp, $r should be the HTTP Request object, -$datatoken is the name to assign to the temporary file. +needs $env{'form.datatoken'}, sets $env{'form.upfile'} to the contents of the file =cut sub load_tmp_file { - my ($r,$datatoken) = @_; - return if ($datatoken eq ''); + my $r=shift; my @studentdata=(); { my $studentfile = $r->dir_config('lonDaemons'). - '/tmp/'.$datatoken.'.tmp'; - if ( open(my $fh,'<',$studentfile) ) { + '/tmp/'.$env{'form.datatoken'}.'.tmp'; + if ( open(my $fh,"<$studentfile") ) { @studentdata=<$fh>; close($fh); } @@ -13412,14 +12767,6 @@ sub load_tmp_file { $env{'form.upfile'}=join('',@studentdata); } -sub valid_datatoken { - my ($datatoken) = @_; - if ($datatoken =~ /^$match_username\_$match_domain\_enroll_(|$match_domain\_$match_courseid)\_\d+_\d+$/) { - return $datatoken; - } - return; -} - =pod =item * &upfile_record_sep() @@ -13860,7 +13207,7 @@ sub DrawBarGraph { @Labels = @$labels; } else { for (my $i=0;$i<@{$Values[0]};$i++) { - push(@Labels,$i+1); + push (@Labels,$i+1); } } # @@ -14299,20 +13646,14 @@ generated by lonerrorhandler.pm, CHECKRP lonsupportreq.pm, loncoursequeueadmin.pm, searchcat.pl respectively. Inputs: -defmail (scalar - email address of default recipient), +defmail (scalar - email address of default recipient), mailing type (scalar: errormail, packagesmail, helpdeskmail, requestsmail, updatesmail, or idconflictsmail). defdom (domain for which to retrieve configuration settings), -origmail (scalar - email address of recipient from loncapa.conf, -i.e., predates configuration by DC via domainprefs.pm - -$requname username of requester (if mailing type is helpdeskmail) - -$requdom domain of requester (if mailing type is helpdeskmail) - -$reqemail e-mail address of requester (if mailing type is helpdeskmail) +origmail (scalar - email address of recipient from loncapa.conf, +i.e., predates configuration by DC via domainprefs.pm Returns: comma separated list of addresses to which to send e-mail. @@ -14323,11 +13664,11 @@ Returns: comma separated list of address ############################################################ ############################################################ sub build_recipient_list { - my ($defmail,$mailing,$defdom,$origmail,$requname,$requdom,$reqemail) = @_; + my ($defmail,$mailing,$defdom,$origmail) = @_; my @recipients; - my ($otheremails,$lastresort,$allbcc,$addtext); + my $otheremails; my %domconfig = - &Apache::lonnet::get_dom('configuration',['contacts'],$defdom); + &Apache::lonnet::get_dom('configuration',['contacts'],$defdom); if (ref($domconfig{'contacts'}) eq 'HASH') { if (exists($domconfig{'contacts'}{$mailing})) { if (ref($domconfig{'contacts'}{$mailing}) eq 'HASH') { @@ -14339,183 +13680,14 @@ sub build_recipient_list { push(@recipients,$addr); } } - } - $otheremails = $domconfig{'contacts'}{$mailing}{'others'}; - if ($mailing eq 'helpdeskmail') { - if ($domconfig{'contacts'}{$mailing}{'bcc'}) { - my @bccs = split(/,/,$domconfig{'contacts'}{$mailing}{'bcc'}); - my @ok_bccs; - foreach my $bcc (@bccs) { - $bcc =~ s/^\s+//g; - $bcc =~ s/\s+$//g; - if ($bcc =~ m/^[^\@]+\@[^\@]+$/) { - if (!(grep(/^\Q$bcc\E$/,@ok_bccs))) { - push(@ok_bccs,$bcc); - } - } - } - if (@ok_bccs > 0) { - $allbcc = join(', ',@ok_bccs); - } - } - $addtext = $domconfig{'contacts'}{$mailing}{'include'}; + $otheremails = $domconfig{'contacts'}{$mailing}{'others'}; } } } elsif ($origmail ne '') { - $lastresort = $origmail; - } - if ($mailing eq 'helpdeskmail') { - if ((ref($domconfig{'contacts'}{'overrides'}) eq 'HASH') && - (keys(%{$domconfig{'contacts'}{'overrides'}}))) { - my ($inststatus,$inststatus_checked); - if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '') && - ($env{'user.domain'} ne 'public')) { - $inststatus_checked = 1; - $inststatus = $env{'environment.inststatus'}; - } - unless ($inststatus_checked) { - if (($requname ne '') && ($requdom ne '')) { - if (($requname =~ /^$match_username$/) && - ($requdom =~ /^$match_domain$/) && - (&Apache::lonnet::domain($requdom))) { - my $requhome = &Apache::lonnet::homeserver($requname, - $requdom); - unless ($requhome eq 'no_host') { - my %userenv = &Apache::lonnet::userenvironment($requdom,$requname,'inststatus'); - $inststatus = $userenv{'inststatus'}; - $inststatus_checked = 1; - } - } - } - } - unless ($inststatus_checked) { - if ($reqemail =~ /^[^\@]+\@[^\@]+$/) { - my %srch = (srchby => 'email', - srchdomain => $defdom, - srchterm => $reqemail, - srchtype => 'exact'); - my %srch_results = &Apache::lonnet::usersearch(\%srch); - foreach my $uname (keys(%srch_results)) { - if (ref($srch_results{$uname}{'inststatus'}) eq 'ARRAY') { - $inststatus = join(',',@{$srch_results{$uname}{'inststatus'}}); - $inststatus_checked = 1; - last; - } - } - unless ($inststatus_checked) { - my ($dirsrchres,%srch_results) = &Apache::lonnet::inst_directory_query(\%srch); - if ($dirsrchres eq 'ok') { - foreach my $uname (keys(%srch_results)) { - if (ref($srch_results{$uname}{'inststatus'}) eq 'ARRAY') { - $inststatus = join(',',@{$srch_results{$uname}{'inststatus'}}); - $inststatus_checked = 1; - last; - } - } - } - } - } - } - if ($inststatus ne '') { - foreach my $status (split(/\:/,$inststatus)) { - if (ref($domconfig{'contacts'}{'overrides'}{$status}) eq 'HASH') { - my @contacts = ('adminemail','supportemail'); - foreach my $item (@contacts) { - if ($domconfig{'contacts'}{'overrides'}{$status}{$item}) { - my $addr = $domconfig{'contacts'}{'overrides'}{$status}; - if (!grep(/^\Q$addr\E$/,@recipients)) { - push(@recipients,$addr); - } - } - } - $otheremails = $domconfig{'contacts'}{'overrides'}{$status}{'others'}; - if ($domconfig{'contacts'}{'overrides'}{$status}{'bcc'}) { - my @bccs = split(/,/,$domconfig{'contacts'}{'overrides'}{$status}{'bcc'}); - my @ok_bccs; - foreach my $bcc (@bccs) { - $bcc =~ s/^\s+//g; - $bcc =~ s/\s+$//g; - if ($bcc =~ m/^[^\@]+\@[^\@]+$/) { - if (!(grep(/^\Q$bcc\E$/,@ok_bccs))) { - push(@ok_bccs,$bcc); - } - } - } - if (@ok_bccs > 0) { - $allbcc = join(', ',@ok_bccs); - } - } - $addtext = $domconfig{'contacts'}{'overrides'}{$status}{'include'}; - last; - } - } - } - } + push(@recipients,$origmail); } } elsif ($origmail ne '') { - $lastresort = $origmail; - } - if (($mailing eq 'helpdeskmail') && ($lastresort ne '')) { - unless (grep(/^\Q$defdom\E$/,&Apache::lonnet::current_machine_domains())) { - my $lonhost = $Apache::lonnet::perlvar{'lonHostID'}; - my $machinedom = $Apache::lonnet::perlvar{'lonDefDomain'}; - my %what = ( - perlvar => 1, - ); - my $primary = &Apache::lonnet::domain($defdom,'primary'); - if ($primary) { - my $gotaddr; - my ($result,$returnhash) = - &Apache::lonnet::get_remote_globals($primary,{ perlvar => 1 }); - if (($result eq 'ok') && (ref($returnhash) eq 'HASH')) { - if ($returnhash->{'lonSupportEMail'} =~ /^[^\@]+\@[^\@]+$/) { - $lastresort = $returnhash->{'lonSupportEMail'}; - $gotaddr = 1; - } - } - unless ($gotaddr) { - my $uintdom = &Apache::lonnet::internet_dom($primary); - my $intdom = &Apache::lonnet::internet_dom($lonhost); - unless ($uintdom eq $intdom) { - my %domconfig = - &Apache::lonnet::get_dom('configuration',['contacts'],$machinedom); - if (ref($domconfig{'contacts'}) eq 'HASH') { - if (ref($domconfig{'contacts'}{'otherdomsmail'}) eq 'HASH') { - my @contacts = ('adminemail','supportemail'); - foreach my $item (@contacts) { - if ($domconfig{'contacts'}{'otherdomsmail'}{$item}) { - my $addr = $domconfig{'contacts'}{$item}; - if (!grep(/^\Q$addr\E$/,@recipients)) { - push(@recipients,$addr); - } - } - } - if ($domconfig{'contacts'}{'otherdomsmail'}{'others'}) { - $otheremails = $domconfig{'contacts'}{'otherdomsmail'}{'others'}; - } - if ($domconfig{'contacts'}{'otherdomsmail'}{'bcc'}) { - my @bccs = split(/,/,$domconfig{'contacts'}{'otherdomsmail'}{'bcc'}); - my @ok_bccs; - foreach my $bcc (@bccs) { - $bcc =~ s/^\s+//g; - $bcc =~ s/\s+$//g; - if ($bcc =~ m/^[^\@]+\@[^\@]+$/) { - if (!(grep(/^\Q$bcc\E$/,@ok_bccs))) { - push(@ok_bccs,$bcc); - } - } - } - if (@ok_bccs > 0) { - $allbcc = join(', ',@ok_bccs); - } - } - $addtext = $domconfig{'contacts'}{'otherdomsmail'}{'include'}; - } - } - } - } - } - } + push(@recipients,$origmail); } if (defined($defmail)) { if ($defmail ne '') { @@ -14535,21 +13707,8 @@ sub build_recipient_list { } } } - if ($mailing eq 'helpdeskmail') { - if ((!@recipients) && ($lastresort ne '')) { - push(@recipients,$lastresort); - } - } elsif ($lastresort ne '') { - if (!grep(/^\Q$lastresort\E$/,@recipients)) { - push(@recipients,$lastresort); - } - } - my $recipientlist = join(',',@recipients); - if (wantarray) { - return ($recipientlist,$allbcc,$addtext); - } else { - return $recipientlist; - } + my $recipientlist = join(',',@recipients); + return $recipientlist; } ############################################################ @@ -14640,8 +13799,6 @@ jsarray (reference to array of categorie subcats (reference to hash of arrays containing all subcategories within each category, -recursive) -maxd (reference to hash used to hold max depth for all top-level categories). - Returns: nothing Side effects: populates trails and allitems hash references. @@ -14649,7 +13806,7 @@ Side effects: populates trails and allit =cut sub extract_categories { - my ($categories,$cats,$trails,$allitems,$idx,$jsarray,$subcats,$maxd) = @_; + my ($categories,$cats,$trails,$allitems,$idx,$jsarray,$subcats) = @_; if (ref($categories) eq 'HASH') { &gather_categories($categories,$cats,$idx,$jsarray); if (ref($cats->[0]) eq 'ARRAY') { @@ -14675,15 +13832,12 @@ sub extract_categories { if (ref($subcats) eq 'HASH') { push(@{$subcats->{$item}},&escape($category).':'.&escape($name).':1'); } - &recurse_categories($cats,2,$category,$trails,$allitems,\@parents,$subcats,$maxd); + &recurse_categories($cats,2,$category,$trails,$allitems,\@parents,$subcats); } } else { if (ref($subcats) eq 'HASH') { $subcats->{$item} = []; } - if (ref($maxd) eq 'HASH') { - $maxd->{$name} = 1; - } } } } @@ -14721,7 +13875,7 @@ Side effects: populates trails and allit =cut sub recurse_categories { - my ($cats,$depth,$category,$trails,$allitems,$parents,$subcats,$maxd) = @_; + my ($cats,$depth,$category,$trails,$allitems,$parents,$subcats) = @_; my $shallower = $depth - 1; if (ref($cats->[$depth]{$category}) eq 'ARRAY') { for (my $k=0; $k<@{$cats->[$depth]{$category}}; $k++) { @@ -14748,21 +13902,16 @@ sub recurse_categories { } } &recurse_categories($cats,$deeper,$name,$trails,$allitems,$parents, - $subcats,$maxd); + $subcats); pop(@{$parents}); } } else { my $item = &escape($category).':'.&escape($parents->[-1]).':'.$shallower; - my $trailstr = join(' » ',(@{$parents},$category)); + my $trailstr = join(' -> ',(@{$parents},$category)); if ($allitems->{$item} eq '') { push(@{$trails},$trailstr); $allitems->{$item} = scalar(@{$trails})-1; } - if (ref($maxd) eq 'HASH') { - if ($depth > $maxd->{$parents->[0]}) { - $maxd->{$parents->[0]} = $depth; - } - } } return; } @@ -14783,19 +13932,16 @@ currcat - scalar with an & separated lis type - scalar contains course type (Course or Community). -disabled - scalar (optional) contains disabled="disabled" if input elements are - to be readonly (e.g., Domain Helpdesk role viewing course settings). - Returns: $output (markup to be displayed) =cut sub assign_categories_table { - my ($cathash,$currcat,$type,$disabled) = @_; + my ($cathash,$currcat,$type) = @_; my $output; if (ref($cathash) eq 'HASH') { - my (@cats,@trails,%allitems,%idx,@jsarray,%maxd,@path,$maxdepth); - &extract_categories($cathash,\@cats,\@trails,\%allitems,\%idx,\@jsarray,\%maxd); + my (@cats,@trails,%allitems,%idx,@jsarray,@path,$maxdepth); + &extract_categories($cathash,\@cats,\@trails,\%allitems,\%idx,\@jsarray); $maxdepth = scalar(@cats); if (@cats > 0) { my $itemcount = 0; @@ -14827,11 +13973,11 @@ sub assign_categories_table { } $table .= ''. ''.$parent_title.''. + $item.'"'.$checked.' />'.$parent_title.''. ''; my $depth = 1; push(@path,$parent); - $table .= &assign_category_rows($itemcount,\@cats,$depth,$parent,\@path,\@currcategories,$disabled); + $table .= &assign_category_rows($itemcount,\@cats,$depth,$parent,\@path,\@currcategories); pop(@path); $table .= ''; $itemcount ++; @@ -14870,15 +14016,12 @@ path - Array containing all categories b currcategories - reference to array of current categories assigned to the course -disabled - scalar (optional) contains disabled="disabled" if input elements are - to be readonly (e.g., Domain Helpdesk role viewing course settings). - Returns: $output (markup to be displayed). =cut sub assign_category_rows { - my ($itemcount,$cats,$depth,$parent,$path,$currcategories,$disabled) = @_; + my ($itemcount,$cats,$depth,$parent,$path,$currcategories) = @_; my ($text,$name,$item,$chgstr); if (ref($cats) eq 'ARRAY') { my $maxdepth = scalar(@{$cats}); @@ -14901,12 +14044,12 @@ sub assign_category_rows { } $text .= ''. + $item.'"'.$checked.' />'.$name.''. ''. ''; if (ref($path) eq 'ARRAY') { push(@{$path},$name); - $text .= &assign_category_rows($itemcount,$cats,$deeper,$name,$path,$currcategories,$disabled); + $text .= &assign_category_rows($itemcount,$cats,$deeper,$name,$path,$currcategories); pop(@{$path}); } $text .= ''; @@ -15054,7 +14197,7 @@ sub commit_studentrole { } } } else { - if ($secchange) { + if ($secchange) { $$logmsg .= &mt('Error when attempting section change for [_1] from old section "[_2]" to new section: "[_3]" in course [_4] -error:',$uname,$oldsec,$sec,$cid).' '.$modify_section_result.$linefeed; } else { $$logmsg .= &mt('Error when attempting to modify role for [_1] for section: "[_2]" in course [_3] -error:',$uname,$sec,$cid).' '.$modify_section_result.$linefeed; @@ -15137,95 +14280,37 @@ sub check_clone { return ($can_clone, $clonemsg, $cloneid, $clonehome); } } - if (($env{'request.role.domain'} eq $args->{'clonedomain'}) && + if (($env{'request.role.domain'} eq $args->{'clonedomain'}) && (&Apache::lonnet::allowed('ccc',$env{'request.role.domain'}))) { $can_clone = 1; } else { - my %clonehash = &Apache::lonnet::get('environment',['cloners','internal.coursecode'], + my %clonehash = &Apache::lonnet::get('environment',['cloners'], $args->{'clonedomain'},$args->{'clonecourse'}); - if ($clonehash{'cloners'} eq '') { - my %domdefs = &Apache::lonnet::get_domain_defaults($args->{'course_domain'}); - if ($domdefs{'canclone'}) { - unless ($domdefs{'canclone'} eq 'none') { - if ($domdefs{'canclone'} eq 'domain') { - if ($args->{'ccdomain'} eq $args->{'clonedomain'}) { - $can_clone = 1; - } - } elsif (($clonehash{'internal.coursecode'}) && ($args->{'crscode'}) && - ($args->{'clonedomain'} eq $args->{'course_domain'})) { - if (&Apache::lonnet::default_instcode_cloning($args->{'clonedomain'},$domdefs{'canclone'}, - $clonehash{'internal.coursecode'},$args->{'crscode'})) { - $can_clone = 1; - } - } - } - } + my @cloners = split(/,/,$clonehash{'cloners'}); + if (grep(/^\*$/,@cloners)) { + $can_clone = 1; + } elsif (grep(/^\*\:\Q$args->{'ccdomain'}\E$/,@cloners)) { + $can_clone = 1; } else { - my @cloners = split(/,/,$clonehash{'cloners'}); - if (grep(/^\*$/,@cloners)) { - $can_clone = 1; - } elsif (grep(/^\*\:\Q$args->{'ccdomain'}\E$/,@cloners)) { - $can_clone = 1; - } elsif (grep(/^\Q$args->{'ccuname'}\E:\Q$args->{'ccdomain'}\E$/,@cloners)) { - $can_clone = 1; - } - unless ($can_clone) { - if (($clonehash{'internal.coursecode'}) && ($args->{'crscode'}) && - ($args->{'clonedomain'} eq $args->{'course_domain'})) { - my (%gotdomdefaults,%gotcodedefaults); - foreach my $cloner (@cloners) { - if (($cloner ne '*') && ($cloner !~ /^\*\:$match_domain$/) && - ($cloner !~ /^$match_username\:$match_domain$/) && ($cloner ne '')) { - my (%codedefaults,@code_order); - if (ref($gotcodedefaults{$args->{'clonedomain'}}) eq 'HASH') { - if (ref($gotcodedefaults{$args->{'clonedomain'}}{'defaults'}) eq 'HASH') { - %codedefaults = %{$gotcodedefaults{$args->{'clonedomain'}}{'defaults'}}; - } - if (ref($gotcodedefaults{$args->{'clonedomain'}}{'order'}) eq 'ARRAY') { - @code_order = @{$gotcodedefaults{$args->{'clonedomain'}}{'order'}}; - } - } else { - &Apache::lonnet::auto_instcode_defaults($args->{'clonedomain'}, - \%codedefaults, - \@code_order); - $gotcodedefaults{$args->{'clonedomain'}}{'defaults'} = \%codedefaults; - $gotcodedefaults{$args->{'clonedomain'}}{'order'} = \@code_order; - } - if (@code_order > 0) { - if (&Apache::lonnet::check_instcode_cloning(\%codedefaults,\@code_order, - $cloner,$clonehash{'internal.coursecode'}, - $args->{'crscode'})) { - $can_clone = 1; - last; - } - } - } - } - } - } - } - unless ($can_clone) { my $ccrole = 'cc'; if ($args->{'crstype'} eq 'Community') { $ccrole = 'co'; } - my %roleshash = - &Apache::lonnet::get_my_roles($args->{'ccuname'}, - $args->{'ccdomain'}, - 'userroles',['active'],[$ccrole], - [$args->{'clonedomain'}]); - if ($roleshash{$args->{'clonecourse'}.':'.$args->{'clonedomain'}.':'.$ccrole}) { + my %roleshash = + &Apache::lonnet::get_my_roles($args->{'ccuname'}, + $args->{'ccdomain'}, + 'userroles',['active'],[$ccrole], + [$args->{'clonedomain'}]); + if (($roleshash{$args->{'clonecourse'}.':'.$args->{'clonedomain'}.':'.$ccrole}) || (grep(/^\Q$args->{'ccuname'}\E:\Q$args->{'ccdomain'}\E$/,@cloners))) { $can_clone = 1; - } elsif (&Apache::lonnet::is_course_owner($args->{'clonedomain'},$args->{'clonecourse'}, - $args->{'ccuname'},$args->{'ccdomain'})) { + } elsif (&Apache::lonnet::is_course_owner($args->{'clonedomain'},$args->{'clonecourse'},$args->{'ccuname'},$args->{'ccdomain'})) { $can_clone = 1; - } - } - unless ($can_clone) { - if ($args->{'crstype'} eq 'Community') { - $clonemsg = &mt('No new community created.').$linefeed.&mt('The new community could not be cloned from the existing community because the new community owner ([_1]) does not have cloning rights in the existing community ([_2]).',$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'}); } else { - $clonemsg = &mt('No new course created.').$linefeed.&mt('The new course could not be cloned from the existing course because the new course owner ([_1]) does not have cloning rights in the existing course ([_2]).',$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'}); + if ($args->{'crstype'} eq 'Community') { + $clonemsg = &mt('No new community created.').$linefeed.&mt('The new community could not be cloned from the existing community because the new community owner ([_1]) does not have cloning rights in the existing community ([_2]).',$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'}); + } else { + $clonemsg = &mt('No new course created.').$linefeed.&mt('The new course could not be cloned from the existing course because the new course owner ([_1]) does not have cloning rights in the existing course ([_2]).',$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'}); + } } } } @@ -15234,8 +14319,7 @@ sub check_clone { } sub construct_course { - my ($args,$logmsg,$courseid,$crsudom,$crsunum,$udom,$uname,$context, - $cnum,$category,$coderef) = @_; + my ($args,$logmsg,$courseid,$crsudom,$crsunum,$udom,$uname,$context,$cnum,$category,$coderef) = @_; my $outcome; my $linefeed = '
    '."\n"; if ($context eq 'auto') { @@ -15383,7 +14467,7 @@ sub construct_course { my $addcheck = &Apache::lonnet::auto_new_course($$crsunum,$$crsudom,$class,$cenv{'internal.courseowner'}); $cenv{'internal.sectionnums'} .= $item.','; unless ($addcheck eq 'ok') { - push(@badclasses,$class); + push @badclasses, $class; } } $cenv{'internal.sectionnums'} =~ s/,$//; @@ -15411,7 +14495,7 @@ sub construct_course { my $addcheck = &Apache::lonnet::auto_new_course($$crsunum,$$crsudom,$xl,$cenv{'internal.courseowner'}); $cenv{'internal.crosslistings'} .= $item.','; unless ($addcheck eq 'ok') { - push(@badclasses,$xl); + push @badclasses, $xl; } } $cenv{'internal.crosslistings'} =~ s/,$//; @@ -15446,29 +14530,28 @@ sub construct_course { } 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.', - 'howi' => 'However, if automated course roster updates are enabled for this class, these particular sections/crosslistings are not guaranteed to contribute towards enrollment.', - 'itis' => 'It is possible that rights to access enrollment for these classes will be available through assignment of co-owners.', + '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' ); - my $badclass_msg = $lt{'tclb'}.$linefeed.$lt{'howi'}.$linefeed. - &mt('That is because the user identified as the course owner ([_1]) does not have rights to access enrollment in these classes, as determined by the policies of your institution on access to official classlists',$cenv{'internal.courseowner'}).$linefeed.$lt{'itis'}; + my $badclass_msg = $cenv{'internal.courseowner'}.') - '.$lt{'dnhr'}. + ' ('.$lt{'adby'}.')'; if ($context eq 'auto') { $outcome .= $badclass_msg.$linefeed; - } else { $outcome .= '
    '.$badclass_msg.$linefeed.'
      '."\n"; - } - foreach my $item (@badclasses) { + foreach my $item (@badclasses) { + if ($context eq 'auto') { + $outcome .= " - $item\n"; + } else { + $outcome .= "
    • $item
    • \n"; + } + } if ($context eq 'auto') { - $outcome .= " - $item\n"; + $outcome .= $linefeed; } else { - $outcome .= "
    • $item
    • \n"; + $outcome .= "


    \n"; } - } - if ($context eq 'auto') { - $outcome .= $linefeed; - } else { - $outcome .= "

    \n"; - } + } } if ($args->{'no_end_date'}) { $args->{'endaccess'} = 0; @@ -15500,9 +14583,6 @@ sub construct_course { if ($args->{'setcontent'}) { $cenv{'question.email'}=$args->{'ccuname'}.':'.$args->{'ccdomain'}; } - if ($args->{'setcomment'}) { - $cenv{'comment.email'}=$args->{'ccuname'}.':'.$args->{'ccdomain'}; - } } if ($args->{'reshome'}) { $cenv{'reshome'}=$args->{'reshome'}.'/'; @@ -15537,7 +14617,7 @@ sub construct_course { if (ref($crsinfo{$$crsudom.'_'.$$crsunum}) eq 'HASH') { $crsinfo{$$crsudom.'_'.$$crsunum}{'uniquecode'} = $code; my $putres = &Apache::lonnet::courseidput($$crsudom,\%crsinfo,$crsuhome,'notime'); - } + } if (ref($coderef)) { $$coderef = $code; } @@ -15574,17 +14654,12 @@ sub construct_course { # Open all assignments # if ($args->{'openall'}) { - my $opendate = time; - if ($args->{'openallfrom'} =~ /^\d+$/) { - $opendate = $args->{'openallfrom'}; - } my $storeunder=$$crsudom.'_'.$$crsunum.'.0.opendate'; - my %storecontent = ($storeunder => $opendate, + my %storecontent = ($storeunder => time, $storeunder.'.type' => 'date_start'); - $outcome .= &mt('All assignments open starting [_1]', - &Apache::lonlocal::locallocaltime($opendate)).': '. - &Apache::lonnet::cput - ('resourcedata',\%storecontent,$$crsudom,$$crsunum).$linefeed; + + $outcome .= &mt('Opening all assignments').': '.&Apache::lonnet::cput + ('resourcedata',\%storecontent,$$crsudom,$$crsunum).$linefeed; } # # Set first page @@ -15627,7 +14702,7 @@ sub make_unique_code { my $tries = 0; my $gotlock = &Apache::lonnet::newput_dom('uniquecodes',$lockhash,$cdom); my ($code,$error); - + while (($gotlock ne 'ok') && ($tries<3)) { $tries ++; sleep 1; @@ -15818,23 +14893,7 @@ sub init_user_environment { opendir(DIR,$lonids); while ($filename=readdir(DIR)) { if ($filename=~/^$username\_\d+\_$domain\_$authhost\.id$/) { - if (tie(my %oldenv,'GDBM_File',"$lonids/$filename", - &GDBM_READER(),0640)) { - my $linkedfile; - if (exists($oldenv{'user.linkedenv'})) { - $linkedfile = $oldenv{'user.linkedenv'}; - } - untie(%oldenv); - if (unlink("$lonids/$filename")) { - if ($linkedfile =~ /^[a-f0-9]+_linked$/) { - if (-l "$lonids/$linkedfile.id") { - unlink("$lonids/$linkedfile.id"); - } - } - } - } else { - unlink($lonids.'/'.$filename); - } + unlink($lonids.'/'.$filename); } } closedir(DIR); @@ -15922,44 +14981,36 @@ sub init_user_environment { $env{'user.noloadbalance'} = $lonhost; } - if ($form->{'noloadbalance'}) { - my @hosts = &Apache::lonnet::current_machine_ids(); - my $hosthere = $form->{'noloadbalance'}; - if (grep(/^\Q$hosthere\E$/,@hosts)) { - $initial_env{"user.noloadbalance"} = $hosthere; - $env{'user.noloadbalance'} = $hosthere; - } - } - + my %is_adv = ( is_adv => $env{'user.adv'} ); + my %domdef; unless ($domain eq 'public') { - my %is_adv = ( is_adv => $env{'user.adv'} ); - my %domdef = &Apache::lonnet::get_domain_defaults($domain); - - foreach my $tool ('aboutme','blog','webdav','portfolio') { - $userenv{'availabletools.'.$tool} = - &Apache::lonnet::usertools_access($username,$domain,$tool,'reload', - undef,\%userenv,\%domdef,\%is_adv); - } + %domdef = &Apache::lonnet::get_domain_defaults($domain); + } - foreach my $crstype ('official','unofficial','community','textbook') { - $userenv{'canrequest.'.$crstype} = - &Apache::lonnet::usertools_access($username,$domain,$crstype, - 'reload','requestcourses', - \%userenv,\%domdef,\%is_adv); - } + foreach my $tool ('aboutme','blog','webdav','portfolio') { + $userenv{'availabletools.'.$tool} = + &Apache::lonnet::usertools_access($username,$domain,$tool,'reload', + undef,\%userenv,\%domdef,\%is_adv); + } - $userenv{'canrequest.author'} = - &Apache::lonnet::usertools_access($username,$domain,'requestauthor', - 'reload','requestauthor', + foreach my $crstype ('official','unofficial','community','textbook') { + $userenv{'canrequest.'.$crstype} = + &Apache::lonnet::usertools_access($username,$domain,$crstype, + 'reload','requestcourses', \%userenv,\%domdef,\%is_adv); - my %reqauthor = &Apache::lonnet::get('requestauthor',['author_status','author'], - $domain,$username); - my $reqstatus = $reqauthor{'author_status'}; - if ($reqstatus eq 'approval' || $reqstatus eq 'approved') { - if (ref($reqauthor{'author'}) eq 'HASH') { - $userenv{'requestauthorqueued'} = $reqstatus.':'. - $reqauthor{'author'}{'timestamp'}; - } + } + + $userenv{'canrequest.author'} = + &Apache::lonnet::usertools_access($username,$domain,'requestauthor', + 'reload','requestauthor', + \%userenv,\%domdef,\%is_adv); + my %reqauthor = &Apache::lonnet::get('requestauthor',['author_status','author'], + $domain,$username); + my $reqstatus = $reqauthor{'author_status'}; + if ($reqstatus eq 'approval' || $reqstatus eq 'approved') { + if (ref($reqauthor{'author'}) eq 'HASH') { + $userenv{'requestauthorqueued'} = $reqstatus.':'. + $reqauthor{'author'}{'timestamp'}; } } @@ -16066,12 +15117,12 @@ and quotacheck.pl Inputs: -filterlist - anonymous array of fields to include as potential filters +filterlist - anonymous array of fields to include as potential filters crstype - course type roleelement - fifth arg in selectcourse_link() populates fifth arg in javascript: opencrsbrowser() function, used - to pop-open a course selector (will contain "extra element"). + to pop-open a course selector (will contain "extra element"). multelement - if multiple course selections will be allowed, this will be a hidden form element: name: multiple; value: 1 @@ -16087,19 +15138,19 @@ cloneruname - username of owner of new c clonerudom - domain of owner of new course who wants to clone -typeelem - text to use for left column in row containing course type (i.e., Course, Community or Course/Community) +typeelem - text to use for left column in row containing course type (i.e., Course, Community or Course/Community) codetitlesref - reference to array of titles of components in institutional codes (official courses) codedom - domain -formname - value of form element named "form". +formname - value of form element named "form". fixeddom - domain, if fixed. -prevphase - value to assign to form element named "phase" when going back to the previous screen +prevphase - value to assign to form element named "phase" when going back to the previous screen -cnameelement - name of form element in form on opener page which will receive title of selected course +cnameelement - name of form element in form on opener page which will receive title of selected course cnumelement - name of form element in form on opener page which will receive courseID of selected course @@ -16241,7 +15292,7 @@ sub build_filters { if (exists($filter->{'instcodefilter'})) { # if (($fixeddom) || ($formname eq 'requestcrs') || # ($formname eq 'modifycourse') || ($formname eq 'filterpicker')) { - if ($codedom) { + if ($codedom) { $officialjs = 1; ($instcodeform,$jscript,$$numtitlesref) = &Apache::courseclassifier::instcode_selectors($codedom,'filterpicker', @@ -16370,7 +15421,7 @@ $typeelement return $jscript.$clonewarning.$output; } -=pod +=pod =item * &timebased_select_form() @@ -16385,7 +15436,7 @@ item - name of form element (sincefilter filter - anonymous hash of criteria and their values Returns: HTML for a select box contained a blank, then six time selections, - with value set in incoming form variables currently selected. + with value set in incoming form variables currently selected. Side Effects: None @@ -16422,7 +15473,7 @@ page load completion for page showing se Inputs: None -Returns: markup containing updateFilters() and hideSearching() javascript functions. +Returns: markup containing updateFilters() and hideSearching() javascript functions. Side Effects: None @@ -16461,7 +15512,7 @@ to retrieve a hash for which keys are co Inputs: -dom - domain being searched +dom - domain being searched type - course type ('Course' or 'Community' or '.' if any). @@ -16473,18 +15524,11 @@ cloneruname - optional username of new c clonerudom - optional domain of new course owner -domcloner - optional "domcloner" flag; has value=1 if user has ccc priv in domain being filtered by, +domcloner - Optional "domcloner" flag; has value=1 if user has ccc priv in domain being filtered by, (used when DC is using course creation form) codetitles - reference to array of titles of components in institutional codes (official courses). -cc_clone - escaped comma separated list of courses for which course cloner has active CC role - (and so can clone automatically) - -reqcrsdom - domain of new course, where search_courses is used to identify potential courses to clone - -reqinstcode - institutional code of new course, where search_courses is used to identify potential - courses to clone Returns: %courses - hash of courses satisfying search criteria, keys = course IDs, values are corresponding colon-separated escaped description, institutional code, owner and type. @@ -16495,8 +15539,7 @@ Side Effects: None sub search_courses { - my ($dom,$type,$filter,$numtitles,$cloneruname,$clonerudom,$domcloner,$codetitles, - $cc_clone,$reqcrsdom,$reqinstcode) = @_; + my ($dom,$type,$filter,$numtitles,$cloneruname,$clonerudom,$domcloner,$codetitles) = @_; my (%courses,%showcourses,$cloner); if (($filter->{'ownerfilter'} ne '') || ($filter->{'ownerdomfilter'} ne '')) { @@ -16544,10 +15587,10 @@ sub search_courses { $filter->{'combownerfilter'}, $filter->{'coursefilter'}, undef,undef,$type,$regexpok,undef,undef, - undef,undef,$cloner,$cc_clone, + undef,undef,$cloner,$env{'form.cc_clone'}, $filter->{'cloneableonly'}, $createdbefore,$createdafter,undef, - $domcloner,undef,$reqcrsdom,$reqinstcode); + $domcloner); if (($filter->{'personfilter'} ne '') && ($filter->{'persondomfilter'} ne '')) { my $ccrole; if ($type eq 'Community') { @@ -16567,7 +15610,7 @@ sub search_courses { if (ref($courses{$cid}) eq 'HASH') { if (ref($courses{$cid}{roles}) eq 'ARRAY') { if (!grep(/^\Q$courserole\E$/,@{$courses{$cid}{roles}})) { - push(@{$courses{$cid}{roles}},$courserole); + push (@{$courses{$cid}{roles}},$courserole); } } else { $courses{$cid}{roles} = [$courserole]; @@ -16585,206 +15628,8 @@ sub search_courses { =back -=head1 Routines for version requirements for current course. - -=over 4 - -=item * &check_release_required() - -Compares required LON-CAPA version with version on server, and -if required version is newer looks for a server with the required version. - -Looks first at servers in user's owen domain; if none suitable, looks at -servers in course's domain are permitted to host sessions for user's domain. - -Inputs: - -$loncaparev - Version on current server (format: Major.Minor.Subrelease-datestamp) - -$courseid - Course ID of current course - -$rolecode - User's current role in course (for switchserver query string). - -$required - LON-CAPA version needed by course (format: Major.Minor). - - -Returns: - -$switchserver - query string tp append to /adm/switchserver call (if - current server's LON-CAPA version is too old. - -$warning - Message is displayed if no suitable server could be found. - -=cut - -sub check_release_required { - my ($loncaparev,$courseid,$rolecode,$required) = @_; - my ($switchserver,$warning); - if ($required ne '') { - my ($reqdmajor,$reqdminor) = ($required =~ /^(\d+)\.(\d+)$/); - my ($major,$minor) = ($loncaparev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/); - if ($reqdmajor ne '' && $reqdminor ne '') { - my $otherserver; - if (($major eq '' && $minor eq '') || - (($reqdmajor > $major) || (($reqdmajor == $major) && ($reqdminor > $minor)))) { - my ($userdomserver) = &Apache::lonnet::choose_server($env{'user.domain'},undef,$required,1); - my $switchlcrev = - &Apache::lonnet::get_server_loncaparev($env{'user.domain'}, - $userdomserver); - my ($swmajor,$swminor) = ($switchlcrev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?$/); - if (($swmajor eq '' && $swminor eq '') || ($reqdmajor > $swmajor) || - (($reqdmajor == $swmajor) && ($reqdminor > $swminor))) { - my $cdom = $env{'course.'.$courseid.'.domain'}; - if ($cdom ne $env{'user.domain'}) { - my ($coursedomserver,$coursehostname) = &Apache::lonnet::choose_server($cdom,undef,$required,1); - my $serverhomeID = &Apache::lonnet::get_server_homeID($coursehostname); - my $serverhomedom = &Apache::lonnet::host_domain($serverhomeID); - my %defdomdefaults = &Apache::lonnet::get_domain_defaults($serverhomedom); - my %udomdefaults = &Apache::lonnet::get_domain_defaults($env{'user.domain'}); - my $remoterev = &Apache::lonnet::get_server_loncaparev($serverhomedom,$coursedomserver); - my $canhost = - &Apache::lonnet::can_host_session($env{'user.domain'}, - $coursedomserver, - $remoterev, - $udomdefaults{'remotesessions'}, - $defdomdefaults{'hostedsessions'}); - - if ($canhost) { - $otherserver = $coursedomserver; - } else { - $warning = &mt('Requires LON-CAPA version [_1].',$env{'course.'.$courseid.'.internal.releaserequired'}).'
    '. &mt("No suitable server could be found amongst servers in either your own domain or in the course's domain."); - } - } else { - $warning = &mt('Requires LON-CAPA version [_1].',$env{'course.'.$courseid.'.internal.releaserequired'}).'
    '.&mt("No suitable server could be found amongst servers in your own domain (which is also the course's domain)."); - } - } else { - $otherserver = $userdomserver; - } - } - if ($otherserver ne '') { - $switchserver = 'otherserver='.$otherserver.'&role='.$rolecode; - } - } - } - return ($switchserver,$warning); -} - -=pod - -=item * &check_release_result() - -Inputs: - -$switchwarning - Warning message if no suitable server found to host session. - -$switchserver - query string to append to /adm/switchserver containing lonHostID - and current role. - -Returns: HTML to display with information about requirement to switch server. - Either displaying warning with link to Roles/Courses screen or - display link to switchserver. - =cut -sub check_release_result { - my ($switchwarning,$switchserver) = @_; - my $output = &start_page('Selected course unavailable on this server'). - '

    '; - if ($switchwarning) { - $output .= $switchwarning.'
    '; - if (&show_course()) { - $output .= &mt('Display courses'); - } else { - $output .= &mt('Display roles'); - } - $output .= ''; - } elsif ($switchserver) { - $output .= &mt('This course requires a newer version of LON-CAPA than is installed on this server.'). - '
    '. - ''. - &mt('Switch Server'). - ''; - } - $output .= '

    '.&end_page(); - return $output; -} - -=pod - -=item * &needs_coursereinit() - -Determine if course contents stored for user's session needs to be -refreshed, because content has changed since "Big Hash" last tied. - -Check for change is made if time last checked is more than 10 minutes ago -(by default). - -Inputs: - -$loncaparev - Version on current server (format: Major.Minor.Subrelease-datestamp) - -$interval (optional) - Time which may elapse (in s) between last check for content - change in current course. (default: 600 s). - -Returns: an array; first element is: - -=over 4 - -'switch' - if content updates mean user's session - needs to be switched to a server running a newer LON-CAPA version - -'update' - if course session needs to be refreshed (i.e., Big Hash needs to be reloaded) - on current server hosting user's session - -'' - if no action required. - -=back - -If first item element is 'switch': - -second item is $switchwarning - Warning message if no suitable server found to host session. - -third item is $switchserver - query string to append to /adm/switchserver containing lonHostID - and current role. - -otherwise: no other elements returned. - -=back - -=cut - -sub needs_coursereinit { - my ($loncaparev,$interval) = @_; - return() unless ($env{'request.course.id'} && $env{'request.course.tied'}); - my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; - my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; - my $now = time; - if ($interval eq '') { - $interval = 600; - } - if (($now-$env{'request.course.timechecked'})>$interval) { - my $lastchange = &Apache::lonnet::get_coursechange($cdom,$cnum); - &Apache::lonnet::appenv({'request.course.timechecked'=>$now}); - if ($lastchange > $env{'request.course.tied'}) { - my %curr_reqd_hash = &Apache::lonnet::userenvironment($cdom,$cnum,'internal.releaserequired'); - if ($curr_reqd_hash{'internal.releaserequired'} ne '') { - my $required = $env{'course.'.$cdom.'_'.$cnum.'.internal.releaserequired'}; - if ($curr_reqd_hash{'internal.releaserequired'} ne $required) { - &Apache::lonnet::appenv({'course.'.$cdom.'_'.$cnum.'.internal.releaserequired' => - $curr_reqd_hash{'internal.releaserequired'}}); - my ($switchserver,$switchwarning) = - &check_release_required($loncaparev,$cdom.'_'.$cnum,$env{'request.role'}, - $curr_reqd_hash{'internal.releaserequired'}); - if ($switchwarning ne '' || $switchserver ne '') { - return ('switch',$switchwarning,$switchserver); - } - } - } - return ('update'); - } - } - return (); -} sub update_content_constraints { my ($cdom,$cnum,$chome,$cid) = @_; @@ -16897,8 +15742,8 @@ sub recurse_supplemental { } sub symb_to_docspath { - my ($symb,$navmapref) = @_; - return unless ($symb && ref($navmapref)); + my ($symb) = @_; + return unless ($symb); my ($mapurl,$id,$resurl) = &Apache::lonnet::decode_symb($symb); if ($resurl=~/\.(sequence|page)$/) { $mapurl=$resurl; @@ -16906,11 +15751,9 @@ sub symb_to_docspath { $mapurl=$env{'course.'.$env{'request.course.id'}.'.url'}; } my $mapresobj; - unless (ref($$navmapref)) { - $$navmapref = Apache::lonnavmaps::navmap->new(); - } - if (ref($$navmapref)) { - $mapresobj = $$navmapref->getResourceByUrl($mapurl); + my $navmap = Apache::lonnavmaps::navmap->new(); + if (ref($navmap)) { + $mapresobj = $navmap->getResourceByUrl($mapurl); } $mapurl=~s{^.*/([^/]+)\.(\w+)$}{$1}; my $type=$2; @@ -16920,7 +15763,7 @@ sub symb_to_docspath { if ($pcslist ne '') { foreach my $pc (split(/,/,$pcslist)) { next if ($pc <= 1); - my $res = $$navmapref->getByMapPc($pc); + my $res = $navmap->getByMapPc($pc); if (ref($res)) { my $thisurl = $res->src(); $thisurl=~s{^.*/([^/]+)\.\w+$}{$1}; @@ -16967,32 +15810,31 @@ sub symb_to_docspath { } sub captcha_display { - my ($context,$lonhost,$defdom) = @_; + my ($context,$lonhost) = @_; my ($output,$error); - my ($captcha,$pubkey,$privkey,$version) = - &get_captcha_config($context,$lonhost,$defdom); + my ($captcha,$pubkey,$privkey) = &get_captcha_config($context,$lonhost); if ($captcha eq 'original') { $output = &create_captcha(); unless ($output) { $error = 'captcha'; } } elsif ($captcha eq 'recaptcha') { - $output = &create_recaptcha($pubkey,$version); + $output = &create_recaptcha($pubkey); unless ($output) { $error = 'recaptcha'; } } - return ($output,$error,$captcha,$version); + return ($output,$error,$captcha); } sub captcha_response { - my ($context,$lonhost,$defdom) = @_; + my ($context,$lonhost) = @_; my ($captcha_chk,$captcha_error); - my ($captcha,$pubkey,$privkey,$version) = &get_captcha_config($context,$lonhost,$defdom); + my ($captcha,$pubkey,$privkey) = &get_captcha_config($context,$lonhost); if ($captcha eq 'original') { ($captcha_chk,$captcha_error) = &check_captcha(); } elsif ($captcha eq 'recaptcha') { - $captcha_chk = &check_recaptcha($privkey,$version); + $captcha_chk = &check_recaptcha($privkey); } else { $captcha_chk = 1; } @@ -17000,8 +15842,8 @@ sub captcha_response { } sub get_captcha_config { - my ($context,$lonhost,$dom_in_effect) = @_; - my ($captcha,$pubkey,$privkey,$version,$hashtocheck); + my ($context,$lonhost) = @_; + my ($captcha,$pubkey,$privkey,$hashtocheck); my $hostname = &Apache::lonnet::hostname($lonhost); my $serverhomeID = &Apache::lonnet::get_server_homeID($hostname); my $serverhomedom = &Apache::lonnet::host_domain($serverhomeID); @@ -17017,10 +15859,6 @@ sub get_captcha_config { } if ($privkey && $pubkey) { $captcha = 'recaptcha'; - $version = $hashtocheck->{'recaptchaversion'}; - if ($version ne '2') { - $version = 1; - } } else { $captcha = 'original'; } @@ -17038,39 +15876,14 @@ sub get_captcha_config { $privkey = $domconfhash{$serverhomedom.'.login.recaptchakeys_private'}; if ($privkey && $pubkey) { $captcha = 'recaptcha'; - $version = $domconfhash{$serverhomedom.'.login.recaptchaversion'}; - if ($version ne '2') { - $version = 1; - } } else { $captcha = 'original'; } } elsif ($domconfhash{$serverhomedom.'.login.captcha'} eq 'original') { $captcha = 'original'; } - } elsif ($context eq 'passwords') { - if ($dom_in_effect) { - my %passwdconf = &Apache::lonnet::get_passwdconf($dom_in_effect); - if ($passwdconf{'captcha'} eq 'recaptcha') { - if (ref($passwdconf{'recaptchakeys'}) eq 'HASH') { - $pubkey = $passwdconf{'recaptchakeys'}{'public'}; - $privkey = $passwdconf{'recaptchakeys'}{'private'}; - } - if ($privkey && $pubkey) { - $captcha = 'recaptcha'; - $version = $passwdconf{'recaptchaversion'}; - if ($version ne '2') { - $version = 1; - } - } else { - $captcha = 'original'; - } - } elsif ($passwdconf{'captcha'} ne 'notused') { - $captcha = 'original'; - } - } } - return ($captcha,$pubkey,$privkey,$version); + return ($captcha,$pubkey,$privkey); } sub create_captcha { @@ -17129,61 +15942,38 @@ sub check_captcha { } sub create_recaptcha { - my ($pubkey,$version) = @_; - if ($version >= 2) { - return '
    '; - } else { - my $use_ssl; - if ($ENV{'SERVER_PORT'} == 443) { - $use_ssl = 1; - } - my $captcha = Captcha::reCAPTCHA->new; - return $captcha->get_options_setter({theme => 'white'})."\n". - $captcha->get_html($pubkey,undef,$use_ssl). - &mt('If the text is hard to read, [_1] will replace them.', - 'reCAPTCHA refresh'). - '

    '; - } + my ($pubkey) = @_; + my $use_ssl; + if ($ENV{'SERVER_PORT'} == 443) { + $use_ssl = 1; + } + my $captcha = Captcha::reCAPTCHA->new; + return $captcha->get_options_setter({theme => 'white'})."\n". + $captcha->get_html($pubkey,undef,$use_ssl). + &mt('If either word is hard to read, [_1] will replace them.', + 'reCAPTCHA refresh'). + '

    '; } sub check_recaptcha { - my ($privkey,$version) = @_; + my ($privkey) = @_; my $captcha_chk; - if ($version >= 2) { - my $ua = LWP::UserAgent->new; - $ua->timeout(10); - my %info = ( - secret => $privkey, - response => $env{'form.g-recaptcha-response'}, - remoteip => $ENV{'REMOTE_ADDR'}, - ); - my $response = $ua->post('https://www.google.com/recaptcha/api/siteverify',\%info); - if ($response->is_success) { - my $data = JSON::DWIW->from_json($response->decoded_content); - if (ref($data) eq 'HASH') { - if ($data->{'success'}) { - $captcha_chk = 1; - } - } - } - } else { - my $captcha = Captcha::reCAPTCHA->new; - my $captcha_result = - $captcha->check_answer( - $privkey, - $ENV{'REMOTE_ADDR'}, - $env{'form.recaptcha_challenge_field'}, - $env{'form.recaptcha_response_field'}, - ); - if ($captcha_result->{is_valid}) { - $captcha_chk = 1; - } + my $captcha = Captcha::reCAPTCHA->new; + my $captcha_result = + $captcha->check_answer( + $privkey, + $ENV{'REMOTE_ADDR'}, + $env{'form.recaptcha_challenge_field'}, + $env{'form.recaptcha_response_field'}, + ); + if ($captcha_result->{is_valid}) { + $captcha_chk = 1; } return $captcha_chk; } sub emailusername_info { - my @fields = ('firstname','lastname','institution','web','location','officialemail','id'); + my @fields = ('firstname','lastname','institution','web','location','officialemail'); my %titles = &Apache::lonlocal::texthash ( lastname => 'Last Name', firstname => 'First Name', @@ -17191,7 +15981,6 @@ sub emailusername_info { location => "School's city, state/province, country", web => "School's web address", officialemail => 'E-mail address at institution (if different)', - id => 'Student/Employee ID', ); return (\@fields,\%titles); } @@ -17223,18 +16012,18 @@ sub cleanup_html { sub critical_redirect { my ($interval) = @_; if ((time-$env{'user.criticalcheck.time'})>$interval) { - my @what=&Apache::lonnet::dump('critical', $env{'user.domain'}, + my @what=&Apache::lonnet::dump('critical', $env{'user.domain'}, $env{'user.name'}); &Apache::lonnet::appenv({'user.criticalcheck.time'=>time}); my $redirecturl; if ($what[0]) { - if (($what[0] ne 'con_lost') && ($what[0]!~/^error\:/)) { - $redirecturl='/adm/email?critical=display'; - my $url=&Apache::lonnet::absolute_url().$redirecturl; + if (($what[0] ne 'con_lost') && ($what[0]!~/^error\:/)) { + $redirecturl='/adm/email?critical=display'; + my $url=&Apache::lonnet::absolute_url().$redirecturl; return (1, $url); } } - } + } return (); } @@ -17272,175 +16061,14 @@ sub des_decrypt { } else { $cypher=new DES $keybin; } - my $plaintext=''; - my $cypherlength = length($cyphertext); - my $numchunks = int($cypherlength/32); - for (my $j=0; $j<$numchunks; $j++) { - my $start = $j*32; - my $cypherblock = substr($cyphertext,$start,32); - my $chunk = - $cypher->decrypt(unpack("a8",pack("H16",substr($cypherblock,0,16)))); - $chunk .= - $cypher->decrypt(unpack("a8",pack("H16",substr($cypherblock,16,16)))); - $chunk=substr($chunk,1,ord(substr($chunk,0,1)) ); - $plaintext .= $chunk; - } + my $plaintext= + $cypher->decrypt(unpack("a8",pack("H16",substr($cyphertext,0,16)))); + $plaintext.= + $cypher->decrypt(unpack("a8",pack("H16",substr($cyphertext,16,16)))); + $plaintext=substr($plaintext,1,ord(substr($plaintext,0,1)) ); return $plaintext; } -sub is_nonframeable { - my ($url,$absolute,$hostname,$ip,$nocache) = @_; - my ($remprotocol,$remhost) = ($url =~ m{^(https?)\://(([a-z0-9]+(-[a-z0-9]+)*\.)+[a-z]{2,})}i); - return if (($remprotocol eq '') || ($remhost eq '')); - - $remprotocol = lc($remprotocol); - $remhost = lc($remhost); - my $remport = 80; - if ($remprotocol eq 'https') { - $remport = 443; - } - my ($result,$cached) = &Apache::lonnet::is_cached_new('noiframe',$remhost.':'.$remport); - if ($cached) { - unless ($nocache) { - if ($result) { - return 1; - } else { - return 0; - } - } - } - my $uselink; - my $request = new HTTP::Request('HEAD',$url); - my $ua = LWP::UserAgent->new; - $ua->timeout(5); - my $response=$ua->request($request); - if ($response->is_success()) { - my $secpolicy = lc($response->header('content-security-policy')); - my $xframeop = lc($response->header('x-frame-options')); - $secpolicy =~ s/^\s+|\s+$//g; - $xframeop =~ s/^\s+|\s+$//g; - if (($secpolicy ne '') || ($xframeop ne '')) { - my $remotehost = $remprotocol.'://'.$remhost; - my ($origin,$protocol,$port); - if ($ENV{'SERVER_PORT'} =~/^\d+$/) { - $port = $ENV{'SERVER_PORT'}; - } else { - $port = 80; - } - if ($absolute eq '') { - $protocol = 'http:'; - if ($port == 443) { - $protocol = 'https:'; - } - $origin = $protocol.'//'.lc($hostname); - } else { - $origin = lc($absolute); - ($protocol,$hostname) = ($absolute =~ m{^(https?:)//([^/]+)$}); - } - if (($secpolicy) && ($secpolicy =~ /\Qframe-ancestors\E([^;]*)(;|$)/)) { - my $framepolicy = $1; - $framepolicy =~ s/^\s+|\s+$//g; - my @policies = split(/\s+/,$framepolicy); - if (@policies) { - if (grep(/^\Q'none'\E$/,@policies)) { - $uselink = 1; - } else { - $uselink = 1; - if ((grep(/^\Q*\E$/,@policies)) || (grep(/^\Q$protocol\E$/,@policies)) || - (($origin ne '') && (grep(/^\Q$origin\E$/,@policies))) || - (($ip ne '') && (grep(/^\Q$ip\E$/,@policies)))) { - undef($uselink); - } - if ($uselink) { - if (grep(/^\Q'self'\E$/,@policies)) { - if (($origin ne '') && ($remotehost eq $origin)) { - undef($uselink); - } - } - } - if ($uselink) { - my @possok; - if ($ip ne '') { - push(@possok,$ip); - } - my $hoststr = ''; - foreach my $part (reverse(split(/\./,$hostname))) { - if ($hoststr eq '') { - $hoststr = $part; - } else { - $hoststr = "$part.$hoststr"; - } - if ($hoststr eq $hostname) { - push(@possok,$hostname); - } else { - push(@possok,"*.$hoststr"); - } - } - if (@possok) { - foreach my $poss (@possok) { - last if (!$uselink); - foreach my $policy (@policies) { - if ($policy =~ m{^(\Q$protocol\E//|)\Q$poss\E(\Q:$port\E|)$}) { - undef($uselink); - last; - } - } - } - } - } - } - } - } elsif ($xframeop ne '') { - $uselink = 1; - my @policies = split(/\s*,\s*/,$xframeop); - if (@policies) { - unless (grep(/^deny$/,@policies)) { - if ($origin ne '') { - if (grep(/^sameorigin$/,@policies)) { - if ($remotehost eq $origin) { - undef($uselink); - } - } - if ($uselink) { - foreach my $policy (@policies) { - if ($policy =~ /^allow-from\s*(.+)$/) { - my $allowfrom = $1; - if (($allowfrom ne '') && ($allowfrom eq $origin)) { - undef($uselink); - last; - } - } - } - } - } - } - } - } - } - } - if ($nocache) { - if ($cached) { - my $devalidate; - if ($uselink && !$result) { - $devalidate = 1; - } elsif (!$uselink && $result) { - $devalidate = 1; - } - if ($devalidate) { - &Apache::lonnet::devalidate_cache_new('noiframe',$remhost.':'.$remport); - } - } - } else { - if ($uselink) { - $result = 1; - } else { - $result = 0; - } - &Apache::lonnet::do_cache_new('noiframe',$remhost.':'.$remport,$result,3600); - } - return $uselink; -} - 1; __END__;