--- loncom/interface/loncommon.pm 2015/04/07 15:13:35 1.1075.2.92 +++ loncom/interface/loncommon.pm 2022/09/28 15:13:50 1.1389 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # a pile of common routines # -# $Id: loncommon.pm,v 1.1075.2.92 2015/04/07 15:13:35 raeburn Exp $ +# $Id: loncommon.pm,v 1.1389 2022/09/28 15:13:50 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,12 +71,23 @@ use Apache::lonuserutils(); use Apache::lonuserstate(); use Apache::courseclassifier(); use LONCAPA qw(:DEFAULT :match); +use LONCAPA::LWPReq; +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); @@ -161,6 +172,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; @@ -191,18 +203,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); @@ -212,7 +225,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); @@ -226,7 +239,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); @@ -240,7 +253,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); @@ -254,12 +267,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); } @@ -269,7 +282,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); @@ -422,7 +435,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}; @@ -1196,7 +1257,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 @@ -1220,10 +1281,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); @@ -1237,11 +1300,7 @@ sub help_open_topic { $topic=~s/\W/\_/g; if (!$stayOnPage) { - if ($env{'browser.mobile'}) { - $link = "javascript:openMyModal('/adm/help/${filename}.hlp',$width,$height,'yes');"; - } else { - $link = "javascript:void(open('/adm/help/${filename}.hlp', 'Help_for_$topic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))"; - } + $link = "javascript:openMyModal('/adm/help/${filename}.hlp',$width,$height,'yes');"; } elsif ($stayOnPage eq 'popup') { $link = "javascript:void(open('/adm/help/${filename}.hlp', 'Help_for_$topic', 'menubar=0,toolbar=1,scrollbars=1,width=$width,height=$height,resizable=yes'))"; } else { @@ -1249,9 +1308,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.''; } @@ -1261,7 +1327,7 @@ sub help_open_topic { if ($imgid ne '') { $imgid = ' id="'.$imgid.'"'; } - $template.=' ' + $template.=' ' .''.&mt('Help: [_1]',$topic).''; unless ($not_author) { - $out .= ' ' - .&help_open_topic('Authoring_Output_Tags',&mt('Output Tags'),$stayOnPage,undef,600) - .' ' - .&help_open_topic('Authoring_Multilingual_Problems',&mt('Languages'),$stayOnPage,undef,600) - .''; + $out .= '' + .&help_open_topic('Authoring_Output_Tags',&mt('Output Tags'),$stayOnPage,undef,600) + .' ' + .&help_open_topic('Authoring_Multilingual_Problems',&mt('How to create problems in different languages'),$stayOnPage,undef,600) + .''; } $out .= ''; # End cheatsheet return $out; @@ -1334,20 +1400,20 @@ ENDOUTPUT # now just updates the help link and generates a blue icon sub help_open_menu { - my ($topic,$component_help,$faq,$bug,$stayOnPage,$width,$height,$text) + my ($topic,$component_help,$faq,$bug,$stayOnPage,$width,$height,$text,$links_target) = @_; $stayOnPage = 1; my $output; if ($component_help) { if (!$text) { $output=&help_open_topic($component_help,undef,$stayOnPage, - $width,$height); + $width,$height,'',$links_target); } else { my $help_text; $help_text=&unescape($topic); $output='
'. &help_open_topic($component_help,$help_text,$stayOnPage, - $width,$height).'
'; + $width,$height,'',$links_target).''; } } my $banner_link = &update_help_link($topic,$component_help,$faq,$bug,$stayOnPage); @@ -1355,12 +1421,10 @@ sub help_open_menu { } sub top_nav_help { - my ($text) = @_; + my ($text,$linkattr) = @_; $text = &mt($text); - my $stay_on_page; - unless ($env{'environment.remote'} eq 'on') { - $stay_on_page = 1; - } + my $stay_on_page = 1; + my ($link,$banner_link); unless ($env{'request.noversionuri'} =~ m{^/adm/helpmenu}) { $link = ($stay_on_page) ? "javascript:helpMenu('display')" @@ -1371,7 +1435,7 @@ sub top_nav_help { if ($link) { return <<"END"; $banner_link -$text +$text END } else { return ' '.$text.' '; @@ -1390,9 +1454,9 @@ sub help_menu_js { &Apache::loncommon::start_page('Help Menu', undef, {'frameset' => 1, 'js_ready' => 1, - 'use_absolute' => $httphost, + 'use_absolute' => $httphost, 'add_entries' => { - 'border' => '0', + 'border' => '0', 'rows' => "110,*",},}); my $end_page = &Apache::loncommon::end_page({'frameset' => 1, @@ -1456,19 +1520,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; @@ -1733,6 +1804,524 @@ 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 +// + function fold_box(curDepth, lastresource){ + + // we need a list because there can be several blocks you need to fold in one tag + var block = document.getElementsByName('foldblock_'+curDepth); + // but there is only one folding button per tag + var foldbutton = document.getElementById('folding_btn_'+curDepth); + + if(block.item(0).style.display == 'none'){ + + foldbutton.value = '@{[&mt("Hide")]}'; + for (i = 0; i < block.length; i++){ + block.item(i).style.display = ''; + } + }else{ + + foldbutton.value = '@{[&mt("Show")]}'; + for (i = 0; i < block.length; i++){ + // block.item(i).style.visibility = 'collapse'; + block.item(i).style.display = 'none'; + } + }; + saveState(lastresource); + } + + function saveState (lastresource) { + + var tag_list = getTagList(); + if(tag_list != null){ + var timestamp = new Date().getTime(); + var key = lastresource; + + // the value pattern is: 'time;key1,value1;key2,value2; ... ' + // starting with timestamp + var value = timestamp+';'; + + // building the list of key-value pairs + for(var i = 0; i < tag_list.length; i++){ + value += tag_list[i]+','; + value += document.getElementsByName(tag_list[i])[0].style.display+';'; + } + + // only iterate whole storage if nothing to override + if(localStorage.getItem(key) == null){ + + // prevent storage from growing large + if(localStorage.length > 50){ + var regex_getTimestamp = /^(?:\d)+;/; + var oldest_timestamp = regex_getTimestamp.exec(localStorage.key(0)); + var oldest_key; + + for(var i = 1; i < localStorage.length; i++){ + if (regex_getTimestamp.exec(localStorage.key(i)) < oldest_timestamp) { + oldest_key = localStorage.key(i); + oldest_timestamp = regex_getTimestamp.exec(oldest_key); + } + } + localStorage.removeItem(oldest_key); + } + } + localStorage.setItem(key,value); + } + } + + // restore folding status of blocks (on page load) + function restoreState (lastresource) { + if(localStorage.getItem(lastresource) != null){ + var key = lastresource; + var value = localStorage.getItem(key); + var regex_delTimestamp = /^\d+;/; + + value.replace(regex_delTimestamp, ''); + + var valueArr = value.split(';'); + var pairs; + var elements; + for (var i = 0; i < valueArr.length; i++){ + pairs = valueArr[i].split(','); + elements = document.getElementsByName(pairs[0]); + + for (var j = 0; j < elements.length; j++){ + elements[j].style.display = pairs[1]; + if (pairs[1] == "none"){ + var regex_id = /([_\\d]+)\$/; + regex_id.exec(pairs[0]); + document.getElementById("folding_btn"+RegExp.\$1).value = "Show"; + } + } + } + } + } + + function getTagList () { + + var stringToSearch = document.lonhomework.innerHTML; + + var ret = new Array(); + var regex_findBlock = /(foldblock_.*?)"/g; + var tag_list = stringToSearch.match(regex_findBlock); + + if(tag_list != null){ + for(var i = 0; i < tag_list.length; i++){ + ret.push(tag_list[i].replace(/"/, '')); + } + } + return ret; + } + + function saveScrollPosition (resource) { + var tag_list = getTagList(); + + // we dont always want to jump to the first block + // 170 is roughly above the "Problem Editing" header. we just want to save if the user scrolled down further than this + if(\$(window).scrollTop() > 170){ + if(tag_list != null){ + var result; + for(var i = 0; i < tag_list.length; i++){ + if(isElementInViewport(tag_list[i])){ + result += tag_list[i]+';'; + } + } + sessionStorage.setItem('anchor_'+resource, result); + } + } else { + // we dont need to save zero, just delete the item to leave everything tidy + sessionStorage.removeItem('anchor_'+resource); + } + } + + function restoreScrollPosition(resource){ + + var elem = sessionStorage.getItem('anchor_'+resource); + if(elem != null){ + var tag_list = elem.split(';'); + var elem_list; + + for(var i = 0; i < tag_list.length; i++){ + elem_list = document.getElementsByName(tag_list[i]); + + if(elem_list.length > 0){ + elem = elem_list[0]; + break; + } + } + elem.scrollIntoView(); + } + } + + function isElementInViewport(el) { + + // change to last element instead of first + var elem = document.getElementsByName(el); + var rect = elem[0].getBoundingClientRect(); + + return ( + rect.top >= 0 && + rect.left >= 0 && + rect.bottom <= (window.innerHeight || document.documentElement.clientHeight) && /*or $(window).height() */ + rect.right <= (window.innerWidth || document.documentElement.clientWidth) /*or $(window).width() */ + ); + } + + function autosize(depth){ + var cmInst = window['cm'+depth]; + var fitsizeButton = document.getElementById('fitsize'+depth); + + // is fixed size, switching to dynamic + if (sessionStorage.getItem("autosized_"+depth) == null) { + cmInst.setSize("","auto"); + fitsizeButton.value = "@{[&mt('Fixed size')]}"; + sessionStorage.setItem("autosized_"+depth, "yes"); + + // is dynamic size, switching to fixed + } else { + cmInst.setSize("","300px"); + fitsizeButton.value = "@{[&mt('Dynamic size')]}"; + sessionStorage.removeItem("autosized_"+depth); + } + } + +$browse_or_search + +// ]]> + +COLORFULEDIT +} + +sub xmleditor_js { + return < + +XMLEDIT +} + +sub insert_folding_button { + my $curDepth = $Apache::lonxml::curdepth; + my $lastresource = $env{'request.ambiguous'}; + + return ""; +} + +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 @@ -1920,10 +2509,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))]; @@ -1992,12 +2595,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 \n"; + my $disabled; + if ($readonly) { + $disabled = ' disabled="disabled"'; + } + my $selectform = " form to allow a user to select the domain to preform an operation in. @@ -2194,16 +2804,21 @@ The optional $onchange argument specifie The optional $incdoms is a reference to an array of domains which will be the only available options. -The optional $excdoms is a reference to an array of domains which will be excluded from the available options. +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}); @@ -2212,9 +2827,9 @@ sub select_dom_form { } if ($includeempty) { @domains=('',@domains); } if (ref($excdoms) eq 'ARRAY') { - map { $exclude{$_} = 1; } @{$excdoms}; + map { $exclude{$_} = 1; } @{$excdoms}; } - my $selectdomain = "\n"; foreach my $dom (@domains) { next if ($exclude{$dom}); $selectdomain.="\n"; + ($posstype eq $crstype ? ' selected="selected" ' : ''). ">".$shown."\n"; } $typeselectform.=""; } @@ -15105,7 +17793,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', @@ -15234,7 +17922,7 @@ $typeelement return $jscript.$clonewarning.$output; } -=pod +=pod =item * &timebased_select_form() @@ -15249,7 +17937,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 @@ -15286,7 +17974,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 @@ -15325,7 +18013,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). @@ -15337,11 +18025,18 @@ cloneruname - optional username of new c clonerudom - optional domain of new course owner -domcloner - Optional "domcloner" flag; has value=1 if user has ccc priv in domain being filtered by, +domcloner - optional "domcloner" flag; has value=1 if user has ccc priv in domain being filtered by, (used when DC is using course creation form) codetitles - reference to array of titles of components in institutional codes (official courses). +cc_clone - escaped comma separated list of courses for which course cloner has active CC role + (and so can clone automatically) + +reqcrsdom - domain of new course, where search_courses is used to identify potential courses to clone + +reqinstcode - institutional code of new course, where search_courses is used to identify potential + courses to clone Returns: %courses - hash of courses satisfying search criteria, keys = course IDs, values are corresponding colon-separated escaped description, institutional code, owner and type. @@ -15352,7 +18047,8 @@ Side Effects: None sub search_courses { - my ($dom,$type,$filter,$numtitles,$cloneruname,$clonerudom,$domcloner,$codetitles) = @_; + my ($dom,$type,$filter,$numtitles,$cloneruname,$clonerudom,$domcloner,$codetitles, + $cc_clone,$reqcrsdom,$reqinstcode) = @_; my (%courses,%showcourses,$cloner); if (($filter->{'ownerfilter'} ne '') || ($filter->{'ownerdomfilter'} ne '')) { @@ -15400,10 +18096,10 @@ sub search_courses { $filter->{'combownerfilter'}, $filter->{'coursefilter'}, undef,undef,$type,$regexpok,undef,undef, - undef,undef,$cloner,$env{'form.cc_clone'}, + undef,undef,$cloner,$cc_clone, $filter->{'cloneableonly'}, $createdbefore,$createdafter,undef, - $domcloner); + $domcloner,undef,$reqcrsdom,$reqinstcode); if (($filter->{'personfilter'} ne '') && ($filter->{'persondomfilter'} ne '')) { my $ccrole; if ($type eq 'Community') { @@ -15423,7 +18119,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]; @@ -15466,8 +18162,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. @@ -15580,7 +18276,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: @@ -15588,9 +18284,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. @@ -15598,10 +18294,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. @@ -15619,8 +18315,12 @@ 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}); + my $blocked = &blocking_status('reinit',undef,$cnum,$cdom,undef,1); + if ($blocked) { + return (); + } + my $lastchange = &Apache::lonnet::get_coursechange($cdom,$cnum); if ($lastchange > $env{'request.course.tied'}) { my %curr_reqd_hash = &Apache::lonnet::userenvironment($cdom,$cnum,'internal.releaserequired'); if ($curr_reqd_hash{'internal.releaserequired'} ne '') { @@ -15643,22 +18343,34 @@ sub needs_coursereinit { } sub update_content_constraints { - my ($cdom,$cnum,$chome,$cid) = @_; + my ($cdom,$cnum,$chome,$cid,$keeporder) = @_; 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) = 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})); @@ -15671,8 +18383,38 @@ 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); } + my (@resources,@order,@resparms,@zombies); + if ($keeporder) { + use LONCAPA::map; + @resources = @LONCAPA::map::resources; + @order = @LONCAPA::map::order; + @resparms = @LONCAPA::map::resparms; + @zombies = @LONCAPA::map::zombies; + } + my $suppmap = 'supplemental.sequence'; + my ($suppcount,$supptools,$errors) = (0,0,0); + ($suppcount,$supptools,$errors) = &recurse_supplemental($cnum,$cdom,$suppmap, + $suppcount,$supptools,$errors); + if ($keeporder) { + @LONCAPA::map::resources = @resources; + @LONCAPA::map::order = @order; + @LONCAPA::map::resparms = @resparms; + @LONCAPA::map::zombies = @zombies; + } + if ($supptools) { + 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); } @@ -15693,7 +18435,7 @@ sub allmaps_incourse { if ($lastchange > $env{'request.course.tied'}) { my ($furl,$ferr) = &Apache::lonuserstate::readmap("$cdom/$cnum"); unless ($ferr) { - &update_content_constraints($cdom,$cnum,$chome,$cid); + &update_content_constraints($cdom,$cnum,$chome,$cid,1); } } my $navmap = Apache::lonnavmaps::navmap->new(); @@ -15729,19 +18471,25 @@ sub parse_supplemental_title { } sub recurse_supplemental { - my ($cnum,$cdom,$suppmap,$numfiles,$errors) = @_; + my ($cnum,$cdom,$suppmap,$numfiles,$numexttools,$errors) = @_; if ($suppmap) { 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; + foreach my $idx (@order) { + my ($title,$src,$ext,$type,$status)=split(/\:/,$resources[$idx]); if (($src ne '') && ($status eq 'res')) { if ($src =~ m{^\Q/uploaded/$cdom/$cnum/\E(supplemental_\d+\.sequence)$}) { - ($numfiles,$errors) = &recurse_supplemental($cnum,$cdom,$1,$numfiles,$errors); + ($numfiles,$numexttools,$errors) = &recurse_supplemental($cnum,$cdom,$1, + $numfiles,$numexttools,$errors); } else { + if ($src =~ m{^/adm/$cdom/$cnum/\d+/ext\.tool$}) { + $numexttools ++; + } $numfiles ++; } } @@ -15749,12 +18497,12 @@ sub recurse_supplemental { } } } - return ($numfiles,$errors); + return ($numfiles,$numexttools,$errors); } 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; @@ -15762,9 +18510,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; @@ -15774,7 +18524,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}; @@ -15821,31 +18571,32 @@ sub symb_to_docspath { } 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; } @@ -15853,8 +18604,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); @@ -15870,6 +18621,10 @@ sub get_captcha_config { } if ($privkey && $pubkey) { $captcha = 'recaptcha'; + $version = $hashtocheck->{'recaptchaversion'}; + if ($version ne '2') { + $version = 1; + } } else { $captcha = 'original'; } @@ -15887,14 +18642,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 { @@ -15910,13 +18690,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; } @@ -15953,38 +18737,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', @@ -15992,6 +18806,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); } @@ -16020,21 +18835,40 @@ 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) { - my @what=&Apache::lonnet::dump('critical', $env{'user.domain'}, + 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\:/)) { - $redirecturl='/adm/email?critical=display'; - my $url=&Apache::lonnet::absolute_url().$redirecturl; + 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); } } - } + } return (); } @@ -16072,14 +18906,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__; 500 Internal Server Error

Internal Server Error

The server encountered an internal error or misconfiguration and was unable to complete your request.

Please contact the server administrator at root@localhost to inform them of the time this error occurred, and the actions you performed just before this error.

More information about this error may be available in the server error log.