--- loncom/interface/loncommon.pm 2015/08/16 20:45:41 1.1228 +++ loncom/interface/loncommon.pm 2022/10/29 18:13:28 1.1395 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # a pile of common routines # -# $Id: loncommon.pm,v 1.1228 2015/08/16 20:45:41 raeburn Exp $ +# $Id: loncommon.pm,v 1.1395 2022/10/29 18:13:28 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -61,7 +61,7 @@ use POSIX qw(strftime mktime); use Apache::lonmenu(); use Apache::lonenc(); use Apache::lonlocal; -use Apache::lonnet(); +use Apache::lonnavmaps(); use HTML::Entities; use Apache::lonhtmlcommon(); use Apache::loncoursedata(); @@ -71,16 +71,24 @@ use Apache::lonuserutils(); use Apache::lonuserstate(); use Apache::courseclassifier(); use LONCAPA qw(:DEFAULT :match); +use LONCAPA::LWPReq; +use LONCAPA::map(); +use HTTP::Request; use DateTime::TimeZone; -use DateTime::Locale::Catalog; +use DateTime::Locale; use Encode(); use Text::Aspell; use Authen::Captcha; use Captcha::reCAPTCHA; +use JSON::DWIW; use Crypt::DES; use DynaLoader; # for Crypt::DES version use MIME::Lite; use MIME::Types; +use File::Copy(); +use File::Path(); +use String::CRC32(); +use Short::URL(); # ---------------------------------------------- Designs use vars qw(%defaultdesign); @@ -196,7 +204,7 @@ 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); @@ -218,7 +226,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 +240,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 +254,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 +268,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 +283,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 +436,7 @@ sub studentbrowser_javascript { END # output the initial values for the selection lists - $result .= "\n"; my @order = sort(keys(%{$hashref})); if (ref($menuorder) eq 'ARRAY') { @order = @{$menuorder}; @@ -1233,7 +1258,7 @@ END =pod -=item * &help_open_topic($topic,$text,$stayOnPage,$width,$height,$imgid) +=item * &help_open_topic($topic,$text,$stayOnPage,$width,$height,$imgid,$links_target) Returns a string corresponding to an HTML link to the given help $topic, where $topic corresponds to the name of a .tex file in @@ -1257,10 +1282,12 @@ $imgid is the id of the img tag used for used in a javascript call to switch the image src. See lonhtmlcommon::htmlareaselectactive() for an example. +$links_target will optionally be set to a target (_top, _parent or _self). + =cut sub help_open_topic { - my ($topic, $text, $stayOnPage, $width, $height, $imgid) = @_; + my ($topic, $text, $stayOnPage, $width, $height, $imgid, $links_target) = @_; $text = "" if (not defined $text); $stayOnPage = 0 if (not defined $stayOnPage); $width = 500 if (not defined $width); @@ -1282,9 +1309,16 @@ sub help_open_topic { } # Add the text - if ($text ne "") { + my $target = ' target="_top"'; + if ($links_target) { + $target = ' target="'.$links_target.'"'; + } elsif ((($env{'request.lti.login'}) && ($env{'request.lti.target'} eq 'iframe')) || + (($env{'request.deeplink.login'}) && ($env{'request.deeplink.target'} eq '_self'))) { + $target = ''; + } + if ($text ne "") { $template.='' - .'' + .'' .$text.''; } @@ -1294,7 +1328,7 @@ sub help_open_topic { if ($imgid ne '') { $imgid = ' id="'.$imgid.'"'; } - $template.=' ' + $template.=' ' .''.&mt('Help: [_1]',$topic).''; + $width,$height,'',$links_target).''; } } my $banner_link = &update_help_link($topic,$component_help,$faq,$bug,$stayOnPage); @@ -1388,7 +1422,7 @@ sub help_open_menu { } sub top_nav_help { - my ($text) = @_; + my ($text,$linkattr) = @_; $text = &mt($text); my $stay_on_page = 1; @@ -1402,7 +1436,7 @@ sub top_nav_help { if ($link) { return <<"END"; $banner_link -$text +$text END } else { return ' '.$text.' '; @@ -1487,19 +1521,26 @@ sub help_open_bug { { $link = $url; } + + my $target = '_top'; + if ((($env{'request.lti.login'}) && ($env{'request.lti.target'} eq 'iframe')) || + (($env{'request.deeplink.login'}) && ($env{'request.deeplink.target'} eq '_self'))) { + $target = '_blank'; + } + # Add the text if ($text ne "") { $template .= "". - "
$text"; + "$text"; } # Add the graphic my $title = &mt('Report a Bug'); my $bugicon=&lonhttpdurl("/adm/lonMisc/smallBug.gif"); $template .= <<"ENDTEMPLATE"; - (Bug: $topic) + (Bug: $topic) ENDTEMPLATE if ($text ne '') { $template.='
' }; return $template; @@ -1765,6 +1806,162 @@ RESIZE } sub colorfuleditor_js { + my $browse_or_search; + my $respath; + my ($cnum,$cdom) = &crsauthor_url(); + if ($cnum) { + $respath = "/res/$cdom/$cnum/"; + my %js_lt = &Apache::lonlocal::texthash( + sunm => 'Sub-directory name', + save => 'Save page to make this permanent', + ); + &js_escape(\%js_lt); + $browse_or_search = <<"END"; + + function toggleChooser(form,element,titleid,only,search) { + var disp = 'none'; + if (document.getElementById('chooser_'+element)) { + var curr = document.getElementById('chooser_'+element).style.display; + if (curr == 'none') { + disp='inline'; + if (form.elements['chooser_'+element].length) { + for (var i=0; i 1) { + window['select1'+element+'_changed'](); + } + } + } + document.getElementById('chooser_'+element+'_crsres').style.display = 'block'; + + } + if (document.getElementById('chooser_'+element+'_upload')) { + document.getElementById('chooser_'+element+'_upload').style.display = 'none'; + if (document.getElementById('uploadcrsres_'+element)) { + document.getElementById('uploadcrsres_'+element).value = ''; + } + } + return; + } + + function toggleCrsUpload(form,element,numcrsdirs) { + if (document.getElementById('chooser_'+element+'_crsres')) { + document.getElementById('chooser_'+element+'_crsres').style.display = 'none'; + } + if (document.getElementById('chooser_'+element+'_upload')) { + var curr = document.getElementById('chooser_'+element+'_upload').style.display; + if (curr == 'none') { + if (numcrsdirs) { + form.elements['crsauthorpath_'+element].selectedIndex = 0; + form.elements['newsubdir_'+element][0].checked = true; + toggleNewsubdir(form,element); + } + } + document.getElementById('chooser_'+element+'_upload').style.display = 'block'; + } + return; + } + + function toggleResImport(form,element) { + var choices = new Array('crsres','upload'); + for (var i=0; i // @@ -1947,7 +2144,7 @@ sub colorfuleditor_js { } } - +$browse_or_search // ]]> @@ -1999,6 +2196,133 @@ sub insert_folding_button { value=\"".&mt('Hide')."\" onclick=\"fold_box('$curDepth','$lastresource')\">"; } +sub crsauthor_url { + my ($url) = @_; + if ($url eq '') { + $url = $ENV{'REQUEST_URI'}; + } + my ($cnum,$cdom); + if ($env{'request.course.id'}) { + my ($audom,$auname) = ($url =~ m{^/priv/($match_domain)/($match_name)/}); + if ($audom ne '' && $auname ne '') { + if (($env{'course.'.$env{'request.course.id'}.'.num'} eq $auname) && + ($env{'course.'.$env{'request.course.id'}.'.domain'} eq $audom)) { + $cnum = $auname; + $cdom = $audom; + } + } + } + return ($cnum,$cdom); +} + +sub import_crsauthor_form { + my ($form,$firstselectname,$secondselectname,$onchangefirst,$only,$suffix,$disabled) = @_; + return (0) unless ($env{'request.course.id'}); + my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; + my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; + my $crshome = $env{'course.'.$env{'request.course.id'}.'.home'}; + return (0) unless (($cnum ne '') && ($cdom ne '')); + my $londocroot = $Apache::lonnet::perlvar{'lonDocRoot'}; + my @ids=&Apache::lonnet::current_machine_ids(); + my ($output,$is_home,$relpath,%subdirs,%files,%selimport_menus); + + if (grep(/^\Q$crshome\E$/,@ids)) { + $is_home = 1; + } + $relpath = "/priv/$cdom/$cnum"; + &Apache::lonnet::recursedirs($is_home,'priv',$londocroot,$relpath,'',\%subdirs,\%files); + my %lt = &Apache::lonlocal::texthash ( + fnam => 'Filename', + dire => 'Directory', + ); + my $numdirs = scalar(keys(%files)); + my (%possexts,$singledir,@singledirfiles); + if ($only) { + map { $possexts{$_} = 1; } split(/\s*,\s*/,$only); + } + my (%nonemptydirs,$possdirs); + if ($numdirs > 1) { + my @order; + foreach my $key (sort { lc($a) cmp lc($b) } (keys(%files))) { + if (ref($files{$key}) eq 'HASH') { + my $shown = $key; + if ($key eq '') { + $shown = '/'; + } + my @ordered = (); + foreach my $file (sort { lc($a) cmp lc($b) } (keys(%{$files{$key}}))) { + next if ($file =~ /\.rights$/); + if ($only) { + my ($ext) = ($file =~ /\.([^.]+)$/); + unless ($possexts{lc($ext)}) { + next; + } + } + $selimport_menus{$key}->{'select2'}->{$file} = $file; + push(@ordered,$file); + } + if (@ordered) { + push(@order,$key); + $nonemptydirs{$key} = 1; + $selimport_menus{$key}->{'text'} = $shown; + $selimport_menus{$key}->{'default'} = ''; + $selimport_menus{$key}->{'select2'}->{''} = ''; + $selimport_menus{$key}->{'order'} = \@ordered; + } + } + } + $possdirs = scalar(keys(%nonemptydirs)); + if ($possdirs > 1) { + my @order = sort { lc($a) cmp lc($b) } (keys(%nonemptydirs)); + $output = $lt{'dire'}. + &linked_select_forms($form,'
'. + $lt{'fnam'},'', + $firstselectname,$secondselectname, + \%selimport_menus,\@order, + $onchangefirst,'',$suffix).'
'; + } elsif ($possdirs == 1) { + $singledir = (keys(%nonemptydirs))[0]; + if (ref($selimport_menus{$singledir}->{'order'}) eq 'ARRAY') { + @singledirfiles = @{$selimport_menus{$singledir}->{'order'}}; + } + delete($selimport_menus{$singledir}); + } + } elsif ($numdirs == 1) { + $singledir = (keys(%files))[0]; + foreach my $file (sort { lc($a) cmp lc($b) } (keys(%{$files{$singledir}}))) { + if ($only) { + my ($ext) = ($file =~ /\.([^.]+)$/); + unless ($possexts{lc($ext)}) { + next; + } + } else { + next if ($file =~ /\.rights$/); + } + push(@singledirfiles,$file); + } + if (@singledirfiles) { + $possdirs = 1; + } + } + if (($possdirs == 1) && (@singledirfiles)) { + my $showdir = $singledir; + if ($singledir eq '') { + $showdir = '/'; + } + $output = $lt{'dire'}. + '
'. + $lt{'fnam'}.'
'."\n"; + } + return ($possdirs,$output); +} + =pod =head1 Excel and CSV file utility routines @@ -2186,10 +2510,24 @@ sub create_text_file { # ------------------------------------------ sub domain_select { - my ($name,$value,$multiple)=@_; + my ($name,$value,$multiple,$incdoms,$excdoms)=@_; + my @possdoms; + if (ref($incdoms) eq 'ARRAY') { + @possdoms = @{$incdoms}; + } else { + @possdoms = &Apache::lonnet::all_domains(); + } + my %domains=map { $_ => $_.' '. &Apache::lonnet::domain($_,'description') - } &Apache::lonnet::all_domains(); + } @possdoms; + + if ((ref($excdoms) eq 'ARRAY') && (@{$excdoms} > 0)) { + foreach my $dom (@{$excdoms}) { + delete($domains{$dom}); + } + } + if ($multiple) { $domains{''}=&mt('Any domain'); $domains{'select_form_order'} = [sort {lc($a) cmp lc($b) } (keys(%domains))]; @@ -2258,12 +2596,15 @@ sub multiple_select_form { =pod -=item * &select_form($defdom,$name,$hashref,$onchange) +=item * &select_form($defdom,$name,$hashref,$onchange,$readonly) Returns a string containing a form to allow a user to select the domain to preform an operation in. @@ -2466,14 +2807,19 @@ The optional $incdoms is a reference to The optional $excdoms is a reference to an array of domains which will be excluded from the available options. +The optional $disabled argument, if true, adds the disabled attribute to the select tag. + =cut #------------------------------------------- sub select_dom_form { - my ($defdom,$name,$includeempty,$showdomdesc,$onchange,$incdoms,$excdoms) = @_; + my ($defdom,$name,$includeempty,$showdomdesc,$onchange,$incdoms,$excdoms,$disabled) = @_; if ($onchange) { $onchange = ' onchange="'.$onchange.'"'; } + if ($disabled) { + $disabled = ' disabled="disabled"'; + } my (@domains,%exclude); if (ref($incdoms) eq 'ARRAY') { @domains = sort {lc($a) cmp lc($b)} (@{$incdoms}); @@ -2484,7 +2830,7 @@ sub select_dom_form { if (ref($excdoms) eq 'ARRAY') { map { $exclude{$_} = 1; } @{$excdoms}; } - my $selectdomain = "\n"; foreach my $dom (@domains) { next if ($exclude{$dom}); $selectdomain.="'. + $item.'"'.$checked.$disabled.' />'.$parent_title.''. ''; my $depth = 1; push(@path,$parent); - $table .= &assign_category_rows($itemcount,\@cats,$depth,$parent,\@path,\@currcategories); + $table .= &assign_category_rows($itemcount,\@cats,$depth,$parent,\@path,\@currcategories,$disabled); pop(@path); $table .= ''; $itemcount ++; @@ -14342,12 +16286,15 @@ 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) = @_; + my ($itemcount,$cats,$depth,$parent,$path,$currcategories,$disabled) = @_; my ($text,$name,$item,$chgstr); if (ref($cats) eq 'ARRAY') { my $maxdepth = scalar(@{$cats}); @@ -14370,12 +16317,12 @@ sub assign_category_rows { } $text .= ''. + $item.'"'.$checked.$disabled.' />'.$name.''. ''. ''; if (ref($path) eq 'ARRAY') { push(@{$path},$name); - $text .= &assign_category_rows($itemcount,$cats,$deeper,$name,$path,$currcategories); + $text .= &assign_category_rows($itemcount,$cats,$deeper,$name,$path,$currcategories,$disabled); pop(@{$path}); } $text .= ''; @@ -14586,7 +16533,8 @@ sub check_clone { my $cloneid='/'.$args->{'clonedomain'}.'/'.$args->{'clonecourse'}; my ($clonecrsudom,$clonecrsunum)= &LONCAPA::split_courseid($cloneid); my $clonehome=&Apache::lonnet::homeserver($clonecrsunum,$clonecrsudom); - my $clonemsg; + my $clonetitle; + my @clonemsg; my $can_clone = 0; my $lctype = lc($args->{'crstype'}); if ($lctype ne 'community') { @@ -14594,19 +16542,41 @@ sub check_clone { } if ($clonehome eq 'no_host') { if ($args->{'crstype'} eq 'Community') { - $clonemsg = &mt('No new community created.').$linefeed.&mt('A new community could not be cloned from the specified original - [_1] - because it is a non-existent community.',$args->{'clonecourse'}.':'.$args->{'clonedomain'}); + push(@clonemsg,({ + mt => 'No new community created.', + args => [], + }, + { + mt => 'A new community could not be cloned from the specified original - [_1] - because it is a non-existent community.', + args => [$args->{'clonedomain'}.':'.$args->{'clonedomain'}], + })); } else { - $clonemsg = &mt('No new course created.').$linefeed.&mt('A new course could not be cloned from the specified original - [_1] - because it is a non-existent course.',$args->{'clonecourse'}.':'.$args->{'clonedomain'}); - } + push(@clonemsg,({ + mt => 'No new course created.', + args => [], + }, + { + mt => 'A new course could not be cloned from the specified original - [_1] - because it is a non-existent course.', + args => [$args->{'clonecourse'}.':'.$args->{'clonedomain'}], + })); + } } else { my %clonedesc = &Apache::lonnet::coursedescription($cloneid,{'one_time' => 1}); + $clonetitle = $clonedesc{'description'}; if ($args->{'crstype'} eq 'Community') { if ($clonedesc{'type'} ne 'Community') { - $clonemsg = &mt('No new community created.').$linefeed.&mt('A new community could not be cloned from the specified original - [_1] - because it is a course not a community.',$args->{'clonecourse'}.':'.$args->{'clonedomain'}); - return ($can_clone, $clonemsg, $cloneid, $clonehome); + push(@clonemsg,({ + mt => 'No new community created.', + args => [], + }, + { + mt => 'A new community could not be cloned from the specified original - [_1] - because it is a course not a community.', + args => [$args->{'clonecourse'}.':'.$args->{'clonedomain'}], + })); + 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 { @@ -14692,19 +16662,34 @@ sub check_clone { } 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'}); + push(@clonemsg,({ + mt => 'No new community created.', + args => [], + }, + { + 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 => [$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'}); + push(@clonemsg,({ + mt => 'No new course created.', + args => [], + }, + { + 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 => [$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'}], + })); } } } } - return ($can_clone, $clonemsg, $cloneid, $clonehome); + return ($can_clone,\@clonemsg,$cloneid,$clonehome,$clonetitle); } sub construct_course { - my ($args,$logmsg,$courseid,$crsudom,$crsunum,$udom,$uname,$context,$cnum,$category,$coderef) = @_; - my $outcome; + my ($args,$logmsg,$courseid,$crsudom,$crsunum,$udom,$uname,$context, + $cnum,$category,$coderef,$callercontext,$user_lh) = @_; + my ($outcome,$msgref,$clonemsgref); my $linefeed = '
'."\n"; if ($context eq 'auto') { $linefeed = "\n"; @@ -14713,25 +16698,23 @@ sub construct_course { # # Are we cloning? # - my ($can_clone, $clonemsg, $cloneid, $clonehome); + my ($can_clone,$cloneid,$clonehome,$clonetitle); if (($args->{'clonecourse'}) && ($args->{'clonedomain'})) { - ($can_clone, $clonemsg, $cloneid, $clonehome) = &check_clone($args,$linefeed); - if ($context ne 'auto') { - if ($clonemsg ne '') { - $clonemsg = ''.$clonemsg.''; - } - } - $outcome .= $clonemsg.$linefeed; - + ($can_clone,$clonemsgref,$cloneid,$clonehome,$clonetitle) = &check_clone($args,$linefeed); if (!$can_clone) { - return (0,$outcome); + return (0,$outcome,$clonemsgref); } } # # 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'}, @@ -14742,15 +16725,20 @@ sub construct_course { $args->{'ccuname'}.':'. $args->{'ccdomain'}, $args->{'crstype'}, - $cnum,$context,$category); + $cnum,$context,$category, + $callercontext); # Note: The testing routines depend on this being output; see # Utils::Course. This needs to at least be output as a comment # if anyone ever decides to not show this, and Utils::Course::new # will need to be suitably modified. - $outcome .= &mt('New LON-CAPA [_1] ID: [_2]',$crstype,$$courseid).$linefeed; + if (($callercontext eq 'auto') && ($user_lh ne '')) { + $outcome .= &mt_user($user_lh,'New LON-CAPA [_1] ID: [_2]',$showncrstype,$$courseid).$linefeed; + } else { + $outcome .= &mt('New LON-CAPA [_1] ID: [_2]',$showncrstype,$$courseid).$linefeed; + } if ($$courseid =~ /^error:/) { - return (0,$outcome); + return (0,$outcome,$clonemsgref); } # @@ -14759,23 +16747,37 @@ sub construct_course { ($$crsudom,$$crsunum)= &LONCAPA::split_courseid($$courseid); my $crsuhome=&Apache::lonnet::homeserver($$crsunum,$$crsudom); if ($crsuhome eq 'no_host') { - $outcome .= &mt('Course creation failed, unrecognized course home server.').$linefeed; - return (0,$outcome); + if (($callercontext eq 'auto') && ($user_lh ne '')) { + $outcome .= &mt_user($user_lh, + 'Course creation failed, unrecognized course home server.'); + } else { + $outcome .= &mt('Course creation failed, unrecognized course home server.'); + } + $outcome .= $linefeed; + return (0,$outcome,$clonemsgref); } $outcome .= &mt('Created on').': '.$crsuhome.$linefeed; # # Do the cloning # + my @clonemsg; if ($can_clone && $cloneid) { - $clonemsg = &mt('Cloning [_1] from [_2]',$crstype,$clonehome); - if ($context ne 'auto') { - $clonemsg = ''.$clonemsg.''; - } - $outcome .= $clonemsg.$linefeed; + push(@clonemsg, + { + mt => 'Created [_1] by cloning from [_2]', + args => [$showncrstype,$clonetitle], + }); my %oldcenv=&Apache::lonnet::dump('environment',$$crsudom,$$crsunum); # Copy all files - &Apache::lonclonecourse::copycoursefiles($cloneid,$$courseid,$args->{'datemode'},$args->{'dateshift'}); + my @info = + &Apache::lonclonecourse::copycoursefiles($cloneid,$$courseid,$args->{'datemode'}, + $args->{'dateshift'},$args->{'crscode'}, + $args->{'ccuname'}.':'.$args->{'ccdomain'}, + $args->{'tinyurls'}); + if (@info) { + push(@clonemsg,@info); + } # Restore URL $cenv{'url'}=$oldcenv{'url'}; # Restore title @@ -14800,8 +16802,7 @@ sub construct_course { 'plc.users.denied', 'hidefromcat', 'checkforpriv', - 'categories', - 'internal.uniquecode'], + 'categories'], $$crsudom,$$crsunum); if ($args->{'textbook'}) { $cenv{'internal.textbook'} = $args->{'textbook'}; @@ -14816,6 +16817,9 @@ sub construct_course { if ($args->{'crstype'}) { $cenv{'type'}=$args->{'crstype'}; } + if ($args->{'lti'}) { + $cenv{'internal.lti'}=$args->{'lti'}; + } if ($args->{'crsid'}) { $cenv{'courseid'}=$args->{'crsid'}; } @@ -14851,7 +16855,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/,$//; @@ -14879,7 +16883,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/,$//; @@ -14914,27 +16918,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. 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' + '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.', ); - my $badclass_msg = $cenv{'internal.courseowner'}.') - '.$lt{'dnhr'}. - ' ('.$lt{'adby'}.')'; + 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'}; if ($context eq 'auto') { $outcome .= $badclass_msg.$linefeed; + } else { $outcome .= '
'.$badclass_msg.$linefeed.'

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

    \n"; } } if ($args->{'no_end_date'}) { @@ -14967,6 +16972,9 @@ 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'}.'/'; @@ -15038,19 +17046,23 @@ 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 => time, + my %storecontent = ($storeunder => $opendate, $storeunder.'.type' => 'date_start'); - - $outcome .= &mt('Opening all assignments').': '.&Apache::lonnet::cput - ('resourcedata',\%storecontent,$$crsudom,$$crsunum).$linefeed; + $outcome .= &mt('All assignments open starting [_1]', + &Apache::lonlocal::locallocaltime($opendate)).': '. + &Apache::lonnet::cput + ('resourcedata',\%storecontent,$$crsudom,$$crsunum).$linefeed; } # # Set first page # unless (($args->{'nonstandard'}) || ($args->{'firstres'} eq 'blank') || ($cloneid)) { - use LONCAPA::map; $outcome .= &mt('Setting first resource').': '; my $map = '/uploaded/'.$$crsudom.'/'.$$crsunum.'/default.sequence'; @@ -15073,7 +17085,31 @@ sub construct_course { $outcome .= ($fatal?$errtext:'write ok').$linefeed; } - return (1,$outcome); +# +# 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,\@clonemsg); } sub make_unique_code { @@ -15133,8 +17169,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)) { @@ -15152,17 +17187,20 @@ 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','lti'); my %typename = ( official => 'Official course', unofficial => 'Unofficial course', community => 'Community', textbook => 'Textbook course', + placement => 'Placement test', + lti => 'LTI provider', ); return (\@types,\%typename); } @@ -15242,6 +17280,24 @@ 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) = @_; @@ -15249,8 +17305,6 @@ sub init_user_environment { my $public=($username eq 'public' && $domain eq 'public'); -# See if old ID present, if so, remove - my ($filename,$cookie,$userroles,$firstaccenv,$timerintenv); my $now=time; @@ -15272,12 +17326,29 @@ sub init_user_environment { } if (!$cookie) { $cookie="publicuser_$oldest"; } } else { - # if this isn't a robot, kill any existing non-robot sessions + # See if old ID present, if so, remove if this isn't a robot, + # killing any existing non-robot sessions if (!$args->{'robot'}) { opendir(DIR,$lonids); while ($filename=readdir(DIR)) { if ($filename=~/^$username\_\d+\_$domain\_$authhost\.id$/) { - unlink($lonids.'/'.$filename); + 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); + } } } closedir(DIR); @@ -15312,8 +17383,7 @@ sub init_user_environment { my %userenv = &Apache::lonnet::dump('environment',$domain,$username); my ($tmp) = keys(%userenv); - if ($tmp !~ /^(con_lost|error|no_such_host)/i) { - } else { + if ($tmp =~ /^(con_lost|error|no_such_host)/i) { undef(%userenv); } if (($userenv{'interface'}) && (!$form->{'interface'})) { @@ -15328,6 +17398,7 @@ sub init_user_environment { # --------------------------------------------------------- Write first profile { + my $ip = &Apache::lonnet::get_requestor_ip($r); my %initial_env = ("user.name" => $username, "user.domain" => $domain, @@ -15346,7 +17417,7 @@ sub init_user_environment { "request.course.sec" => '', "request.role" => 'cm', "request.role.adv" => $env{'user.adv'}, - "request.host" => $ENV{'REMOTE_ADDR'},); + "request.host" => $ip,); if ($form->{'localpath'}) { $initial_env{"browser.localpath"} = $form->{'localpath'}; @@ -15365,39 +17436,75 @@ sub init_user_environment { $env{'user.noloadbalance'} = $lonhost; } - my %is_adv = ( is_adv => $env{'user.adv'} ); - my %domdef; - unless ($domain eq 'public') { - %domdef = &Apache::lonnet::get_domain_defaults($domain); + 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; + } } - foreach my $tool ('aboutme','blog','webdav','portfolio') { - $userenv{'availabletools.'.$tool} = - &Apache::lonnet::usertools_access($username,$domain,$tool,'reload', - undef,\%userenv,\%domdef,\%is_adv); - } + unless ($domain eq 'public') { + my %is_adv = ( is_adv => $env{'user.adv'} ); + my %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','timezone') { + $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', - \%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'}; + foreach my $crstype ('official','unofficial','community','textbook','placement','lti') { + $userenv{'canrequest.'.$crstype} = + &Apache::lonnet::usertools_access($username,$domain,$crstype, + 'reload','requestcourses', + \%userenv,\%domdef,\%is_adv); } - } + $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'}; + } + } + my ($types,$typename) = &course_types(); + if (ref($types) eq 'ARRAY') { + my @options = ('approval','validate','autolimit'); + my $optregex = join('|',@options); + my (%willtrust,%trustchecked); + foreach my $type (@{$types}) { + my $dom_str = $env{'environment.reqcrsotherdom.'.$type}; + if ($dom_str ne '') { + my $updatedstr = ''; + my @possdomains = split(',',$dom_str); + foreach my $entry (@possdomains) { + my ($extdom,$extopt) = split(':',$entry); + unless ($trustchecked{$extdom}) { + $willtrust{$extdom} = &Apache::lonnet::will_trust('reqcrs',$domain,$extdom); + $trustchecked{$extdom} = 1; + } + if ($willtrust{$extdom}) { + $updatedstr .= $entry.','; + } + } + $updatedstr =~ s/,$//; + if ($updatedstr) { + $userenv{'reqcrsotherdom.'.$type} = $updatedstr; + } else { + delete($userenv{'reqcrsotherdom.'.$type}); + } + } + } + } + } $env{'user.environment'} = "$lonids/$cookie.id"; if (tie(my %disk_env,'GDBM_File',"$lonids/$cookie.id", @@ -15625,15 +17732,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', ); @@ -15641,6 +17752,8 @@ sub build_filters { my $typeval = 'Course'; if ($crstype eq 'Community') { $typeval = 'Community'; + } elsif ($crstype eq 'Placement') { + $typeval = 'Placement'; } $typeselectform = ''; } else { @@ -15649,9 +17762,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.=""; } @@ -16002,7 +18121,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]; @@ -16198,24 +18317,52 @@ sub needs_coursereinit { $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); - } + my $blocked = &blocking_status('reinit',undef,$cnum,$cdom,undef,1); + if ($blocked) { + return (); + } + my $update; + my $lastmainchange = &Apache::lonnet::get_coursechange($cdom,$cnum); + my $lastsuppchange = &Apache::lonnet::get_suppchange($cdom,$cnum); + if ($lastmainchange > $env{'request.course.tied'}) { + my ($needswitch,$switchwarning,$switchserver) = &switch_for_update($loncaparev,$cdom,$cnum); + if ($needswitch) { + return ('switch',$switchwarning,$switchserver); + } + $update = 'main'; + } + if ($lastsuppchange > $env{'request.course.suppupdated'}) { + if ($update) { + $update = 'both'; + } else { + my ($needswitch,$switchwarning,$switchserver) = &switch_for_update($loncaparev,$cdom,$cnum); + if ($needswitch) { + return ('switch',$switchwarning,$switchserver); + } else { + $update = 'supp'; } } - return ('update'); + return ($update); + } + } + return (); +} + +sub switch_for_update { + my ($loncaparev,$cdom,$cnum) = @_; + 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 (); @@ -16225,19 +18372,31 @@ sub update_content_constraints { my ($cdom,$cnum,$chome,$cid) = @_; my %curr_reqd_hash = &Apache::lonnet::userenvironment($cdom,$cnum,'internal.releaserequired'); my ($reqdmajor,$reqdminor) = split(/\./,$curr_reqd_hash{'internal.releaserequired'}); - my %checkresponsetypes; + my (%checkresponsetypes,%checkcrsrestypes); foreach my $key (keys(%Apache::lonnet::needsrelease)) { - my ($item,$name,$value,$valmatch) = split(/:/,$key); + my ($item,$name,$value) = split(/:/,$key); if ($item eq 'resourcetag') { if ($name eq 'responsetype') { $checkresponsetypes{$value} = $Apache::lonnet::needsrelease{$key} } + } elsif ($item eq 'course') { + if ($name eq 'courserestype') { + $checkcrsrestypes{$value} = $Apache::lonnet::needsrelease{$key}; + } } } my $navmap = Apache::lonnavmaps::navmap->new(); if (defined($navmap)) { - my %allresponses; - foreach my $res ($navmap->retrieveResources(undef,sub { $_[0]->is_problem() },1,0)) { + my (%allresponses,%allcrsrestypes); + foreach my $res ($navmap->retrieveResources(undef,sub { $_[0]->is_problem() || $_[0]->is_tool() },1,0)) { + if ($res->is_tool()) { + if ($allcrsrestypes{'exttool'}) { + $allcrsrestypes{'exttool'} ++; + } else { + $allcrsrestypes{'exttool'} = 1; + } + next; + } my %responses = $res->responseTypes(); foreach my $key (keys(%responses)) { next unless(exists($checkresponsetypes{$key})); @@ -16250,8 +18409,20 @@ sub update_content_constraints { ($reqdmajor,$reqdminor) = ($major,$minor); } } + foreach my $key (keys(%allcrsrestypes)) { + my ($major,$minor) = split(/\./,$checkcrsrestypes{$key}); + if (($major > $reqdmajor) || ($major == $reqdmajor && $minor > $reqdminor)) { + ($reqdmajor,$reqdminor) = ($major,$minor); + } + } undef($navmap); } + if (&Apache::lonnet::count_supptools($cnum,$cdom,1)) { + my ($major,$minor) = split(/\./,$checkcrsrestypes{'exttool'}); + if (($major > $reqdmajor) || ($major == $reqdmajor && $minor > $reqdminor)) { + ($reqdmajor,$reqdminor) = ($major,$minor); + } + } unless (($reqdmajor eq '') && ($reqdminor eq '')) { &Apache::lonnet::update_released_required($reqdmajor.'.'.$reqdminor,$cdom,$cnum,$chome,$cid); } @@ -16307,33 +18478,152 @@ sub parse_supplemental_title { return $title; } +sub get_supplemental { + my ($cnum,$cdom,$ignorecache,$possdel)=@_; + my $hashid=$cnum.':'.$cdom; + my ($supplemental,$cached,$set_httprefs); + unless ($ignorecache) { + ($supplemental,$cached) = &Apache::lonnet::is_cached_new('supplemental',$hashid); + } + unless (defined($cached)) { + my $chome=&Apache::lonnet::homeserver($cnum,$cdom); + unless ($chome eq 'no_host') { + my @order = @LONCAPA::map::order; + my @resources = @LONCAPA::map::resources; + my @resparms = @LONCAPA::map::resparms; + my @zombies = @LONCAPA::map::zombies; + my ($errors,%ids,%hidden); + $errors = + &recurse_supplemental($cnum,$cdom,'supplemental.sequence', + $errors,$possdel,\%ids,\%hidden); + @LONCAPA::map::order = @order; + @LONCAPA::map::resources = @resources; + @LONCAPA::map::resparms = @resparms; + @LONCAPA::map::zombies = @zombies; + $set_httprefs = 1; + if ($env{'request.course.id'} eq $cdom.'_'.$cnum) { + &Apache::lonnet::appenv({'request.course.suppupdated' => time}); + } + $supplemental = { + ids => \%ids, + hidden => \%hidden, + }; + &Apache::lonnet::do_cache_new('supplemental',$hashid,$supplemental,600); + } + } + return ($supplemental,$set_httprefs); +} + sub recurse_supplemental { - my ($cnum,$cdom,$suppmap,$numfiles,$errors) = @_; - if ($suppmap) { + my ($cnum,$cdom,$suppmap,$errors,$possdel,$suppids,$hiddensupp,$hidden) = @_; + if (($suppmap) && (ref($suppids) eq 'HASH') && (ref($hiddensupp) eq 'HASH')) { + my $mapnum; + if ($suppmap eq 'supplemental.sequence') { + $mapnum = 0; + } else { + ($mapnum) = ($suppmap =~ /^supplemental_(\d+)\.sequence$/); + } my ($errtext,$fatal) = &LONCAPA::map::mapread('/uploaded/'.$cdom.'/'.$cnum.'/'.$suppmap); if ($fatal) { $errors ++; } else { - if ($#LONCAPA::map::resources > 0) { - foreach my $res (@LONCAPA::map::resources) { - my ($title,$src,$ext,$type,$status)=split(/\:/,$res); + my @order = @LONCAPA::map::order; + if (@order > 0) { + my @resources = @LONCAPA::map::resources; + my @resparms = @LONCAPA::map::resparms; + foreach my $idx (@order) { + my ($title,$src,$ext,$type,$status)=split(/\:/,$resources[$idx]); if (($src ne '') && ($status eq 'res')) { + my $id = $mapnum.':'.$idx; + push(@{$suppids->{$src}},$id); + if (($hidden) || (&get_supp_parameter($resparms[$idx],'parameter_hiddenresource') =~ /^yes/i)) { + $hiddensupp->{$id} = 1; + } if ($src =~ m{^\Q/uploaded/$cdom/$cnum/\E(supplemental_\d+\.sequence)$}) { - ($numfiles,$errors) = &recurse_supplemental($cnum,$cdom,$1,$numfiles,$errors); + $errors = &recurse_supplemental($cnum,$cdom,$1,$errors,$possdel,$suppids, + $hiddensupp,$hiddensupp->{$id}); } else { - $numfiles ++; + my $allowed; + if (($env{'request.role.adv'}) || (!$hiddensupp->{$id})) { + $allowed = 1; + } elsif ($possdel) { + foreach my $item (@{$suppids->{$src}}) { + next if ($item eq $id); + unless ($hiddensupp->{$item}) { + $allowed = 1; + last; + } + } + if ((!$allowed) && (exists($env{'httpref.'.$src}))) { + &Apache::lonnet::delenv('httpref.'.$src); + } + } + if ($allowed && (!exists($env{'httpref.'.$src}))) { + &Apache::lonnet::allowuploaded('/adm/coursedoc',$src); + } } } } } } } - return ($numfiles,$errors); + return $errors; +} + +sub set_supp_httprefs { + my ($cnum,$cdom,$supplemental,$possdel) = @_; + if (ref($supplemental) eq 'HASH') { + if ((ref($supplemental->{'ids'}) eq 'HASH') && (ref($supplemental->{'hidden'}) eq 'HASH')) { + foreach my $src (keys(%{$supplemental->{'ids'}})) { + next if ($src =~ /\.sequence$/); + if (ref($supplemental->{'ids'}->{$src}) eq 'ARRAY') { + my $allowed; + if ($env{'request.role.adv'}) { + $allowed = 1; + } else { + foreach my $id (@{$supplemental->{'ids'}->{$src}}) { + unless ($supplemental->{'hidden'}->{$id}) { + $allowed = 1; + last; + } + } + } + if (exists($env{'httpref.'.$src})) { + if ($possdel) { + unless ($allowed) { + &Apache::lonnet::delenv('httpref.'.$src); + } + } + } elsif ($allowed) { + &Apache::lonnet::allowuploaded('/adm/coursedoc',$src); + } + } + } + if ($env{'request.course.id'} eq $cdom.'_'.$cnum) { + &Apache::lonnet::appenv({'request.course.suppupdated' => time}); + } + } + } +} + +sub get_supp_parameter { + my ($resparm,$name)=@_; + return if ($resparm eq ''); + my $value=undef; + my $ptype=undef; + foreach (split('&&&',$resparm)) { + my ($thistype,$thisname,$thisvalue)=split('___',$_); + if ($thisname eq $name) { + $value=$thisvalue; + $ptype=$thistype; + } + } + return $value; } sub symb_to_docspath { - my ($symb) = @_; - return unless ($symb); + my ($symb,$navmapref) = @_; + return unless ($symb && ref($navmapref)); my ($mapurl,$id,$resurl) = &Apache::lonnet::decode_symb($symb); if ($resurl=~/\.(sequence|page)$/) { $mapurl=$resurl; @@ -16341,9 +18631,11 @@ sub symb_to_docspath { $mapurl=$env{'course.'.$env{'request.course.id'}.'.url'}; } my $mapresobj; - my $navmap = Apache::lonnavmaps::navmap->new(); - if (ref($navmap)) { - $mapresobj = $navmap->getResourceByUrl($mapurl); + unless (ref($$navmapref)) { + $$navmapref = Apache::lonnavmaps::navmap->new(); + } + if (ref($$navmapref)) { + $mapresobj = $$navmapref->getResourceByUrl($mapurl); } $mapurl=~s{^.*/([^/]+)\.(\w+)$}{$1}; my $type=$2; @@ -16353,7 +18645,7 @@ sub symb_to_docspath { if ($pcslist ne '') { foreach my $pc (split(/,/,$pcslist)) { next if ($pc <= 1); - my $res = $navmap->getByMapPc($pc); + my $res = $$navmapref->getByMapPc($pc); if (ref($res)) { my $thisurl = $res->src(); $thisurl=~s{^.*/([^/]+)\.\w+$}{$1}; @@ -16399,32 +18691,94 @@ sub symb_to_docspath { return $path; } +sub validate_folderpath { + my ($supplementalflag,$allowed,$coursenum,$coursedom) = @_; + if ($env{'form.folderpath'} ne '') { + my @items = split(/\&/,$env{'form.folderpath'}); + my ($badpath,$changed,$got_supp,$supppath,%supphidden,%suppids); + for (my $i=0; $i<@items; $i++) { + my $odd = $i%2; + if (($odd) && (!$supplementalflag) && ($items[$i] !~ /^[^:]*:(|\d+):(|1):(|1):(|1):(|1)$/)) { + $badpath = 1; + } elsif ($odd && $supplementalflag) { + my $idx = $i-1; + if ($items[$i] =~ /^([^:]*)::(|1):::$/) { + my $esc_name = $1; + if ((!$allowed) || ($items[$idx] eq 'supplemental')) { + $supppath .= '&'.$esc_name; + $changed = 1; + } else { + $supppath .= '&'.$items[$i]; + } + } elsif (($allowed) && ($items[$idx] ne 'supplemental')) { + $changed = 1; + my $is_hidden; + unless ($got_supp) { + my ($supplemental) = &get_supplemental($coursenum,$coursedom); + if (ref($supplemental) eq 'HASH') { + if (ref($supplemental->{'hidden'}) eq 'HASH') { + %supphidden = %{$supplemental->{'hidden'}}; + } + if (ref($supplemental->{'ids'}) eq 'HASH') { + %suppids = %{$supplemental->{'ids'}}; + } + } + $got_supp = 1; + } + if (ref($suppids{"/uploaded/$coursedom/$coursenum/$items[$idx].sequence"}) eq 'ARRAY') { + my $mapid = $suppids{"/uploaded/$coursedom/$coursenum/$items[$idx].sequence"}->[0]; + if ($supphidden{$mapid}) { + $is_hidden = 1; + } + } + $supppath .= '&'.$items[$i].'::'.$is_hidden.':::'; + } else { + $supppath .= '&'.$items[$i]; + } + } elsif ((!$odd) && ($items[$i] !~ /^(default|supplemental)(|_\d+)$/)) { + $badpath = 1; + } elsif ($supplementalflag) { + $supppath .= '&'.$items[$i]; + } + last if ($badpath); + } + if ($badpath) { + delete($env{'form.folderpath'}); + } elsif ($changed && $supplementalflag) { + $supppath =~ s/^\&//; + $env{'form.folderpath'} = $supppath; + } + } + return; +} + sub captcha_display { - my ($context,$lonhost) = @_; + my ($context,$lonhost,$defdom) = @_; my ($output,$error); - my ($captcha,$pubkey,$privkey) = &get_captcha_config($context,$lonhost); + my ($captcha,$pubkey,$privkey,$version) = + &get_captcha_config($context,$lonhost,$defdom); if ($captcha eq 'original') { $output = &create_captcha(); unless ($output) { $error = 'captcha'; } } elsif ($captcha eq 'recaptcha') { - $output = &create_recaptcha($pubkey); + $output = &create_recaptcha($pubkey,$version); unless ($output) { $error = 'recaptcha'; } } - return ($output,$error,$captcha); + return ($output,$error,$captcha,$version); } sub captcha_response { - my ($context,$lonhost) = @_; + my ($context,$lonhost,$defdom) = @_; my ($captcha_chk,$captcha_error); - my ($captcha,$pubkey,$privkey) = &get_captcha_config($context,$lonhost); + my ($captcha,$pubkey,$privkey,$version) = &get_captcha_config($context,$lonhost,$defdom); if ($captcha eq 'original') { ($captcha_chk,$captcha_error) = &check_captcha(); } elsif ($captcha eq 'recaptcha') { - $captcha_chk = &check_recaptcha($privkey); + $captcha_chk = &check_recaptcha($privkey,$version); } else { $captcha_chk = 1; } @@ -16432,8 +18786,8 @@ sub captcha_response { } sub get_captcha_config { - my ($context,$lonhost) = @_; - my ($captcha,$pubkey,$privkey,$hashtocheck); + my ($context,$lonhost,$dom_in_effect) = @_; + my ($captcha,$pubkey,$privkey,$version,$hashtocheck); my $hostname = &Apache::lonnet::hostname($lonhost); my $serverhomeID = &Apache::lonnet::get_server_homeID($hostname); my $serverhomedom = &Apache::lonnet::host_domain($serverhomeID); @@ -16449,6 +18803,10 @@ sub get_captcha_config { } if ($privkey && $pubkey) { $captcha = 'recaptcha'; + $version = $hashtocheck->{'recaptchaversion'}; + if ($version ne '2') { + $version = 1; + } } else { $captcha = 'original'; } @@ -16466,14 +18824,39 @@ 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'; } - } - return ($captcha,$pubkey,$privkey); + } 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); } sub create_captcha { @@ -16489,13 +18872,17 @@ 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; } @@ -16532,38 +18919,68 @@ sub check_captcha { } sub create_recaptcha { - 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 the text is hard to read, [_1] will replace them.', - 'reCAPTCHA refresh'). - '

    '; + 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'). + '

    '; + } } sub check_recaptcha { - my ($privkey) = @_; + my ($privkey,$version) = @_; my $captcha_chk; - 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 $ip = &Apache::lonnet::get_requestor_ip(); + if ($version >= 2) { + my %info = ( + secret => $privkey, + response => $env{'form.g-recaptcha-response'}, + remoteip => $ip, + ); + my $request=new HTTP::Request('POST','https://www.google.com/recaptcha/api/siteverify'); + $request->content(join('&',map { + my $name = escape($_); + "$name=" . ( ref($info{$_}) eq 'ARRAY' + ? join("&$name=", map {escape($_) } @{$info{$_}}) + : &escape($info{$_}) ); + } keys(%info))); + my $response = &LONCAPA::LWPReq::makerequest('',$request,'','',10,1); + 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, + $ip, + $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'); + my @fields = ('firstname','lastname','institution','web','location','officialemail','id'); my %titles = &Apache::lonlocal::texthash ( lastname => 'Last Name', firstname => 'First Name', @@ -16571,6 +18988,7 @@ 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); } @@ -16599,15 +19017,34 @@ sub cleanup_html { # Checks for critical messages and returns a redirect url if one exists. # $interval indicates how often to check for messages. +# $context is the calling context -- roles, grades, contents, menu or flip. sub critical_redirect { - my ($interval) = @_; + my ($interval,$context) = @_; + unless (($env{'user.domain'} ne '') && ($env{'user.name'} ne '')) { + return (); + } if ((time-$env{'user.criticalcheck.time'})>$interval) { + if (($env{'request.course.id'}) && (($context eq 'flip') || ($context eq 'contents'))) { + my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'}; + my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'}; + my $blocked = &blocking_status('alert',undef,$cnum,$cdom,undef,1); + if ($blocked) { + my $checkrole = "cm./$cdom/$cnum"; + if ($env{'request.course.sec'} ne '') { + $checkrole .= "/$env{'request.course.sec'}"; + } + unless ((&Apache::lonnet::allowed('evb',undef,undef,$checkrole)) && + ($env{'request.role'} !~ m{^st\./$cdom/$cnum})) { + return; + } + } + } 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\:/)) { + 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; return (1, $url); @@ -16651,14 +19088,355 @@ sub des_decrypt { } else { $cypher=new DES $keybin; } - 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)) ); + 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; + } return $plaintext; } +sub get_requested_shorturls { + my ($cdom,$cnum,$navmap) = @_; + return unless (ref($navmap)); + my ($numnew,$errors); + my @toshorten = &Apache::loncommon::get_env_multiple('form.addtiny'); + if (@toshorten) { + my (%maps,%resources,%titles); + &Apache::loncourserespicker::enumerate_course_contents($navmap,\%maps,\%resources,\%titles, + 'shorturls',$cdom,$cnum); + if (keys(%resources)) { + my %tocreate; + foreach my $item (sort {$a <=> $b} (@toshorten)) { + my $symb = $resources{$item}; + if ($symb) { + $tocreate{$cnum.'&'.$symb} = 1; + } + } + if (keys(%tocreate)) { + ($numnew,$errors) = &make_short_symbs($cdom,$cnum, + \%tocreate); + } + } + } + return ($numnew,$errors); +} + +sub make_short_symbs { + my ($cdom,$cnum,$tocreateref,$lockuser) = @_; + my ($numnew,@errors); + if (ref($tocreateref) eq 'HASH') { + my %tocreate = %{$tocreateref}; + if (keys(%tocreate)) { + my %coursetiny = &Apache::lonnet::dump('tiny',$cdom,$cnum); + my $su = Short::URL->new(no_vowels => 1); + my $init = ''; + my (%newunique,%addcourse,%courseonly,%failed); + # get lock on tiny db + my $now = time; + if ($lockuser eq '') { + $lockuser = $env{'user.name'}.':'.$env{'user.domain'}; + } + my $lockhash = { + "lock\0$now" => $lockuser, + }; + my $tries = 0; + my $gotlock = &Apache::lonnet::newput_dom('tiny',$lockhash,$cdom); + my ($code,$error); + while (($gotlock ne 'ok') && ($tries<3)) { + $tries ++; + sleep 1; + $gotlock = &Apache::lonnet::newput_dom('tiny',$lockhash,$cdom); + } + if ($gotlock eq 'ok') { + $init = &shorten_symbs($cdom,$init,$su,\%coursetiny,\%tocreate,\%newunique, + \%addcourse,\%courseonly,\%failed); + if (keys(%failed)) { + my $numfailed = scalar(keys(%failed)); + push(@errors,&mt('error: could not obtain unique six character URL for [quant,_1,resource]',$numfailed)); + } + if (keys(%newunique)) { + my $putres = &Apache::lonnet::newput_dom('tiny',\%newunique,$cdom); + if ($putres eq 'ok') { + $numnew = scalar(keys(%newunique)); + my $newputres = &Apache::lonnet::newput('tiny',\%addcourse,$cdom,$cnum); + unless ($newputres eq 'ok') { + push(@errors,&mt('error: could not store course look-up of short URLs')); + } + } else { + push(@errors,&mt('error: could not store unique six character URLs')); + } + } + my $dellockres = &Apache::lonnet::del_dom('tiny',["lock\0$now"],$cdom); + unless ($dellockres eq 'ok') { + push(@errors,&mt('error: could not release lockfile')); + } + } else { + push(@errors,&mt('error: could not obtain lockfile')); + } + if (keys(%courseonly)) { + my $result = &Apache::lonnet::newput('tiny',\%courseonly,$cdom,$cnum); + if ($result ne 'ok') { + push(@errors,&mt('error: could not update course look-up of short URLs')); + } + } + } + } + return ($numnew,\@errors); +} + +sub shorten_symbs { + my ($cdom,$init,$su,$coursetiny,$tocreate,$newunique,$addcourse,$courseonly,$failed) = @_; + return unless ((ref($su)) && (ref($coursetiny) eq 'HASH') && (ref($tocreate) eq 'HASH') && + (ref($newunique) eq 'HASH') && (ref($addcourse) eq 'HASH') && + (ref($courseonly) eq 'HASH') && (ref($failed) eq 'HASH')); + my (%possibles,%collisions); + foreach my $key (keys(%{$tocreate})) { + my $num = String::CRC32::crc32($key); + my $tiny = $su->encode($num,$init); + if ($tiny) { + $possibles{$tiny} = $key; + } + } + if (!$init) { + $init = 1; + } else { + $init ++; + } + if (keys(%possibles)) { + my @posstiny = keys(%possibles); + my $configuname = &Apache::lonnet::get_domainconfiguser($cdom); + my %currtiny = &Apache::lonnet::get('tiny',\@posstiny,$cdom,$configuname); + if (keys(%currtiny)) { + foreach my $key (keys(%currtiny)) { + next if ($currtiny{$key} eq ''); + if ($currtiny{$key} eq $possibles{$key}) { + my ($tcnum,$tsymb) = split(/\&/,$currtiny{$key}); + unless (($coursetiny->{$tsymb} eq $key) || ($addcourse->{$tsymb} eq $key) || ($courseonly->{$tsymb} eq $key)) { + $courseonly->{$tsymb} = $key; + } + } else { + $collisions{$possibles{$key}} = 1; + } + delete($possibles{$key}); + } + } + foreach my $key (keys(%possibles)) { + $newunique->{$key} = $possibles{$key}; + my ($tcnum,$tsymb) = split(/\&/,$possibles{$key}); + unless (($coursetiny->{$tsymb} eq $key) || ($addcourse->{$tsymb} eq $key) || ($courseonly->{$tsymb} eq $key)) { + $addcourse->{$tsymb} = $key; + } + } + } + if (keys(%collisions)) { + if ($init <5) { + if (!$init) { + $init = 1; + } else { + $init ++; + } + $init = &shorten_symbs($cdom,$init,$su,$coursetiny,\%collisions, + $newunique,$addcourse,$courseonly,$failed); + } else { + foreach my $key (keys(%collisions)) { + $failed->{$key} = 1; + } + } + } + return $init; +} + +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 $response = &LONCAPA::LWPReq::makerequest('',$request,'','',5); + 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; +} + +sub page_menu { + my ($menucolls,$menunum) = @_; + my %menu; + foreach my $item (split(/;/,$menucolls)) { + my ($num,$value) = split(/\%/,$item); + if ($num eq $menunum) { + my @entries = split(/\&/,$value); + foreach my $entry (@entries) { + my ($name,$fields) = split(/=/,$entry); + if (($name eq 'top') || ($name eq 'inline') || ($name eq 'foot') || ($name eq 'main')) { + $menu{$name} = $fields; + } else { + my @shown; + if ($fields =~ /,/) { + @shown = split(/,/,$fields); + } else { + @shown = ($fields); + } + if (@shown) { + foreach my $field (@shown) { + next if ($field eq ''); + $menu{$field} = 1; + } + } + } + } + } + } + return %menu; +} + 1; __END__;