--- loncom/interface/loncommon.pm 2022/01/16 19:11:03 1.1075.2.162 +++ loncom/interface/loncommon.pm 2016/05/03 22:33:52 1.1242 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # a pile of common routines # -# $Id: loncommon.pm,v 1.1075.2.162 2022/01/16 19:11:03 raeburn Exp $ +# $Id: loncommon.pm,v 1.1242 2016/05/03 22:33:52 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -71,18 +71,18 @@ 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 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(); +use MIME::Lite; +use MIME::Types; # ---------------------------------------------- Designs use vars qw(%defaultdesign); @@ -167,6 +167,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 +198,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 +220,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 +234,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 +248,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 +262,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 +277,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 +430,7 @@ sub studentbrowser_javascript { OFFLOAD + } } } } @@ -8245,7 +7964,7 @@ OFFLOAD if (!$args->{'frameset'}) { $result .= ' /'; } - $result .= '>' + $result .= '>' .$inhibitprint .$head_extra; my $clientmobile; @@ -8259,7 +7978,6 @@ OFFLOAD '; } - $result .= ''."\n"; return $result.''; } @@ -8278,12 +7996,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; } @@ -8328,8 +8046,7 @@ sub print_suppression { } my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; - my $clientip = &Apache::lonnet::get_requestor_ip(); - my $blocked = &blocking_status('printout',$clientip,$cnum,$cdom,undef,1); + my $blocked = &blocking_status('printout',$cnum,$cdom,undef,1); if ($blocked) { my $checkrole = "cm./$cdom/$cnum"; if ($env{'request.course.sec'} ne '') { @@ -8437,22 +8154,11 @@ $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 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). - links_disabled -> Links in primary and secondary menus are disabled - (Can enable them once page has loaded - see lonroles.pm - for an example). + group -> includes the current group, if page is for a + specific group =back @@ -8482,8 +8188,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); } } @@ -8516,24 +8222,16 @@ 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); - }else{ - $result .= &Apache::lonhtmlcommon::breadcrumbs('','',$menulink); + $result .= &Apache::lonhtmlcommon::breadcrumbs($args->{'bread_crumbs_component'}); + } elsif ($args->{'crstype'} eq 'Placement') { + $result .= &Apache::lonhtmlcommon::breadcrumbs('','','','','','','','','', + $args->{'crstype'}); + } else { + $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; } @@ -8629,7 +8327,7 @@ 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; @@ -8654,20 +8352,13 @@ sub modal_link { $target_attr = 'target="'.$target.'"'; } return <<"ENDLINK"; -$linktext + + $linktext ENDLINK } sub modal_adhoc_script { - my ($funcname,$width,$height,$content,$possmathjax)=@_; - my $mathjax; - if ($possmathjax) { - $mathjax = <<'ENDJAX'; - if (typeof MathJax == 'object') { - MathJax.Hub.Queue(["Typeset",MathJax.Hub]); - } -ENDJAX - } + my ($funcname,$width,$height,$content)=@_; return (< // @@ -8686,21 +8376,21 @@ ENDADHOC } sub modal_adhoc_inner { - my ($funcname,$width,$height,$content,$possmathjax)=@_; + 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(). &end_page() ); - return &modal_adhoc_script($funcname,$width,$height,$content,$possmathjax); + return &modal_adhoc_script($funcname,$width,$height,$content); } sub modal_adhoc_window { - my ($funcname,$width,$height,$content,$linktext,$possmathjax)=@_; - return &modal_adhoc_inner($funcname,$width,$height,$content,$possmathjax). + my ($funcname,$width,$height,$content,$linktext)=@_; + return &modal_adhoc_inner($funcname,$width,$height,$content). "".$linktext.""; } @@ -8766,9 +8456,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; } @@ -8829,54 +8496,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 @@ -9374,7 +9024,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(); @@ -9696,8 +9346,8 @@ Incoming parameters: 2. user's domain 3. quota name - portfolio, author, or course (if no quota name provided, defaults to portfolio). -4. crstype - official, unofficial, textbook or community, if quota name is - course +4. crstype - official, unofficial, textbook, placement or community, + if quota name is course Returns: 1. Disk quota (in MB) assigned to student. @@ -9770,8 +9420,9 @@ 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') || + ($crstype eq 'placement')) { $defquota = $domdefs{$crstype.'quota'}; } if ($defquota eq '') { @@ -9919,7 +9570,7 @@ Inputs: 7 4. filename of file for which action is being requested 5. filesize (kB) of file 6. action being taken: copy or upload. -7. quotatype (in course context -- official, unofficial, community or textbook). +7. quotatype (in course context -- official, unofficial, textbook, placement or community). Returns: 1 scalar: HTML to display containing warning if quota would be exceeded, otherwise return null. @@ -9955,6 +9606,8 @@ sub excess_filesize_warning { ############################################### + + sub get_secgrprole_info { my ($cdom,$cnum,$needroles,$type) = @_; my %sections_count = &get_sections($cdom,$cnum); @@ -9993,24 +9646,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', @@ -10057,14 +9694,7 @@ sub user_picker { ); &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 = ' '.$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 ++; @@ -15040,15 +14495,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}); @@ -15071,12 +14523,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 .= ''; @@ -15224,7 +14676,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; @@ -15307,7 +14759,7 @@ 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 { @@ -15321,7 +14773,7 @@ sub check_clone { if ($args->{'ccdomain'} eq $args->{'clonedomain'}) { $can_clone = 1; } - } elsif (($clonehash{'internal.coursecode'}) && ($args->{'crscode'}) && + } 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'})) { @@ -15340,7 +14792,7 @@ sub check_clone { $can_clone = 1; } unless ($can_clone) { - if (($clonehash{'internal.coursecode'}) && ($args->{'crscode'}) && + if (($clonehash{'internal.coursecode'}) && ($args->{'crscode'}) && ($args->{'clonedomain'} eq $args->{'course_domain'})) { my (%gotdomdefaults,%gotcodedefaults); foreach my $cloner (@cloners) { @@ -15379,12 +14831,12 @@ sub check_clone { if ($args->{'crstype'} eq 'Community') { $ccrole = 'co'; } - my %roleshash = - &Apache::lonnet::get_my_roles($args->{'ccuname'}, - $args->{'ccdomain'}, + my %roleshash = + &Apache::lonnet::get_my_roles($args->{'ccuname'}, + $args->{'ccdomain'}, 'userroles',['active'],[$ccrole], - [$args->{'clonedomain'}]); - if ($roleshash{$args->{'clonecourse'}.':'.$args->{'clonedomain'}.':'.$ccrole}) { + [$args->{'clonedomain'}]); + if ($roleshash{$args->{'clonecourse'}.':'.$args->{'clonedomain'}.':'.$ccrole}) { $can_clone = 1; } elsif (&Apache::lonnet::is_course_owner($args->{'clonedomain'},$args->{'clonecourse'}, $args->{'ccuname'},$args->{'ccdomain'})) { @@ -15396,7 +14848,7 @@ sub check_clone { $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'}); - } + } } } } @@ -15404,8 +14856,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') { @@ -15433,7 +14884,12 @@ sub construct_course { # # Open course # - my $crstype = lc($args->{'crstype'}); + my $showncrstype; + if ($args->{'crstype'} eq 'Placement') { + $showncrstype = 'placement test'; + } else { + $showncrstype = lc($args->{'crstype'}); + } my %cenv=(); $$courseid=&Apache::lonnet::createcourse($args->{'course_domain'}, $args->{'cdescr'}, @@ -15450,7 +14906,7 @@ sub construct_course { # 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).$linefeed; + $outcome .= &mt('New LON-CAPA [_1] ID: [_2]',$showncrstype,$$courseid).$linefeed; if ($$courseid =~ /^error:/) { return (0,$outcome); } @@ -15470,7 +14926,7 @@ sub construct_course { # Do the cloning # if ($can_clone && $cloneid) { - $clonemsg = &mt('Cloning [_1] from [_2]',$crstype,$clonehome); + $clonemsg = &mt('Cloning [_1] from [_2]',$showncrstype,$clonehome); if ($context ne 'auto') { $clonemsg = ''.$clonemsg.''; } @@ -15502,7 +14958,8 @@ sub construct_course { 'plc.users.denied', 'hidefromcat', 'checkforpriv', - 'categories'], + 'categories', + 'internal.uniquecode'], $$crsudom,$$crsunum); if ($args->{'textbook'}) { $cenv{'internal.textbook'} = $args->{'textbook'}; @@ -15552,7 +15009,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/,$//; @@ -15580,7 +15037,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/,$//; @@ -15615,29 +15072,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; @@ -15669,9 +15125,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'}.'/'; @@ -15706,7 +15159,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; } @@ -15743,17 +15196,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 @@ -15783,6 +15231,30 @@ sub construct_course { $outcome .= ($fatal?$errtext:'write ok').$linefeed; } +# +# Set params for Placement Tests +# + if ($args->{'crstype'} eq 'Placement') { + my %storecontent; + my $prefix=$$crsudom.'_'.$$crsunum.'.0.'; + my %defaults = ( + buttonshide => { value => 'yes', + type => 'string_yesno',}, + type => { value => 'randomizetry', + type => 'string_questiontype',}, + maxtries => { value => 1, + type => 'int_pos',}, + problemstatus => { value => 'no', + type => 'string_problemstatus',}, + ); + foreach my $key (keys(%defaults)) { + $storecontent{$prefix.$key} = $defaults{$key}{'value'}; + $storecontent{$prefix.$key.'.type'} = $defaults{$key}{'type'}; + } + &Apache::lonnet::cput + ('resourcedata',\%storecontent,$$crsudom,$$crsunum); + } + return (1,$outcome); } @@ -15796,7 +15268,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; @@ -15843,8 +15315,7 @@ sub generate_code { ############################################################ ############################################################ -#SD -# only Community and Course, or anything else? +# Community, Course and Placement Test sub course_type { my ($cid) = @_; if (!defined($cid)) { @@ -15862,17 +15333,19 @@ sub group_term { my %names = ( 'Course' => 'group', 'Community' => 'group', + 'Placement' => 'group', ); return $names{$crstype}; } sub course_types { - my @types = ('official','unofficial','community','textbook'); + my @types = ('official','unofficial','community','textbook','placement'); my %typename = ( official => 'Official course', unofficial => 'Unofficial course', community => 'Community', textbook => 'Textbook course', + placement => 'Placement test', ); return (\@types,\%typename); } @@ -15952,24 +15425,6 @@ sub compare_arrays { return @difference; } -sub lon_status_items { - my %defaults = ( - E => 100, - W => 4, - N => 1, - U => 5, - threshold => 200, - sysmail => 2500, - ); - my %names = ( - E => 'Errors', - W => 'Warnings', - N => 'Notices', - U => 'Unsent', - ); - return (\%defaults,\%names); -} - # -------------------------------------------------------- Initialize user login sub init_user_environment { my ($r, $username, $domain, $authhost, $form, $args) = @_; @@ -16005,23 +15460,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); @@ -16072,7 +15511,6 @@ sub init_user_environment { # --------------------------------------------------------- Write first profile { - my $ip = &Apache::lonnet::get_requestor_ip(); my %initial_env = ("user.name" => $username, "user.domain" => $domain, @@ -16091,7 +15529,7 @@ sub init_user_environment { "request.course.sec" => '', "request.role" => 'cm', "request.role.adv" => $env{'user.adv'}, - "request.host" => $ip,); + "request.host" => $ENV{'REMOTE_ADDR'},); if ($form->{'localpath'}) { $initial_env{"browser.localpath"} = $form->{'localpath'}; @@ -16110,44 +15548,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','placement') { + $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'}; } } @@ -16254,12 +15684,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 @@ -16275,19 +15705,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 @@ -16378,15 +15808,19 @@ sub build_filters { $createdfilterform = &timebased_select_form('createdfilter',$filter); } + my $prefix = $crstype; + if ($crstype eq 'Placement') { + $prefix = 'Placement Test' + } my %lt = &Apache::lonlocal::texthash( - 'cac' => "$crstype Activity", - 'ccr' => "$crstype Created", - 'cde' => "$crstype Title", - 'cdo' => "$crstype Domain", + 'cac' => "$prefix Activity", + 'ccr' => "$prefix Created", + 'cde' => "$prefix Title", + 'cdo' => "$prefix Domain", 'ins' => 'Institutional Code', 'inc' => 'Institutional Categorization', - 'cow' => "$crstype Owner/Co-owner", - 'cop' => "$crstype Personnel Includes", + 'cow' => "$prefix Owner/Co-owner", + 'cop' => "$prefix Personnel Includes", 'cog' => 'Type', ); @@ -16394,6 +15828,8 @@ sub build_filters { my $typeval = 'Course'; if ($crstype eq 'Community') { $typeval = 'Community'; + } elsif ($crstype eq 'Placement') { + $typeval = 'Placement'; } $typeselectform = ''; } else { @@ -16402,9 +15838,15 @@ sub build_filters { $typeselectform .= ' onchange="'.$onchange.'"'; } $typeselectform .= '>'."\n"; - foreach my $posstype ('Course','Community') { + foreach my $posstype ('Course','Community','Placement') { + my $shown; + if ($posstype eq 'Placement') { + $shown = &mt('Placement Test'); + } else { + $shown = &mt($posstype); + } $typeselectform.='\n"; + ($posstype eq $crstype ? ' selected="selected" ' : ''). ">".$shown."\n"; } $typeselectform.=""; } @@ -16429,7 +15871,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', @@ -16558,7 +16000,7 @@ $typeelement return $jscript.$clonewarning.$output; } -=pod +=pod =item * &timebased_select_form() @@ -16573,7 +16015,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 @@ -16610,7 +16052,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 @@ -16649,7 +16091,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). @@ -16661,7 +16103,7 @@ 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). @@ -16671,8 +16113,8 @@ cc_clone - escaped comma separated list 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 +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. @@ -16755,7 +16197,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]; @@ -16798,8 +16240,8 @@ $required - LON-CAPA version needed by c Returns: -$switchserver - query string tp append to /adm/switchserver call (if - current server's LON-CAPA version is too old. +$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. @@ -16912,7 +16354,7 @@ 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). + change in current course. (default: 600 s). Returns: an array; first element is: @@ -16920,9 +16362,9 @@ Returns: an array; first element is: '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 + on current server hosting user's session '' - if no action required. @@ -16930,10 +16372,10 @@ Returns: an array; first element is: If first item element is 'switch': -second item is $switchwarning - Warning message if no suitable server found to host session. +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. + and current role. otherwise: no other elements returned. @@ -17085,8 +16527,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; @@ -17094,11 +16536,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; @@ -17108,7 +16548,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}; @@ -17155,10 +16595,10 @@ 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,$version) = + &get_captcha_config($context,$lonhost); if ($captcha eq 'original') { $output = &create_captcha(); unless ($output) { @@ -17174,9 +16614,9 @@ sub captcha_display { } 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,$version) = &get_captcha_config($context,$lonhost); if ($captcha eq 'original') { ($captcha_chk,$captcha_error) = &check_captcha(); } elsif ($captcha eq 'recaptcha') { @@ -17188,7 +16628,7 @@ sub captcha_response { } sub get_captcha_config { - my ($context,$lonhost,$dom_in_effect) = @_; + my ($context,$lonhost) = @_; my ($captcha,$pubkey,$privkey,$version,$hashtocheck); my $hostname = &Apache::lonnet::hostname($lonhost); my $serverhomeID = &Apache::lonnet::get_server_homeID($hostname); @@ -17228,7 +16668,7 @@ sub get_captcha_config { $captcha = 'recaptcha'; $version = $domconfhash{$serverhomedom.'.login.recaptchaversion'}; if ($version ne '2') { - $version = 1; + $version = 1; } } else { $captcha = 'original'; @@ -17236,27 +16676,6 @@ sub get_captcha_config { } 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); } @@ -17274,17 +16693,13 @@ sub create_captcha { if (-e $Apache::lonnet::perlvar{'lonCaptchaDir'}.'/'.$md5sum.'.png') { $output = ''."\n". - ''. &mt('Type in the letters/numbers shown below').' '. ''. - '
'. + '
'. 'captcha'; last; } } - if ($output eq '') { - &Apache::lonnet::logthis("Failed to create Captcha code after $tries attempts."); - } return $output; } @@ -17323,8 +16738,7 @@ sub check_captcha { sub create_recaptcha { my ($pubkey,$version) = @_; if ($version >= 2) { - return '
'. - '
'; + return '
'; } else { my $use_ssl; if ($ENV{'SERVER_PORT'} == 443) { @@ -17336,20 +16750,19 @@ sub create_recaptcha { &mt('If the text is hard to read, [_1] will replace them.', 'reCAPTCHA refresh'). '

