$starting
+
+ENDPROGBAR
+ }
+ &r_print($r,$content.&LCprogressbar_script($LCcurrentid,$number_to_do));
}
sub LCprogressbarUpdate {
- my ($r,$val,$text)=@_;
- unless ($val) {
- if ($LClastpercent) {
- $val=$LClastpercent;
- } else {
- $val=0;
- }
+ my ($r,$val,$text,$number_to_do)=@_;
+ if ($number_to_do) {
+ unless ($val) {
+ if ($LClastpercent) {
+ $val=$LClastpercent;
+ } else {
+ $val=0;
+ }
+ }
+ if ($val<0) { $val=0; }
+ if ($val>100) { $val=0; }
+ $LClastpercent=$val;
+ unless ($text) { $text=$val.'%'; }
+ } else {
+ $val = 'false';
}
- if ($val<0) { $val=0; }
- if ($val>100) { $val=0; }
- $LClastpercent=$val;
- unless ($text) { $text=$val.'%'; }
$text=&js_ready($text);
&r_print($r,<'.$msg.'
'. &Apache::loncommon::end_page(); if (ref($r)) { @@ -10221,11 +11253,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'}); @@ -10236,8 +11272,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; @@ -10245,15 +11281,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]; } } } @@ -11503,7 +12552,7 @@ sub modify_html_refs { return; } } - if (open(my $fh,"<$container")) { + if (open(my $fh,'<',$container)) { $content = join('', <$fh>); close($fh); } else { @@ -11568,7 +12617,7 @@ sub modify_html_refs { } } } else { - if (open(my $fh,">$container")) { + if (open(my $fh,'>',$container)) { print $fh $content; close($fh); $output = ''.&mt('Updated [quant,_1,reference] in [_2].', @@ -12186,8 +13235,7 @@ sub process_decompression { if (ref($newdirlistref) eq 'ARRAY') { foreach my $dir_line (@{$newdirlistref}) { my ($item,undef,undef,$testdir)=split(/\&/,$dir_line,5); - unless (($item =~ /^\.+$/) || ($item eq $file) || - ((@to_skip > 0) && (grep(/^\Q$item\E$/,@to_skip)))) { + unless (($item =~ /^\.+$/) || ($item eq $file)) { push(@newitems,$item); if ($dirptr&$testdir) { $is_dir{$item} = 1; @@ -12775,7 +13823,7 @@ sub process_extracted_files { $newseqid{$i} = $newidx; unless ($errtext) { $result .= '
'."\n"; if ($context eq 'auto') { $linefeed = "\n"; @@ -15055,18 +16151,11 @@ sub construct_course { # # Are we cloning? # - my ($can_clone, $clonemsg, $cloneid, $clonehome); + my ($can_clone,$cloneid,$clonehome,$clonetitle); if (($args->{'clonecourse'}) && ($args->{'clonedomain'})) { - ($can_clone, $clonemsg, $cloneid, $clonehome) = &check_clone($args,$linefeed); - if ($context ne 'auto') { - if ($clonemsg ne '') { - $clonemsg = ''.$clonemsg.''; - } - } - $outcome .= $clonemsg.$linefeed; - + ($can_clone,$clonemsgref,$cloneid,$clonehome,$clonetitle) = &check_clone($args,$linefeed); if (!$can_clone) { - return (0,$outcome); + return (0,$outcome,$clonemsgref); } } @@ -15084,15 +16173,20 @@ sub construct_course { $args->{'ccuname'}.':'. $args->{'ccdomain'}, $args->{'crstype'}, - $cnum,$context,$category); + $cnum,$context,$category, + $callercontext); # Note: The testing routines depend on this being output; see # Utils::Course. This needs to at least be output as a comment # if anyone ever decides to not show this, and Utils::Course::new # will need to be suitably modified. - $outcome .= &mt('New LON-CAPA [_1] ID: [_2]',$crstype,$$courseid).$linefeed; + if (($callercontext eq 'auto') && ($user_lh ne '')) { + $outcome .= &mt_user($user_lh,'New LON-CAPA [_1] ID: [_2]',$crstype,$$courseid).$linefeed; + } else { + $outcome .= &mt('New LON-CAPA [_1] ID: [_2]',$crstype,$$courseid).$linefeed; + } if ($$courseid =~ /^error:/) { - return (0,$outcome); + return (0,$outcome,$clonemsgref); } # @@ -15101,23 +16195,37 @@ sub construct_course { ($$crsudom,$$crsunum)= &LONCAPA::split_courseid($$courseid); my $crsuhome=&Apache::lonnet::homeserver($$crsunum,$$crsudom); if ($crsuhome eq 'no_host') { - $outcome .= &mt('Course creation failed, unrecognized course home server.').$linefeed; - return (0,$outcome); + if (($callercontext eq 'auto') && ($user_lh ne '')) { + $outcome .= &mt_user($user_lh, + 'Course creation failed, unrecognized course home server.'); + } else { + $outcome .= &mt('Course creation failed, unrecognized course home server.'); + } + $outcome .= $linefeed; + return (0,$outcome,$clonemsgref); } $outcome .= &mt('Created on').': '.$crsuhome.$linefeed; # # Do the cloning -# +# + my @clonemsg; if ($can_clone && $cloneid) { - $clonemsg = &mt('Cloning [_1] from [_2]',$crstype,$clonehome); - if ($context ne 'auto') { - $clonemsg = ''.$clonemsg.''; - } - $outcome .= $clonemsg.$linefeed; + push(@clonemsg, + { + mt => 'Created [_1] by cloning from [_2]', + args => [$crstype,$clonetitle], + }); my %oldcenv=&Apache::lonnet::dump('environment',$$crsudom,$$crsunum); # Copy all files - &Apache::lonclonecourse::copycoursefiles($cloneid,$$courseid,$args->{'datemode'},$args->{'dateshift'}); + my @info = + &Apache::lonclonecourse::copycoursefiles($cloneid,$$courseid,$args->{'datemode'}, + $args->{'dateshift'},$args->{'crscode'}, + $args->{'ccuname'}.':'.$args->{'ccdomain'}, + $args->{'tinyurls'}); + if (@info) { + push(@clonemsg,@info); + } # Restore URL $cenv{'url'}=$oldcenv{'url'}; # Restore title @@ -15142,8 +16250,7 @@ sub construct_course { 'plc.users.denied', 'hidefromcat', 'checkforpriv', - 'categories', - 'internal.uniquecode'], + 'categories'], $$crsudom,$$crsunum); if ($args->{'textbook'}) { $cenv{'internal.textbook'} = $args->{'textbook'}; @@ -15158,6 +16265,9 @@ sub construct_course { if ($args->{'crstype'}) { $cenv{'type'}=$args->{'crstype'}; } + if ($args->{'lti'}) { + $cenv{'internal.lti'}=$args->{'lti'}; + } if ($args->{'crsid'}) { $cenv{'courseid'}=$args->{'crsid'}; } @@ -15384,19 +16494,23 @@ sub construct_course { # Open all assignments # if ($args->{'openall'}) { + my $opendate = time; + if ($args->{'openallfrom'} =~ /^\d+$/) { + $opendate = $args->{'openallfrom'}; + } my $storeunder=$$crsudom.'_'.$$crsunum.'.0.opendate'; - my %storecontent = ($storeunder => time, + my %storecontent = ($storeunder => $opendate, $storeunder.'.type' => 'date_start'); - - $outcome .= &mt('Opening all assignments').': '.&Apache::lonnet::cput - ('resourcedata',\%storecontent,$$crsudom,$$crsunum).$linefeed; + $outcome .= &mt('All assignments open starting [_1]', + &Apache::lonlocal::locallocaltime($opendate)).': '. + &Apache::lonnet::cput + ('resourcedata',\%storecontent,$$crsudom,$$crsunum).$linefeed; } # # Set first page # unless (($args->{'nonstandard'}) || ($args->{'firstres'} eq 'blank') || ($cloneid)) { - use LONCAPA::map; $outcome .= &mt('Setting first resource').': '; my $map = '/uploaded/'.$$crsudom.'/'.$$crsunum.'/default.sequence'; @@ -15419,7 +16533,7 @@ sub construct_course { $outcome .= ($fatal?$errtext:'write ok').$linefeed; } - return (1,$outcome); + return (1,$outcome,\@clonemsg); } sub make_unique_code { @@ -15503,12 +16617,13 @@ sub group_term { } sub course_types { - my @types = ('official','unofficial','community','textbook'); + my @types = ('official','unofficial','community','textbook','lti'); my %typename = ( official => 'Official course', unofficial => 'Unofficial course', community => 'Community', textbook => 'Textbook course', + lti => 'LTI provider', ); return (\@types,\%typename); } @@ -15588,6 +16703,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) = @_; @@ -15623,7 +16756,23 @@ sub init_user_environment { opendir(DIR,$lonids); while ($filename=readdir(DIR)) { if ($filename=~/^$username\_\d+\_$domain\_$authhost\.id$/) { - unlink($lonids.'/'.$filename); + if (tie(my %oldenv,'GDBM_File',"$lonids/$filename", + &GDBM_READER(),0640)) { + my $linkedfile; + if (exists($oldenv{'user.linkedenv'})) { + $linkedfile = $oldenv{'user.linkedenv'}; + } + untie(%oldenv); + if (unlink("$lonids/$filename")) { + if ($linkedfile =~ /^[a-f0-9]+_linked$/) { + if (-l "$lonids/$linkedfile.id") { + unlink("$lonids/$linkedfile.id"); + } + } + } + } else { + unlink($lonids.'/'.$filename); + } } } closedir(DIR); @@ -15658,7 +16807,8 @@ sub init_user_environment { my %userenv = &Apache::lonnet::dump('environment',$domain,$username); my ($tmp) = keys(%userenv); - if ($tmp =~ /^(con_lost|error|no_such_host)/i) { + if ($tmp !~ /^(con_lost|error|no_such_host)/i) { + } else { undef(%userenv); } if (($userenv{'interface'}) && (!$form->{'interface'})) { @@ -15673,6 +16823,7 @@ sub init_user_environment { # --------------------------------------------------------- Write first profile { + my $ip = &Apache::lonnet::get_requestor_ip(); my %initial_env = ("user.name" => $username, "user.domain" => $domain, @@ -15691,7 +16842,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'}; @@ -15723,13 +16874,13 @@ sub init_user_environment { my %is_adv = ( is_adv => $env{'user.adv'} ); my %domdef = &Apache::lonnet::get_domain_defaults($domain); - foreach my $tool ('aboutme','blog','webdav','portfolio') { + foreach my $tool ('aboutme','blog','webdav','portfolio','timezone') { $userenv{'availabletools.'.$tool} = &Apache::lonnet::usertools_access($username,$domain,$tool,'reload', undef,\%userenv,\%domdef,\%is_adv); } - foreach my $crstype ('official','unofficial','community','textbook') { + foreach my $crstype ('official','unofficial','community','textbook','lti') { $userenv{'canrequest.'.$crstype} = &Apache::lonnet::usertools_access($username,$domain,$crstype, 'reload','requestcourses', @@ -16551,24 +17702,52 @@ sub needs_coursereinit { $interval = 600; } if (($now-$env{'request.course.timechecked'})>$interval) { - my $lastchange = &Apache::lonnet::get_coursechange($cdom,$cnum); &Apache::lonnet::appenv({'request.course.timechecked'=>$now}); - if ($lastchange > $env{'request.course.tied'}) { - my %curr_reqd_hash = &Apache::lonnet::userenvironment($cdom,$cnum,'internal.releaserequired'); - if ($curr_reqd_hash{'internal.releaserequired'} ne '') { - my $required = $env{'course.'.$cdom.'_'.$cnum.'.internal.releaserequired'}; - if ($curr_reqd_hash{'internal.releaserequired'} ne $required) { - &Apache::lonnet::appenv({'course.'.$cdom.'_'.$cnum.'.internal.releaserequired' => - $curr_reqd_hash{'internal.releaserequired'}}); - my ($switchserver,$switchwarning) = - &check_release_required($loncaparev,$cdom.'_'.$cnum,$env{'request.role'}, - $curr_reqd_hash{'internal.releaserequired'}); - if ($switchwarning ne '' || $switchserver ne '') { - return ('switch',$switchwarning,$switchserver); - } + my $blocked = &blocking_status('reinit',undef,$cnum,$cdom,undef,1); + if ($blocked) { + return (); + } + my $update; + my $lastmainchange = &Apache::lonnet::get_coursechange($cdom,$cnum); + my $lastsuppchange = &Apache::lonnet::get_suppchange($cdom,$cnum); + if ($lastmainchange > $env{'request.course.tied'}) { + my ($needswitch,$switchwarning,$switchserver) = &switch_for_update($loncaparev,$cdom,$cnum); + if ($needswitch) { + return ('switch',$switchwarning,$switchserver); + } + $update = 'main'; + } + if ($lastsuppchange > $env{'request.course.suppupdated'}) { + if ($update) { + $update = 'both'; + } else { + my ($needswitch,$switchwarning,$switchserver) = &switch_for_update($loncaparev,$cdom,$cnum); + if ($needswitch) { + return ('switch',$switchwarning,$switchserver); + } else { + $update = 'supp'; } } - return ('update'); + return ($update); + } + } + return (); +} + +sub switch_for_update { + my ($loncaparev,$cdom,$cnum) = @_; + my %curr_reqd_hash = &Apache::lonnet::userenvironment($cdom,$cnum,'internal.releaserequired'); + if ($curr_reqd_hash{'internal.releaserequired'} ne '') { + my $required = $env{'course.'.$cdom.'_'.$cnum.'.internal.releaserequired'}; + if ($curr_reqd_hash{'internal.releaserequired'} ne $required) { + &Apache::lonnet::appenv({'course.'.$cdom.'_'.$cnum.'.internal.releaserequired' => + $curr_reqd_hash{'internal.releaserequired'}}); + my ($switchserver,$switchwarning) = + &check_release_required($loncaparev,$cdom.'_'.$cnum,$env{'request.role'}, + $curr_reqd_hash{'internal.releaserequired'}); + if ($switchwarning ne '' || $switchserver ne '') { + return ('switch',$switchwarning,$switchserver); + } } } return (); @@ -16651,8 +17830,10 @@ sub parse_supplemental_title { my $name = &plainname($uname,$udom); $name = &HTML::Entities::encode($name,'"<>&\''); $renametitle = &HTML::Entities::encode($renametitle,'"<>&\''); - $title=''.&Apache::lonlocal::locallocaltime($time).' '. - $name.':
'.$foldertitle; + $title=''.&Apache::lonlocal::locallocaltime($time).' '.$name; + if ($foldertitle ne '') { + $title .= ':
'.$foldertitle; + } } if (wantarray) { return ($title,$foldertitle,$renametitle); @@ -16660,28 +17841,147 @@ sub parse_supplemental_title { return $title; } +sub get_supplemental { + my ($cnum,$cdom,$ignorecache,$possdel)=@_; + my $hashid=$cnum.':'.$cdom; + my ($supplemental,$cached,$set_httprefs); + unless ($ignorecache) { + ($supplemental,$cached) = &Apache::lonnet::is_cached_new('supplemental',$hashid); + } + unless (defined($cached)) { + my $chome=&Apache::lonnet::homeserver($cnum,$cdom); + unless ($chome eq 'no_host') { + my @order = @LONCAPA::map::order; + my @resources = @LONCAPA::map::resources; + my @resparms = @LONCAPA::map::resparms; + my @zombies = @LONCAPA::map::zombies; + my ($errors,%ids,%hidden); + $errors = + &recurse_supplemental($cnum,$cdom,'supplemental.sequence', + $errors,$possdel,\%ids,\%hidden); + @LONCAPA::map::order = @order; + @LONCAPA::map::resources = @resources; + @LONCAPA::map::resparms = @resparms; + @LONCAPA::map::zombies = @zombies; + $set_httprefs = 1; + if ($env{'request.course.id'} eq $cdom.'_'.$cnum) { + &Apache::lonnet::appenv({'request.course.suppupdated' => time}); + } + $supplemental = { + ids => \%ids, + hidden => \%hidden, + }; + &Apache::lonnet::do_cache_new('supplemental',$hashid,$supplemental,600); + } + } + return ($supplemental,$set_httprefs); +} + sub recurse_supplemental { - my ($cnum,$cdom,$suppmap,$numfiles,$errors) = @_; - if ($suppmap) { + my ($cnum,$cdom,$suppmap,$errors,$possdel,$suppids,$hiddensupp,$hidden) = @_; + if (($suppmap) && (ref($suppids) eq 'HASH') && (ref($hiddensupp) eq 'HASH')) { + my $mapnum; + if ($suppmap eq 'supplemental.sequence') { + $mapnum = 0; + } else { + ($mapnum) = ($suppmap =~ /^supplemental_(\d+)\.sequence$/); + } my ($errtext,$fatal) = &LONCAPA::map::mapread('/uploaded/'.$cdom.'/'.$cnum.'/'.$suppmap); if ($fatal) { $errors ++; } else { - if ($#LONCAPA::map::resources > 0) { - foreach my $res (@LONCAPA::map::resources) { - my ($title,$src,$ext,$type,$status)=split(/\:/,$res); + my @order = @LONCAPA::map::order; + if (@order > 0) { + my @resources = @LONCAPA::map::resources; + my @resparms = @LONCAPA::map::resparms; + foreach my $idx (@order) { + my ($title,$src,$ext,$type,$status)=split(/\:/,$resources[$idx]); if (($src ne '') && ($status eq 'res')) { + my $id = $mapnum.':'.$idx; + push(@{$suppids->{$src}},$id); + if (($hidden) || (&get_supp_parameter($resparms[$idx],'parameter_hiddenresource') =~ /^yes/i)) { + $hiddensupp->{$id} = 1; + } if ($src =~ m{^\Q/uploaded/$cdom/$cnum/\E(supplemental_\d+\.sequence)$}) { - ($numfiles,$errors) = &recurse_supplemental($cnum,$cdom,$1,$numfiles,$errors); + $errors = &recurse_supplemental($cnum,$cdom,$1,$errors,$possdel,$suppids, + $hiddensupp,$hiddensupp->{$id}); } else { - $numfiles ++; + my $allowed; + if (($env{'request.role.adv'}) || (!$hiddensupp->{$id})) { + $allowed = 1; + } elsif ($possdel) { + foreach my $item (@{$suppids->{$src}}) { + next if ($item eq $id); + unless ($hiddensupp->{$item}) { + $allowed = 1; + last; + } + } + if ((!$allowed) && (exists($env{'httpref.'.$src}))) { + &Apache::lonnet::delenv('httpref.'.$src); + } + } + if ($allowed && (!exists($env{'httpref.'.$src}))) { + &Apache::lonnet::allowuploaded('/adm/coursedoc',$src); + } + } + } + } + } + } + } + return $errors; +} + +sub set_supp_httprefs { + my ($cnum,$cdom,$supplemental,$possdel) = @_; + if (ref($supplemental) eq 'HASH') { + if ((ref($supplemental->{'ids'}) eq 'HASH') && (ref($supplemental->{'hidden'}) eq 'HASH')) { + foreach my $src (keys(%{$supplemental->{'ids'}})) { + next if ($src =~ /\.sequence$/); + if (ref($supplemental->{'ids'}->{$src}) eq 'ARRAY') { + my $allowed; + if ($env{'request.role.adv'}) { + $allowed = 1; + } else { + foreach my $id (@{$supplemental->{'ids'}->{$src}}) { + unless ($supplemental->{'hidden'}->{$id}) { + $allowed = 1; + last; + } } } + if (exists($env{'httpref.'.$src})) { + if ($possdel) { + unless ($allowed) { + &Apache::lonnet::delenv('httpref.'.$src); + } + } + } elsif ($allowed) { + &Apache::lonnet::allowuploaded('/adm/coursedoc',$src); + } } } + if ($env{'request.course.id'} eq $cdom.'_'.$cnum) { + &Apache::lonnet::appenv({'request.course.suppupdated' => time}); + } } } - return ($numfiles,$errors); +} + +sub get_supp_parameter { + my ($resparm,$name)=@_; + return if ($resparm eq ''); + my $value=undef; + my $ptype=undef; + foreach (split('&&&',$resparm)) { + my ($thistype,$thisname,$thisvalue)=split('___',$_); + if ($thisname eq $name) { + $value=$thisvalue; + $ptype=$thistype; + } + } + return $value; } sub symb_to_docspath { @@ -16754,11 +18054,72 @@ sub symb_to_docspath { return $path; } +sub validate_folderpath { + my ($supplementalflag,$allowed,$coursenum,$coursedom) = @_; + if ($env{'form.folderpath'} ne '') { + my @items = split(/\&/,$env{'form.folderpath'}); + my ($badpath,$changed,$got_supp,$supppath,%supphidden,%suppids); + for (my $i=0; $i<@items; $i++) { + my $odd = $i%2; + if (($odd) && (!$supplementalflag) && ($items[$i] !~ /^[^:]*:(|\d+):(|1):(|1):(|1):(|1)$/)) { + $badpath = 1; + } elsif ($odd && $supplementalflag) { + my $idx = $i-1; + if ($items[$i] =~ /^([^:]*)::(|1):::$/) { + my $esc_name = $1; + if ((!$allowed) || ($items[$idx] eq 'supplemental')) { + $supppath .= '&'.$esc_name; + $changed = 1; + } else { + $supppath .= '&'.$items[$i]; + } + } elsif (($allowed) && ($items[$idx] ne 'supplemental')) { + $changed = 1; + my $is_hidden; + unless ($got_supp) { + my ($supplemental) = &get_supplemental($coursenum,$coursedom); + if (ref($supplemental) eq 'HASH') { + if (ref($supplemental->{'hidden'}) eq 'HASH') { + %supphidden = %{$supplemental->{'hidden'}}; + } + if (ref($supplemental->{'ids'}) eq 'HASH') { + %suppids = %{$supplemental->{'ids'}}; + } + } + $got_supp = 1; + } + if (ref($suppids{"/uploaded/$coursedom/$coursenum/$items[$idx].sequence"}) eq 'ARRAY') { + my $mapid = $suppids{"/uploaded/$coursedom/$coursenum/$items[$idx].sequence"}->[0]; + if ($supphidden{$mapid}) { + $is_hidden = 1; + } + } + $supppath .= '&'.$items[$i].'::'.$is_hidden.':::'; + } else { + $supppath .= '&'.$items[$i]; + } + } elsif ((!$odd) && ($items[$i] !~ /^(default|supplemental)(|_\d+)$/)) { + $badpath = 1; + } elsif ($supplementalflag) { + $supppath .= '&'.$items[$i]; + } + last if ($badpath); + } + if ($badpath) { + delete($env{'form.folderpath'}); + } elsif ($changed && $supplementalflag) { + $supppath =~ s/^\&//; + $env{'form.folderpath'} = $supppath; + } + } + return; +} + sub captcha_display { - my ($context,$lonhost) = @_; + my ($context,$lonhost,$defdom) = @_; my ($output,$error); my ($captcha,$pubkey,$privkey,$version) = - &get_captcha_config($context,$lonhost); + &get_captcha_config($context,$lonhost,$defdom); if ($captcha eq 'original') { $output = &create_captcha(); unless ($output) { @@ -16774,9 +18135,9 @@ sub captcha_display { } sub captcha_response { - my ($context,$lonhost) = @_; + my ($context,$lonhost,$defdom) = @_; my ($captcha_chk,$captcha_error); - my ($captcha,$pubkey,$privkey,$version) = &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') { @@ -16788,7 +18149,7 @@ sub captcha_response { } sub get_captcha_config { - my ($context,$lonhost) = @_; + 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); @@ -16836,6 +18197,27 @@ 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); } @@ -16853,13 +18235,17 @@ sub create_captcha { if (-e $Apache::lonnet::perlvar{'lonCaptchaDir'}.'/'.$md5sum.'.png') { $output = ''."\n". + ''. &mt('Type in the letters/numbers shown below').' '. - ''. - '
'. + ''. + '
'. '
';
last;
}
}
+ if ($output eq '') {
+ &Apache::lonnet::logthis("Failed to create Captcha code after $tries attempts.");
+ }
return $output;
}
@@ -16898,7 +18284,8 @@ sub check_captcha {
sub create_recaptcha {
my ($pubkey,$version) = @_;
if ($version >= 2) {
- return '';
+ return ''.
+ '';
} else {
my $use_ssl;
if ($ENV{'SERVER_PORT'} == 443) {
@@ -16916,13 +18303,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) {
@@ -16938,7 +18326,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'},
);
@@ -16987,15 +18375,34 @@ sub cleanup_html {
# Checks for critical messages and returns a redirect url if one exists.
# $interval indicates how often to check for messages.
+# $context is the calling context -- roles, grades, contents, menu or flip.
sub critical_redirect {
- my ($interval) = @_;
+ my ($interval,$context) = @_;
+ unless (($env{'user.domain'} ne '') && ($env{'user.name'} ne '')) {
+ return ();
+ }
if ((time-$env{'user.criticalcheck.time'})>$interval) {
+ if (($env{'request.course.id'}) && (($context eq 'flip') || ($context eq 'contents'))) {
+ my $cdom = $env{'course.'.$env{'request.course.id'}.'.domain'};
+ my $cnum = $env{'course.'.$env{'request.course.id'}.'.num'};
+ my $blocked = &blocking_status('alert',undef,$cnum,$cdom,undef,1);
+ if ($blocked) {
+ my $checkrole = "cm./$cdom/$cnum";
+ if ($env{'request.course.sec'} ne '') {
+ $checkrole .= "/$env{'request.course.sec'}";
+ }
+ unless ((&Apache::lonnet::allowed('evb',undef,undef,$checkrole)) &&
+ ($env{'request.role'} !~ m{^st\./$cdom/$cnum})) {
+ return;
+ }
+ }
+ }
my @what=&Apache::lonnet::dump('critical', $env{'user.domain'},
$env{'user.name'});
&Apache::lonnet::appenv({'user.criticalcheck.time'=>time});
my $redirecturl;
if ($what[0]) {
- if (($what[0] ne 'con_lost') && ($what[0]!~/^error\:/)) {
+ if (($what[0] ne 'con_lost') && ($what[0] ne 'no_such_host') && ($what[0]!~/^error\:/)) {
$redirecturl='/adm/email?critical=display';
my $url=&Apache::lonnet::absolute_url().$redirecturl;
return (1, $url);
@@ -17055,6 +18462,342 @@ 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'));
+ }
+ }
+ 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;
+ $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 $ua = LWP::UserAgent->new;
+ $ua->timeout(5);
+ my $response=$ua->request($request);
+ if ($response->is_success()) {
+ my $secpolicy = lc($response->header('content-security-policy'));
+ my $xframeop = lc($response->header('x-frame-options'));
+ $secpolicy =~ s/^\s+|\s+$//g;
+ $xframeop =~ s/^\s+|\s+$//g;
+ if (($secpolicy ne '') || ($xframeop ne '')) {
+ my $remotehost = $remprotocol.'://'.$remhost;
+ my ($origin,$protocol,$port);
+ if ($ENV{'SERVER_PORT'} =~/^\d+$/) {
+ $port = $ENV{'SERVER_PORT'};
+ } else {
+ $port = 80;
+ }
+ if ($absolute eq '') {
+ $protocol = 'http:';
+ if ($port == 443) {
+ $protocol = 'https:';
+ }
+ $origin = $protocol.'//'.lc($hostname);
+ } else {
+ $origin = lc($absolute);
+ ($protocol,$hostname) = ($absolute =~ m{^(https?:)//([^/]+)$});
+ }
+ if (($secpolicy) && ($secpolicy =~ /\Qframe-ancestors\E([^;]*)(;|$)/)) {
+ my $framepolicy = $1;
+ $framepolicy =~ s/^\s+|\s+$//g;
+ my @policies = split(/\s+/,$framepolicy);
+ if (@policies) {
+ if (grep(/^\Q'none'\E$/,@policies)) {
+ $uselink = 1;
+ } else {
+ $uselink = 1;
+ if ((grep(/^\Q*\E$/,@policies)) || (grep(/^\Q$protocol\E$/,@policies)) ||
+ (($origin ne '') && (grep(/^\Q$origin\E$/,@policies))) ||
+ (($ip ne '') && (grep(/^\Q$ip\E$/,@policies)))) {
+ undef($uselink);
+ }
+ if ($uselink) {
+ if (grep(/^\Q'self'\E$/,@policies)) {
+ if (($origin ne '') && ($remotehost eq $origin)) {
+ undef($uselink);
+ }
+ }
+ }
+ if ($uselink) {
+ my @possok;
+ if ($ip ne '') {
+ push(@possok,$ip);
+ }
+ my $hoststr = '';
+ foreach my $part (reverse(split(/\./,$hostname))) {
+ if ($hoststr eq '') {
+ $hoststr = $part;
+ } else {
+ $hoststr = "$part.$hoststr";
+ }
+ if ($hoststr eq $hostname) {
+ push(@possok,$hostname);
+ } else {
+ push(@possok,"*.$hoststr");
+ }
+ }
+ if (@possok) {
+ foreach my $poss (@possok) {
+ last if (!$uselink);
+ foreach my $policy (@policies) {
+ if ($policy =~ m{^(\Q$protocol\E//|)\Q$poss\E(\Q:$port\E|)$}) {
+ undef($uselink);
+ last;
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ } elsif ($xframeop ne '') {
+ $uselink = 1;
+ my @policies = split(/\s*,\s*/,$xframeop);
+ if (@policies) {
+ unless (grep(/^deny$/,@policies)) {
+ if ($origin ne '') {
+ if (grep(/^sameorigin$/,@policies)) {
+ if ($remotehost eq $origin) {
+ undef($uselink);
+ }
+ }
+ if ($uselink) {
+ foreach my $policy (@policies) {
+ if ($policy =~ /^allow-from\s*(.+)$/) {
+ my $allowfrom = $1;
+ if (($allowfrom ne '') && ($allowfrom eq $origin)) {
+ undef($uselink);
+ last;
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ if ($nocache) {
+ if ($cached) {
+ my $devalidate;
+ if ($uselink && !$result) {
+ $devalidate = 1;
+ } elsif (!$uselink && $result) {
+ $devalidate = 1;
+ }
+ if ($devalidate) {
+ &Apache::lonnet::devalidate_cache_new('noiframe',$remhost.':'.$remport);
+ }
+ }
+ } else {
+ if ($uselink) {
+ $result = 1;
+ } else {
+ $result = 0;
+ }
+ &Apache::lonnet::do_cache_new('noiframe',$remhost.':'.$remport,$result,3600);
+ }
+ return $uselink;
+}
+
+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__;