--- loncom/interface/loncommon.pm 2019/08/28 02:38:42 1.1075.2.139 +++ loncom/interface/loncommon.pm 2016/10/10 03:02:47 1.1255 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # a pile of common routines # -# $Id: loncommon.pm,v 1.1075.2.139 2019/08/28 02:38:42 raeburn Exp $ +# $Id: loncommon.pm,v 1.1255 2016/10/10 03:02:47 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -71,18 +71,18 @@ use Apache::lonuserutils(); use Apache::lonuserstate(); use Apache::courseclassifier(); use LONCAPA qw(:DEFAULT :match); -use HTTP::Request; use DateTime::TimeZone; use DateTime::Locale; use Encode(); +use Text::Aspell; use Authen::Captcha; use Captcha::reCAPTCHA; use JSON::DWIW; use LWP::UserAgent; use Crypt::DES; use DynaLoader; # for Crypt::DES version -use File::Copy(); -use File::Path(); +use MIME::Lite; +use MIME::Types; # ---------------------------------------------- Designs use vars qw(%defaultdesign); @@ -167,6 +167,7 @@ sub ssi_with_retries { # ----------------------------------------------- Filetypes/Languages/Copyright my %language; my %supported_language; +my %supported_codes; my %latex_language; # For choosing hyphenation in my %latex_language_bykey; # for choosing hyphenation from metadata my %cprtag; @@ -197,18 +198,19 @@ BEGIN { { my $langtabfile = $Apache::lonnet::perlvar{'lonTabDir'}. '/language.tab'; - if ( open(my $fh,'<',$langtabfile) ) { + if ( open(my $fh,"<$langtabfile") ) { while (my $line = <$fh>) { next if ($line=~/^\#/); chomp($line); - my ($key,$two,$country,$three,$enc,$val,$sup,$latex)=(split(/\t/,$line)); + my ($key,$code,$country,$three,$enc,$val,$sup,$latex)=(split(/\t/,$line)); $language{$key}=$val.' - '.$enc; if ($sup) { $supported_language{$key}=$sup; + $supported_codes{$key} = $code; } if ($latex) { $latex_language_bykey{$key} = $latex; - $latex_language{$two} = $latex; + $latex_language{$code} = $latex; } } close($fh); @@ -218,7 +220,7 @@ BEGIN { { my $copyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}. '/copyright.tab'; - if ( open (my $fh,'<',$copyrightfile) ) { + if ( open (my $fh,"<$copyrightfile") ) { while (my $line = <$fh>) { next if ($line=~/^\#/); chomp($line); @@ -232,7 +234,7 @@ BEGIN { { my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}. '/source_copyright.tab'; - if ( open (my $fh,'<',$sourcecopyrightfile) ) { + if ( open (my $fh,"<$sourcecopyrightfile") ) { while (my $line = <$fh>) { next if ($line =~ /^\#/); chomp($line); @@ -246,7 +248,7 @@ BEGIN { # -------------------------------------------------------------- default domain designs my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors'; my $designfile = $designdir.'/default.tab'; - if ( open (my $fh,'<',$designfile) ) { + if ( open (my $fh,"<$designfile") ) { while (my $line = <$fh>) { next if ($line =~ /^\#/); chomp($line); @@ -260,12 +262,12 @@ BEGIN { { my $categoryfile = $Apache::lonnet::perlvar{'lonTabDir'}. '/filecategories.tab'; - if ( open (my $fh,'<',$categoryfile) ) { + if ( open (my $fh,"<$categoryfile") ) { while (my $line = <$fh>) { next if ($line =~ /^\#/); chomp($line); my ($extension,$category)=(split(/\s+/,$line,2)); - push(@{$category_extensions{lc($category)}},$extension); + push @{$category_extensions{lc($category)}},$extension; } close($fh); } @@ -275,7 +277,7 @@ BEGIN { { my $typesfile = $Apache::lonnet::perlvar{'lonTabDir'}. '/filetypes.tab'; - if ( open (my $fh,'<',$typesfile) ) { + if ( open (my $fh,"<$typesfile") ) { while (my $line = <$fh>) { next if ($line =~ /^\#/); chomp($line); @@ -678,7 +680,7 @@ if (!Array.prototype.indexOf) { var n = 0; if (arguments.length > 0) { n = Number(arguments[1]); - if (n !== n) { // shortcut for verifying if it's NaN + if (n !== n) { // shortcut for verifying if it is NaN n = 0; } else if (n !== 0 && n !== (1 / 0) && n !== -(1 / 0)) { n = (n > 0 || -1) * Math.floor(Math.abs(n)); @@ -879,6 +881,8 @@ sub selectcourse_link { my $linktext = &mt('Select Course'); if ($selecttype eq 'Community') { $linktext = &mt('Select Community'); + } elsif ($selecttype eq 'Placement') { + $linktext = &mt('Select Placement Test'); } elsif ($selecttype eq 'Course/Community') { $linktext = &mt('Select Course/Community'); $type = ''; @@ -914,12 +918,12 @@ sub check_uncheck_jscript { function checkAll(field) { if (field.length > 0) { for (i = 0; i < field.length; i++) { - if (!field[i].disabled) { + if (!field[i].disabled) { field[i].checked = true; } } } else { - if (!field.disabled) { + if (!field.disabled) { field.checked = true; } } @@ -939,8 +943,8 @@ ENDSCRT } sub select_timezone { - my ($name,$selected,$onchange,$includeempty,$disabled)=@_; - my $output=''."\n"; if ($includeempty) { $output .= '\n"; } $typeselectform.=""; } @@ -16108,7 +16274,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', @@ -16237,7 +16403,7 @@ $typeelement return $jscript.$clonewarning.$output; } -=pod +=pod =item * &timebased_select_form() @@ -16252,7 +16418,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 @@ -16289,7 +16455,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 @@ -16328,7 +16494,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). @@ -16340,7 +16506,7 @@ cloneruname - optional username of new c clonerudom - optional domain of new course owner -domcloner - optional "domcloner" flag; has value=1 if user has ccc priv in domain being filtered by, +domcloner - optional "domcloner" flag; has value=1 if user has ccc priv in domain being filtered by, (used when DC is using course creation form) codetitles - reference to array of titles of components in institutional codes (official courses). @@ -16350,8 +16516,8 @@ cc_clone - escaped comma separated list reqcrsdom - domain of new course, where search_courses is used to identify potential courses to clone -reqinstcode - institutional code of new course, where search_courses is used to identify potential - courses to clone +reqinstcode - institutional code of new course, where search_courses is used to identify potential + courses to clone Returns: %courses - hash of courses satisfying search criteria, keys = course IDs, values are corresponding colon-separated escaped description, institutional code, owner and type. @@ -16434,7 +16600,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]; @@ -16477,8 +16643,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. @@ -16591,7 +16757,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: @@ -16599,9 +16765,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. @@ -16609,10 +16775,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. @@ -16764,8 +16930,8 @@ sub recurse_supplemental { } sub symb_to_docspath { - my ($symb,$navmapref) = @_; - return unless ($symb && ref($navmapref)); + my ($symb) = @_; + return unless ($symb); my ($mapurl,$id,$resurl) = &Apache::lonnet::decode_symb($symb); if ($resurl=~/\.(sequence|page)$/) { $mapurl=$resurl; @@ -16773,11 +16939,9 @@ sub symb_to_docspath { $mapurl=$env{'course.'.$env{'request.course.id'}.'.url'}; } my $mapresobj; - unless (ref($$navmapref)) { - $$navmapref = Apache::lonnavmaps::navmap->new(); - } - if (ref($$navmapref)) { - $mapresobj = $$navmapref->getResourceByUrl($mapurl); + my $navmap = Apache::lonnavmaps::navmap->new(); + if (ref($navmap)) { + $mapresobj = $navmap->getResourceByUrl($mapurl); } $mapurl=~s{^.*/([^/]+)\.(\w+)$}{$1}; my $type=$2; @@ -16787,7 +16951,7 @@ sub symb_to_docspath { if ($pcslist ne '') { foreach my $pc (split(/,/,$pcslist)) { next if ($pc <= 1); - my $res = $$navmapref->getByMapPc($pc); + my $res = $navmap->getByMapPc($pc); if (ref($res)) { my $thisurl = $res->src(); $thisurl=~s{^.*/([^/]+)\.\w+$}{$1}; @@ -16834,10 +16998,10 @@ sub symb_to_docspath { } sub captcha_display { - my ($context,$lonhost,$defdom) = @_; + my ($context,$lonhost) = @_; my ($output,$error); - my ($captcha,$pubkey,$privkey,$version) = - &get_captcha_config($context,$lonhost,$defdom); + my ($captcha,$pubkey,$privkey,$version) = + &get_captcha_config($context,$lonhost); if ($captcha eq 'original') { $output = &create_captcha(); unless ($output) { @@ -16853,9 +17017,9 @@ sub captcha_display { } sub captcha_response { - my ($context,$lonhost,$defdom) = @_; + my ($context,$lonhost) = @_; my ($captcha_chk,$captcha_error); - my ($captcha,$pubkey,$privkey,$version) = &get_captcha_config($context,$lonhost,$defdom); + my ($captcha,$pubkey,$privkey,$version) = &get_captcha_config($context,$lonhost); if ($captcha eq 'original') { ($captcha_chk,$captcha_error) = &check_captcha(); } elsif ($captcha eq 'recaptcha') { @@ -16867,7 +17031,7 @@ sub captcha_response { } sub get_captcha_config { - my ($context,$lonhost,$dom_in_effect) = @_; + my ($context,$lonhost) = @_; my ($captcha,$pubkey,$privkey,$version,$hashtocheck); my $hostname = &Apache::lonnet::hostname($lonhost); my $serverhomeID = &Apache::lonnet::get_server_homeID($hostname); @@ -16907,7 +17071,7 @@ sub get_captcha_config { $captcha = 'recaptcha'; $version = $domconfhash{$serverhomedom.'.login.recaptchaversion'}; if ($version ne '2') { - $version = 1; + $version = 1; } } else { $captcha = 'original'; @@ -16915,27 +17079,6 @@ sub get_captcha_config { } elsif ($domconfhash{$serverhomedom.'.login.captcha'} eq 'original') { $captcha = 'original'; } - } elsif ($context eq 'passwords') { - if ($dom_in_effect) { - my %passwdconf = &Apache::lonnet::get_passwdconf($dom_in_effect); - if ($passwdconf{'captcha'} eq 'recaptcha') { - if (ref($passwdconf{'recaptchakeys'}) eq 'HASH') { - $pubkey = $passwdconf{'recaptchakeys'}{'public'}; - $privkey = $passwdconf{'recaptchakeys'}{'private'}; - } - if ($privkey && $pubkey) { - $captcha = 'recaptcha'; - $version = $passwdconf{'recaptchaversion'}; - if ($version ne '2') { - $version = 1; - } - } else { - $captcha = 'original'; - } - } elsif ($passwdconf{'captcha'} ne 'notused') { - $captcha = 'original'; - } - } } return ($captcha,$pubkey,$privkey,$version); } @@ -17010,7 +17153,7 @@ sub create_recaptcha { &mt('If the text is hard to read, [_1] will replace them.', 'reCAPTCHA refresh'). '

