--- loncom/interface/loncommon.pm 2020/09/08 04:19:48 1.1075.2.141.2.6 +++ loncom/interface/loncommon.pm 2021/06/20 17:38:14 1.1075.2.154 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # a pile of common routines # -# $Id: loncommon.pm,v 1.1075.2.141.2.6 2020/09/08 04:19:48 raeburn Exp $ +# $Id: loncommon.pm,v 1.1075.2.154 2021/06/20 17:38:14 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -83,8 +83,6 @@ use Crypt::DES; use DynaLoader; # for Crypt::DES version use File::Copy(); use File::Path(); -use String::CRC32(); -use Short::URL(); # ---------------------------------------------- Designs use vars qw(%defaultdesign); @@ -4425,6 +4423,59 @@ sub get_student_view_with_retries { } } +sub css_links { + my ($currsymb,$level) = @_; + my ($links,@symbs,%cssrefs,%httpref); + if ($level eq 'map') { + my $navmap = Apache::lonnavmaps::navmap->new(); + if (ref($navmap)) { + my ($map,undef,$url)=&Apache::lonnet::decode_symb($currsymb); + my @resources = $navmap->retrieveResources($map,sub { $_[0]->is_problem() },0,0); + foreach my $res (@resources) { + if (ref($res) && $res->symb()) { + push(@symbs,$res->symb()); + } + } + } + } else { + @symbs = ($currsymb); + } + foreach my $symb (@symbs) { + my $css_href = &Apache::lonnet::EXT('resource.0.cssfile',$symb); + if ($css_href =~ /\S/) { + unless ($css_href =~ m{https?://}) { + my $url = (&Apache::lonnet::decode_symb($symb))[-1]; + my $proburl = &Apache::lonnet::clutter($url); + my ($probdir) = ($proburl =~ m{(.+)/[^/]+$}); + unless ($css_href =~ m{^/}) { + $css_href = &Apache::lonnet::hreflocation($probdir,$css_href); + } + if ($css_href =~ m{^/(res|uploaded)/}) { + unless (($httpref{'httpref.'.$css_href}) || + (&Apache::lonnet::is_on_map($css_href))) { + my $thisurl = $proburl; + if ($env{'httpref.'.$proburl}) { + $thisurl = $env{'httpref.'.$proburl}; + } + $httpref{'httpref.'.$css_href} = $thisurl; + } + } + } + $cssrefs{$css_href} = 1; + } + } + if (keys(%httpref)) { + &Apache::lonnet::appenv(\%httpref); + } + if (keys(%cssrefs)) { + foreach my $css_href (keys(%cssrefs)) { + next unless ($css_href =~ m{^(/res/|/uploaded/|https?://)}); + $links .= ''."\n"; + } + } + return $links; +} + =pod =item * &get_student_answers() @@ -4680,13 +4731,13 @@ sub findallcourses { ############################################### sub blockcheck { - my ($setters,$activity,$uname,$udom,$url,$is_course) = @_; + my ($setters,$activity,$uname,$udom,$url,$is_course,$symb,$caller) = @_; if (defined($udom) && defined($uname)) { # If uname and udom are for a course, check for blocks in the course. if (($is_course) || (&Apache::lonnet::is_course($udom,$uname))) { my ($startblock,$endblock,$triggerblock) = - &get_blocks($setters,$activity,$udom,$uname,$url); + &get_blocks($setters,$activity,$udom,$uname,$url,$symb,$caller); return ($startblock,$endblock,$triggerblock); } } else { @@ -4703,8 +4754,7 @@ sub blockcheck { # boards, chat or groups, check for blocking in current course only. if (($activity eq 'boards' || $activity eq 'chat' || - $activity eq 'groups' || $activity eq 'printout' || - $activity eq 'reinit' || $activity eq 'alert') && + $activity eq 'groups' || $activity eq 'printout') && ($env{'request.course.id'})) { foreach my $key (keys(%live_courses)) { if ($key ne $env{'request.course.id'}) { @@ -4814,7 +4864,7 @@ sub blockcheck { # of specified user, unless user has 'evb' privilege. my ($start,$end,$trigger) = - &get_blocks($setters,$activity,$cdom,$cnum,$url); + &get_blocks($setters,$activity,$cdom,$cnum,$url,$symb,$caller); if (($start != 0) && (($startblock == 0) || ($startblock > $start))) { $startblock = $start; @@ -4834,7 +4884,7 @@ sub blockcheck { } sub get_blocks { - my ($setters,$activity,$cdom,$cnum,$url) = @_; + my ($setters,$activity,$cdom,$cnum,$url,$symb,$caller) = @_; my $startblock = 0; my $endblock = 0; my $triggerblock = ''; @@ -4847,7 +4897,13 @@ sub get_blocks { my $now = time; my %commblocks = &Apache::lonnet::get_comm_blocks($cdom,$cnum); if ($activity eq 'docs') { - @blockers = &Apache::lonnet::has_comm_blocking('bre',undef,$url,\%commblocks); + my ($blocked,$nosymbcache,$noenccheck); + if (($caller eq 'blockedaccess') || ($caller eq 'blockingstatus')) { + $blocked = 1; + $nosymbcache = 1; + $noenccheck = 1; + } + @blockers = &Apache::lonnet::has_comm_blocking('bre',$symb,$url,$nosymbcache,$noenccheck,$blocked,\%commblocks); foreach my $block (@blockers) { if ($block =~ /^firstaccess____(.+)$/) { my $item = $1; @@ -4969,12 +5025,12 @@ sub parse_block_record { } sub blocking_status { - my ($activity,$uname,$udom,$url,$is_course) = @_; + my ($activity,$uname,$udom,$url,$is_course,$symb,$caller) = @_; my %setters; # check for active blocking my ($startblock,$endblock,$triggerblock) = - &blockcheck(\%setters,$activity,$uname,$udom,$url,$is_course); + &blockcheck(\%setters,$activity,$uname,$udom,$url,$is_course,$symb,$caller); my $blocked = 0; if ($startblock && $endblock) { $blocked = 1; @@ -4990,7 +5046,12 @@ sub blocking_status { $querystring .= "&udom=$udom" if ($udom =~ /^$match_domain$/); $querystring .= "&uname=$uname" if ($uname =~ /^$match_username$/); } elsif ($activity eq 'docs') { - $querystring .= '&url='.&HTML::Entities::encode($url,'&"'); + my $showurl = &Apache::lonenc::check_encrypt($url); + $querystring .= '&url='.&HTML::Entities::encode($showurl,'\'&"<>'); + if ($symb) { + my $showsymb = &Apache::lonenc::check_encrypt($symb); + $querystring .= '&symb='.&HTML::Entities::encode($showsymb,'\'&"<>'); + } } my $output .= <<'END_MYBLOCK'; @@ -5015,12 +5076,6 @@ END_MYBLOCK $text = &mt('Printing Blocked'); } elsif ($activity eq 'passwd') { $text = &mt('Password Changing Blocked'); - } elsif ($activity eq 'grades') { - $text = &mt('Gradebook Blocked'); - } elsif ($activity eq 'alert') { - $text = &mt('Checking Critical Messages Blocked'); - } elsif ($activity eq 'reinit') { - $text = &mt('Checking Course Update Blocked'); } $output .= <<"END_BLOCK";
@@ -5044,43 +5099,24 @@ sub check_ip_acc { if (!defined($acc) || $acc =~ /^\s*$/ || $acc =~/^\s*no\s*$/i) { return 1; } - my ($ip,$allowed); + my $allowed=0; + my $ip; if (($ENV{'REMOTE_ADDR'} eq '127.0.0.1') || ($ENV{'REMOTE_ADDR'} eq &Apache::lonnet::get_host_ip($Apache::lonnet::perlvar{'lonHostID'}))) { $ip = $env{'request.host'} || $ENV{'REMOTE_ADDR'} || $clientip; } else { - $ip = $ENV{'REMOTE_ADDR'} || $env{'request.host'} || $clientip; + my $remote_ip = &Apache::lonnet::get_requestor_ip(); + $ip = $remote_ip || $env{'request.host'} || $clientip; } my $name; - my %access = ( - allowfrom => 1, - denyfrom => 0, - ); - my @allows; - my @denies; - foreach my $item (split(',',$acc)) { - $item =~ s/^\s*//; - $item =~ s/\s*$//; - if ($item =~ /^\!(.+)$/) { - push(@denies,$1); - } else { - push(@allows,$item); - } - } - my $numdenies = scalar(@denies); - my $numallows = scalar(@allows); - my $count = 0; - foreach my $pattern (@denies,@allows) { - $count ++; - my $acctype = 'allowfrom'; - if ($count <= $numdenies) { - $acctype = 'denyfrom'; - } + foreach my $pattern (split(',',$acc)) { + $pattern =~ s/^\s*//; + $pattern =~ s/\s*$//; if ($pattern =~ /\*$/) { #35.8.* $pattern=~s/\*//; - if ($ip =~ /^\Q$pattern\E/) { $allowed=$access{$acctype}; } + if ($ip =~ /^\Q$pattern\E/) { $allowed=1; } } elsif ($pattern =~ /(\d+\.\d+\.\d+)\.\[(\d+)-(\d+)\]$/) { #35.8.3.[34-56] my $low=$2; @@ -5088,7 +5124,7 @@ sub check_ip_acc { $pattern=$1; if ($ip =~ /^\Q$pattern\E/) { my $last=(split(/\./,$ip))[3]; - if ($last <=$high && $last >=$low) { $allowed=$access{$acctype}; } + if ($last <=$high && $last >=$low) { $allowed=1; } } } elsif ($pattern =~ /^\*/) { #*.msu.edu @@ -5098,10 +5134,10 @@ sub check_ip_acc { my $netaddr=inet_aton($ip); ($name)=gethostbyaddr($netaddr,AF_INET); } - if ($name =~ /\Q$pattern\E$/i) { $allowed=$access{$acctype}; } + if ($name =~ /\Q$pattern\E$/i) { $allowed=1; } } elsif ($pattern =~ /\d+\.\d+\.\d+\.\d+/) { #127.0.0.1 - if ($ip =~ /^\Q$pattern\E/) { $allowed=$access{$acctype}; } + if ($ip =~ /^\Q$pattern\E/) { $allowed=1; } } else { #some.name.com if (!defined($name)) { @@ -5109,16 +5145,9 @@ sub check_ip_acc { my $netaddr=inet_aton($ip); ($name)=gethostbyaddr($netaddr,AF_INET); } - if ($name =~ /\Q$pattern\E$/i) { $allowed=$access{$acctype}; } - } - if ($allowed =~ /^(0|1)$/) { last; } - } - if ($allowed eq '') { - if ($numdenies && !$numallows) { - $allowed = 1; - } else { - $allowed = 0; + if ($name =~ /\Q$pattern\E$/i) { $allowed=1; } } + if ($allowed) { last; } } return $allowed; } @@ -7964,10 +7993,17 @@ ADDMETA unless (&Apache::lonnet::allowed('mau',$dom_in_use)) { my %domdefs = &Apache::lonnet::get_domain_defaults($dom_in_use); my $lonhost = $Apache::lonnet::perlvar{'lonHostID'}; - my $offload; + my ($offload,$offloadoth); if (ref($domdefs{'offloadnow'}) eq 'HASH') { if ($domdefs{'offloadnow'}{$lonhost}) { $offload = 1; + if (($env{'user.domain'} ne '') && ($env{'user.domain'} ne $dom_in_use) && + (!(($env{'user.name'} eq 'public') && ($env{'user.domain'} eq 'public')))) { + unless (&Apache::lonnet::shared_institution($env{'user.domain'})) { + $offloadoth = 1; + $dom_in_use = $env{'user.domain'}; + } + } } } unless ($offload) { @@ -7977,6 +8013,7 @@ ADDMETA (!(($env{'user.name'} eq 'public') && ($env{'user.domain'} eq 'public')))) { unless (&Apache::lonnet::shared_institution($env{'user.domain'})) { $offload = 1; + $offloadoth = 1; $dom_in_use = $env{'user.domain'}; } } @@ -7985,6 +8022,12 @@ ADDMETA } if ($offload) { my $newserver = &Apache::lonnet::spareserver(30000,undef,1,$dom_in_use); + if (($newserver eq '') && ($offloadoth)) { + my @domains = &Apache::lonnet::current_machine_domains(); + if (($dom_in_use ne '') && (!grep(/^\Q$dom_in_use\E$/,@domains))) { + ($newserver) = &Apache::lonnet::choose_server($dom_in_use); + } + } if (($newserver) && ($newserver ne $lonhost)) { my $numsec = 5; my $timeout = $numsec * 1000; @@ -7998,7 +8041,7 @@ ADDMETA } if ($locknum) { my @lockinfo = sort(values(%locks)); - $msg = &mt('Once the following tasks are complete: ')."\n". + $msg = &mt('Once the following tasks are complete:')." \n". join(", ",sort(values(%locks)))."\n"; if (&show_course()) { $msg .= &mt('your session will be transferred to a different server, after you click "Courses".'); @@ -10375,11 +10418,15 @@ sub sorted_inst_types { } sub get_institutional_codes { - my ($settings,$allcourses,$LC_code) = @_; + my ($cdom,$crs,$settings,$allcourses,$LC_code) = @_; # Get complete list of course sections to update my @currsections = (); my @currxlists = (); + my (%unclutteredsec,%unclutteredlcsec); my $coursecode = $$settings{'internal.coursecode'}; + my $crskey = $crs.':'.$coursecode; + @{$unclutteredsec{$crskey}} = (); + @{$unclutteredlcsec{$crskey}} = (); if ($$settings{'internal.sectionnums'} ne '') { @currsections = split(/,/,$$settings{'internal.sectionnums'}); @@ -10390,8 +10437,8 @@ sub get_institutional_codes { } if (@currxlists > 0) { - foreach (@currxlists) { - if (m/^([^:]+):(\w*)$/) { + foreach my $xl (@currxlists) { + if ($xl =~ /^([^:]+):(\w*)$/) { unless (grep/^$1$/,@{$allcourses}) { push(@{$allcourses},$1); $$LC_code{$1} = $2; @@ -10399,15 +10446,28 @@ sub get_institutional_codes { } } } - + if (@currsections > 0) { - foreach (@currsections) { - if (m/^(\w+):(\w*)$/) { - my $sec = $coursecode.$1; + foreach my $sec (@currsections) { + if ($sec =~ m/^(\w+):(\w*)$/ ) { + my $instsec = $1; my $lc_sec = $2; - unless (grep/^$sec$/,@{$allcourses}) { + unless (grep/^\Q$instsec\E$/,@{$unclutteredsec{$crskey}}) { + push(@{$unclutteredsec{$crskey}},$instsec); + push(@{$unclutteredlcsec{$crskey}},$lc_sec); + } + } + } + } + + if (@{$unclutteredsec{$crskey}} > 0) { + my %formattedsec = &Apache::lonnet::auto_instsec_reformat($cdom,'clutter',\%unclutteredsec); + if ((ref($formattedsec{$crskey}) eq 'ARRAY') && (ref($unclutteredlcsec{$crskey}) eq 'ARRAY')) { + for (my $i=0; $i<@{$formattedsec{$crskey}}; $i++) { + my $sec = $coursecode.$formattedsec{$crskey}[$i]; + unless (grep/^\Q$sec\E$/,@{$allcourses}) { push(@{$allcourses},$sec); - $$LC_code{$sec} = $lc_sec; + $$LC_code{$sec} = $unclutteredlcsec{$crskey}[$i]; } } } @@ -15089,8 +15149,7 @@ sub check_clone { my $cloneid='/'.$args->{'clonedomain'}.'/'.$args->{'clonecourse'}; my ($clonecrsudom,$clonecrsunum)= &LONCAPA::split_courseid($cloneid); my $clonehome=&Apache::lonnet::homeserver($clonecrsunum,$clonecrsudom); - my $clonetitle; - my @clonemsg; + my $clonemsg; my $can_clone = 0; my $lctype = lc($args->{'crstype'}); if ($lctype ne 'community') { @@ -15098,38 +15157,16 @@ sub check_clone { } if ($clonehome eq 'no_host') { if ($args->{'crstype'} eq 'Community') { - 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'}], - })); + $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'}); } else { - 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'}], - })); - } + $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'}); + } } else { my %clonedesc = &Apache::lonnet::coursedescription($cloneid,{'one_time' => 1}); - $clonetitle = $clonedesc{'description'}; if ($args->{'crstype'} eq 'Community') { if ($clonedesc{'type'} ne 'Community') { - 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); + $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); } } if (($env{'request.role.domain'} eq $args->{'clonedomain'}) && @@ -15218,34 +15255,20 @@ sub check_clone { } unless ($can_clone) { if ($args->{'crstype'} eq 'Community') { - 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'}], - })); + $clonemsg = &mt('No new community created.').$linefeed.&mt('The new community could not be cloned from the existing community because the new community owner ([_1]) does not have cloning rights in the existing community ([_2]).',$args->{'ccuname'}.':'.$args->{'ccdomain'},$clonedesc{'description'}); } else { - 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'}], - })); - } + $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'}); + } } } } - return ($can_clone,\@clonemsg,$cloneid,$clonehome,$clonetitle); + return ($can_clone, $clonemsg, $cloneid, $clonehome); } sub construct_course { my ($args,$logmsg,$courseid,$crsudom,$crsunum,$udom,$uname,$context, - $cnum,$category,$coderef,$callercontext,$user_lh) = @_; - my ($outcome,$msgref,$clonemsgref); + $cnum,$category,$coderef) = @_; + my $outcome; my $linefeed = '
'."\n"; if ($context eq 'auto') { $linefeed = "\n"; @@ -15254,11 +15277,18 @@ sub construct_course { # # Are we cloning? # - my ($can_clone,$cloneid,$clonehome,$clonetitle); + my ($can_clone, $clonemsg, $cloneid, $clonehome); if (($args->{'clonecourse'}) && ($args->{'clonedomain'})) { - ($can_clone,$clonemsgref,$cloneid,$clonehome,$clonetitle) = &check_clone($args,$linefeed); + ($can_clone, $clonemsg, $cloneid, $clonehome) = &check_clone($args,$linefeed); + if ($context ne 'auto') { + if ($clonemsg ne '') { + $clonemsg = ''.$clonemsg.''; + } + } + $outcome .= $clonemsg.$linefeed; + if (!$can_clone) { - return (0,$outcome,$clonemsgref); + return (0,$outcome); } } @@ -15276,20 +15306,15 @@ sub construct_course { $args->{'ccuname'}.':'. $args->{'ccdomain'}, $args->{'crstype'}, - $cnum,$context,$category, - $callercontext); + $cnum,$context,$category); # 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. - if (($callercontext eq 'auto') && ($user_lh ne '')) { - $outcome .= &mt_user($user_lh,'New LON-CAPA [_1] ID: [_2]',$crstype,$$courseid).$linefeed; - } else { - $outcome .= &mt('New LON-CAPA [_1] ID: [_2]',$crstype,$$courseid).$linefeed; - } + $outcome .= &mt('New LON-CAPA [_1] ID: [_2]',$crstype,$$courseid).$linefeed; if ($$courseid =~ /^error:/) { - return (0,$outcome,$clonemsgref); + return (0,$outcome); } # @@ -15298,37 +15323,23 @@ sub construct_course { ($$crsudom,$$crsunum)= &LONCAPA::split_courseid($$courseid); my $crsuhome=&Apache::lonnet::homeserver($$crsunum,$$crsudom); if ($crsuhome eq 'no_host') { - 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('Course creation failed, unrecognized course home server.').$linefeed; + return (0,$outcome); } $outcome .= &mt('Created on').': '.$crsuhome.$linefeed; # # Do the cloning # - my @clonemsg; if ($can_clone && $cloneid) { - push(@clonemsg, - { - mt => 'Created [_1] by cloning from [_2]', - args => [$crstype,$clonetitle], - }); + $clonemsg = &mt('Cloning [_1] from [_2]',$crstype,$clonehome); + if ($context ne 'auto') { + $clonemsg = ''.$clonemsg.''; + } + $outcome .= $clonemsg.$linefeed; my %oldcenv=&Apache::lonnet::dump('environment',$$crsudom,$$crsunum); # Copy all files - my @info = - &Apache::lonclonecourse::copycoursefiles($cloneid,$$courseid,$args->{'datemode'}, - $args->{'dateshift'},$args->{'crscode'}, - $args->{'ccuname'}.':'.$args->{'ccdomain'}, - $args->{'tinyurls'}); - if (@info) { - push(@clonemsg,@info); - } + &Apache::lonclonecourse::copycoursefiles($cloneid,$$courseid,$args->{'datemode'},$args->{'dateshift'}); # Restore URL $cenv{'url'}=$oldcenv{'url'}; # Restore title @@ -15635,7 +15646,7 @@ sub construct_course { $outcome .= ($fatal?$errtext:'write ok').$linefeed; } - return (1,$outcome,\@clonemsg); + return (1,$outcome); } sub make_unique_code { @@ -15804,6 +15815,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) = @_; @@ -15906,6 +15935,7 @@ sub init_user_environment { # --------------------------------------------------------- Write first profile { + my $ip = &Apache::lonnet::get_requestor_ip(); my %initial_env = ("user.name" => $username, "user.domain" => $domain, @@ -15924,7 +15954,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'}; @@ -16784,12 +16814,8 @@ sub needs_coursereinit { $interval = 600; } if (($now-$env{'request.course.timechecked'})>$interval) { - &Apache::lonnet::appenv({'request.course.timechecked'=>$now}); - my $blocked = &blocking_status('reinit',$cnum,$cdom,undef,1); - if ($blocked) { - return (); - } 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 '') { @@ -17174,13 +17200,14 @@ sub create_recaptcha { sub check_recaptcha { my ($privkey,$version) = @_; my $captcha_chk; + my $ip = &Apache::lonnet::get_requestor_ip(); if ($version >= 2) { my $ua = LWP::UserAgent->new; $ua->timeout(10); my %info = ( secret => $privkey, response => $env{'form.g-recaptcha-response'}, - remoteip => $ENV{'REMOTE_ADDR'}, + remoteip => $ip, ); my $response = $ua->post('https://www.google.com/recaptcha/api/siteverify',\%info); if ($response->is_success) { @@ -17196,7 +17223,7 @@ sub check_recaptcha { my $captcha_result = $captcha->check_answer( $privkey, - $ENV{'REMOTE_ADDR'}, + $ip, $env{'form.recaptcha_challenge_field'}, $env{'form.recaptcha_response_field'}, ); @@ -17245,25 +17272,9 @@ 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,$context) = @_; + my ($interval) = @_; 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',$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}); @@ -17329,146 +17340,6 @@ sub des_decrypt { 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')); - } - } - } - } - } - 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; - $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);