'; - } + } } sub check_recaptcha { my ($privkey,$version) = @_; my $captcha_chk; - my $ip = &Apache::lonnet::get_requestor_ip(); if ($version >= 2) { my $ua = LWP::UserAgent->new; $ua->timeout(10); my %info = ( - secret => $privkey, + secret => $privkey, response => $env{'form.g-recaptcha-response'}, - remoteip => $ip, + remoteip => $ENV{'REMOTE_ADDR'}, ); my $response = $ua->post('https://www.google.com/recaptcha/api/siteverify',\%info); if ($response->is_success) { @@ -17365,7 +16778,7 @@ sub check_recaptcha { my $captcha_result = $captcha->check_answer( $privkey, - $ip, + $ENV{'REMOTE_ADDR'}, $env{'form.recaptcha_challenge_field'}, $env{'form.recaptcha_response_field'}, ); @@ -17377,7 +16790,7 @@ sub check_recaptcha { } 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', @@ -17385,7 +16798,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); } @@ -17416,22 +16828,19 @@ sub cleanup_html { # $interval indicates how often to check for messages. sub critical_redirect { my ($interval) = @_; - unless (($env{'user.domain'} ne '') && ($env{'user.name'} ne '')) { - return (); - } 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] ne 'no_such_host') && ($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 (); } @@ -17485,159 +16894,6 @@ sub des_decrypt { 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__;