'; - } + } } sub check_recaptcha { @@ -17020,7 +17163,7 @@ sub check_recaptcha { my $ua = LWP::UserAgent->new; $ua->timeout(10); my %info = ( - secret => $privkey, + secret => $privkey, response => $env{'form.g-recaptcha-response'}, remoteip => $ENV{'REMOTE_ADDR'}, ); @@ -17090,18 +17233,18 @@ sub cleanup_html { sub critical_redirect { my ($interval) = @_; if ((time-$env{'user.criticalcheck.time'})>$interval) { - my @what=&Apache::lonnet::dump('critical', $env{'user.domain'}, + my @what=&Apache::lonnet::dump('critical', $env{'user.domain'}, $env{'user.name'}); &Apache::lonnet::appenv({'user.criticalcheck.time'=>time}); my $redirecturl; if ($what[0]) { - if (($what[0] ne 'con_lost') && ($what[0]!~/^error\:/)) { - $redirecturl='/adm/email?critical=display'; - my $url=&Apache::lonnet::absolute_url().$redirecturl; + if (($what[0] ne 'con_lost') && ($what[0]!~/^error\:/)) { + $redirecturl='/adm/email?critical=display'; + my $url=&Apache::lonnet::absolute_url().$redirecturl; return (1, $url); } } - } + } return (); } @@ -17155,157 +17298,6 @@ sub des_decrypt { return $plaintext; } -sub is_nonframeable { - my ($url,$absolute,$hostname,$ip,$nocache) = @_; - my ($remprotocol,$remhost) = ($url =~ m{^(https?)\://(([a-z0-9]+(-[a-z0-9]+)*\.)+[a-z]{2,})}i); - return if (($remprotocol eq '') || ($remhost eq '')); - - $remprotocol = lc($remprotocol); - $remhost = lc($remhost); - my $remport = 80; - if ($remprotocol eq 'https') { - $remport = 443; - } - my ($result,$cached) = &Apache::lonnet::is_cached_new('noiframe',$remhost.':'.$remport); - if ($cached) { - unless ($nocache) { - if ($result) { - return 1; - } else { - return 0; - } - } - } - my $uselink; - my $request = new HTTP::Request('HEAD',$url); - my $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; -} - 1; __END__;