//
ENDUPDATE
@@ -11426,7 +11580,7 @@ sub modify_html_refs {
return;
}
}
- if (open(my $fh,"<$container")) {
+ if (open(my $fh,'<',$container)) {
$content = join('', <$fh>);
close($fh);
} else {
@@ -11491,7 +11645,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].',
@@ -12008,6 +12162,18 @@ sub decompress_uploaded_file {
sub process_decompression {
my ($docudom,$docuname,$file,$destination,$dir_root,$hiddenelem) = @_;
+ unless (($dir_root eq '/userfiles') && ($destination =~ m{^(docs|supplemental)/(default|\d+)/\d+$})) {
+ return '
'.&mt('Not extracted.').'
'.
+ &mt('Unexpected file path.').'
'."\n";
+ }
+ unless (($docudom =~ /^$match_domain$/) && ($docuname =~ /^$match_courseid$/)) {
+ return ''.&mt('Not extracted.').'
'.
+ &mt('Unexpected course context.').'
'."\n";
+ }
+ unless ($file eq &Apache::lonnet::clean_filename($file)) {
+ return ''.&mt('Not extracted.').'
'.
+ &mt('Filename contained unexpected characters.').'
'."\n";
+ }
my ($dir,$error,$warning,$output);
if ($file !~ /\.(zip|tar|bz2|gz|tar.gz|tar.bz2|tgz)$/i) {
$error = &mt('Filename not a supported archive file type.').
@@ -12042,30 +12208,44 @@ sub process_decompression {
}
}
my $numskip = scalar(@to_skip);
- if (($numskip > 0) &&
- ($numskip == $env{'form.archive_itemcount'})) {
+ my $numoverwrite = scalar(@to_overwrite);
+ if (($numskip) && (!$numoverwrite)) {
$warning = &mt('All items in the archive file already exist, and no overwriting of existing files has been requested.');
} elsif ($dir eq '') {
$error = &mt('Directory containing archive file unavailable.');
} elsif (!$error) {
my ($decompressed,$display);
- if ($numskip > 0) {
+ if (($numskip) || ($numoverwrite)) {
my $tempdir = time.'_'.$$.int(rand(10000));
mkdir("$dir/$tempdir",0755);
- system("mv $dir/$file $dir/$tempdir/$file");
- ($decompressed,$display) =
- &decompress_uploaded_file($file,"$dir/$tempdir");
- foreach my $item (@to_skip) {
- if (($item ne '') && ($item !~ /\.\./)) {
- if (-f "$dir/$tempdir/$item") {
- unlink("$dir/$tempdir/$item");
- } elsif (-d "$dir/$tempdir/$item") {
- system("rm -rf $dir/$tempdir/$item");
+ if (&File::Copy::move("$dir/$file","$dir/$tempdir/$file")) {
+ ($decompressed,$display) =
+ &decompress_uploaded_file($file,"$dir/$tempdir");
+ foreach my $item (@to_skip) {
+ if (($item ne '') && ($item !~ /\.\./)) {
+ if (-f "$dir/$tempdir/$item") {
+ unlink("$dir/$tempdir/$item");
+ } elsif (-d "$dir/$tempdir/$item") {
+ &File::Path::remove_tree("$dir/$tempdir/$item",{ safe => 1 });
+ }
+ }
+ }
+ foreach my $item (@to_overwrite) {
+ if ((-e "$dir/$tempdir/$item") && (-e "$dir/$item")) {
+ if (($item ne '') && ($item !~ /\.\./)) {
+ if (-f "$dir/$item") {
+ unlink("$dir/$item");
+ } elsif (-d "$dir/$item") {
+ &File::Path::remove_tree("$dir/$item",{ safe => 1 });
+ }
+ &File::Copy::move("$dir/$tempdir/$item","$dir/$item");
+ }
}
}
+ if (&File::Copy::move("$dir/$tempdir/$file","$dir/$file")) {
+ &File::Path::remove_tree("$dir/$tempdir",{ safe => 1 });
+ }
}
- system("mv $dir/$tempdir/* $dir");
- rmdir("$dir/$tempdir");
} else {
($decompressed,$display) =
&decompress_uploaded_file($file,$dir);
@@ -12083,8 +12263,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;
@@ -12569,7 +12748,7 @@ END
sub process_extracted_files {
my ($context,$docudom,$docuname,$destination,$dir_root,$hiddenelem) = @_;
my $numitems = $env{'form.archive_count'};
- return unless ($numitems);
+ return if ((!$numitems) || ($numitems =~ /\D/));
my @ids=&Apache::lonnet::current_machine_ids();
my ($prefix,$pathtocheck,$dir,$ishome,$error,$warning,%toplevelitems,%is_dir,
%folders,%containers,%mapinner,%prompttofetch);
@@ -12582,7 +12761,7 @@ sub process_extracted_files {
} else {
$prefix = $Apache::lonnet::perlvar{'lonDocRoot'};
$pathtocheck = "$dir_root/$docudom/$docuname/$destination";
- $dir = "$dir_root/$docudom/$docuname";
+ $dir = "$dir_root/$docudom/$docuname";
}
my $currdir = "$dir_root/$destination";
(my $docstype,$mapinner{'0'}) = ($destination =~ m{^(docs|supplemental)/(\w+)/});
@@ -12671,7 +12850,9 @@ sub process_extracted_files {
'.'.$containers{$outer},1,1);
$newseqid{$i} = $newidx;
unless ($errtext) {
- $result .= ''.&mt('Folder: [_1] added to course',$docstitle).''."\n";
+ $result .= ''.&mt('Folder: [_1] added to course',
+ &HTML::Entities::encode($docstitle,'<>&"'))..
+ ''."\n";
}
}
} else {
@@ -12680,38 +12861,47 @@ sub process_extracted_files {
my $url = '/uploaded/'.$docudom.'/'.$docuname.'/'.
$docstype.'/'.$mapinner{$outer}.'/'.$newidx.'/'.
$title;
- if (!-e "$prefix$dir/$docstype/$mapinner{$outer}") {
- mkdir("$prefix$dir/$docstype/$mapinner{$outer}",0755);
- }
- if (!-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx") {
- mkdir("$prefix$dir/$docstype/$mapinner{$outer}/$newidx");
- }
- if (-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx") {
- system("mv $prefix$path $prefix$dir/$docstype/$mapinner{$outer}/$newidx/$title");
- $newdest{$i} = "$prefix$dir/$docstype/$mapinner{$outer}/$newidx";
- unless ($ishome) {
- my $fetch = "$newdest{$i}/$title";
- $fetch =~ s/^\Q$prefix$dir\E//;
- $prompttofetch{$fetch} = 1;
+ if (($outer !~ /\D/) && ($mapinner{$outer} !~ /\D/) && ($newidx !~ /\D/)) {
+ if (!-e "$prefix$dir/$docstype/$mapinner{$outer}") {
+ mkdir("$prefix$dir/$docstype/$mapinner{$outer}",0755);
}
- }
- $LONCAPA::map::resources[$newidx]=
- $docstitle.':'.$url.':false:normal:res';
- push(@LONCAPA::map::order, $newidx);
- my ($outtext,$errtext)=
- &LONCAPA::map::storemap('/uploaded/'.$docudom.'/'.
- $docuname.'/'.$folders{$outer}.
- '.'.$containers{$outer},1,1);
- unless ($errtext) {
- if (-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx/$title") {
- $result .= ''.&mt('File: [_1] added to course',$docstitle).''."\n";
+ if (!-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx") {
+ mkdir("$prefix$dir/$docstype/$mapinner{$outer}/$newidx");
+ }
+ if (-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx") {
+ if (rename("$prefix$path","$prefix$dir/$docstype/$mapinner{$outer}/$newidx/$title")) {
+ $newdest{$i} = "$prefix$dir/$docstype/$mapinner{$outer}/$newidx";
+ unless ($ishome) {
+ my $fetch = "$newdest{$i}/$title";
+ $fetch =~ s/^\Q$prefix$dir\E//;
+ $prompttofetch{$fetch} = 1;
+ }
+ }
+ }
+ $LONCAPA::map::resources[$newidx]=
+ $docstitle.':'.$url.':false:normal:res';
+ push(@LONCAPA::map::order, $newidx);
+ my ($outtext,$errtext)=
+ &LONCAPA::map::storemap('/uploaded/'.$docudom.'/'.
+ $docuname.'/'.$folders{$outer}.
+ '.'.$containers{$outer},1,1);
+ unless ($errtext) {
+ if (-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx/$title") {
+ $result .= ''.&mt('File: [_1] added to course',
+ &HTML::Entities::encode($docstitle,'<>&"')).
+ ''."\n";
+ }
}
+ } else {
+ $warning .= &mt('Item extracted from archive: [_1] has unexpected path.',
+ &HTML::Entities::encode($path,'<>&"')).'
';
}
}
}
}
} else {
- $warning .= &mt('Item extracted from archive: [_1] has unexpected path.',$path).'
';
+ $warning .= &mt('Item extracted from archive: [_1] has unexpected path.',
+ &HTML::Entities::encode($path,'<>&"')).'
';
}
}
for (my $i=1; $i<=$numitems; $i++) {
@@ -12772,7 +12962,9 @@ sub process_extracted_files {
}
if ($fullpath ne '') {
if (-e "$prefix$path") {
- system("mv $prefix$path $fullpath/$title");
+ unless (rename("$prefix$path","$fullpath/$title")) {
+ $warning .= &mt('Failed to rename dependency').'
';
+ }
}
if (-e "$fullpath/$title") {
my $showpath;
@@ -12781,21 +12973,26 @@ sub process_extracted_files {
} else {
$showpath = "/$title";
}
- $result .= ''.&mt('[_1] included as a dependency',$showpath).''."\n";
- }
- unless ($ishome) {
- my $fetch = "$fullpath/$title";
- $fetch =~ s/^\Q$prefix$dir\E//;
- $prompttofetch{$fetch} = 1;
+ $result .= ''.&mt('[_1] included as a dependency',
+ &HTML::Entities::encode($showpath,'<>&"')).
+ ''."\n";
+ unless ($ishome) {
+ my $fetch = "$fullpath/$title";
+ $fetch =~ s/^\Q$prefix$dir\E//;
+ $prompttofetch{$fetch} = 1;
+ }
}
}
}
} elsif ($env{'form.archive_'.$referrer{$i}} eq 'discard') {
$warning .= &mt('[_1] is a dependency of [_2], which was discarded.',
- $path,$env{'form.archive_content_'.$referrer{$i}}).'
';
+ &HTML::Entities::encode($path,'<>&"'),
+ &HTML::Entities::encode($env{'form.archive_content_'.$referrer{$i}},'<>&"')).
+ '
';
}
} else {
- $warning .= &mt('Item extracted from archive: [_1] has unexpected path.',$path).'
';
+ $warning .= &mt('Item extracted from archive: [_1] has unexpected path.',
+ &HTML::Entities::encode($path)).'
';
}
}
if (keys(%todelete)) {
@@ -13069,12 +13266,15 @@ sub upfile_store {
$env{'form.upfile'}=~s/\n+/\n/gs;
$env{'form.upfile'}=~s/\n+$//gs;
- my $datatoken=$env{'user.name'}.'_'.$env{'user.domain'}.
- '_enroll_'.$env{'request.course.id'}.'_'.time.'_'.$$;
+ my $datatoken = &valid_datatoken($env{'user.name'}.'_'.$env{'user.domain'}.
+ '_enroll_'.$env{'request.course.id'}.'_'.
+ time.'_'.$$);
+ return if ($datatoken eq '');
+
{
my $datafile = $r->dir_config('lonDaemons').
'/tmp/'.$datatoken.'.tmp';
- if ( open(my $fh,">$datafile") ) {
+ if ( open(my $fh,'>',$datafile) ) {
print $fh $env{'form.upfile'};
close($fh);
}
@@ -13084,21 +13284,22 @@ sub upfile_store {
=pod
-=item * &load_tmp_file($r)
+=item * &load_tmp_file($r,$datatoken)
Load uploaded file from tmp, $r should be the HTTP Request object,
-needs $env{'form.datatoken'},
+$datatoken is the name to assign to the temporary file.
sets $env{'form.upfile'} to the contents of the file
=cut
sub load_tmp_file {
- my $r=shift;
+ my ($r,$datatoken) = @_;
+ return if ($datatoken eq '');
my @studentdata=();
{
my $studentfile = $r->dir_config('lonDaemons').
- '/tmp/'.$env{'form.datatoken'}.'.tmp';
- if ( open(my $fh,"<$studentfile") ) {
+ '/tmp/'.$datatoken.'.tmp';
+ if ( open(my $fh,'<',$studentfile) ) {
@studentdata=<$fh>;
close($fh);
}
@@ -13106,6 +13307,14 @@ sub load_tmp_file {
$env{'form.upfile'}=join('',@studentdata);
}
+sub valid_datatoken {
+ my ($datatoken) = @_;
+ if ($datatoken =~ /^$match_username\_$match_domain\_enroll_(|$match_domain\_$match_courseid)\_\d+_\d+$/) {
+ return $datatoken;
+ }
+ return;
+}
+
=pod
=item * &upfile_record_sep()
@@ -13994,6 +14203,12 @@ defdom (domain for which to retrieve con
origmail (scalar - email address of recipient from loncapa.conf,
i.e., predates configuration by DC via domainprefs.pm
+$requname username of requester (if mailing type is helpdeskmail)
+
+$requdom domain of requester (if mailing type is helpdeskmail)
+
+$reqemail e-mail address of requester (if mailing type is helpdeskmail)
+
Returns: comma separated list of addresses to which to send e-mail.
=back
@@ -14003,7 +14218,7 @@ Returns: comma separated list of address
############################################################
############################################################
sub build_recipient_list {
- my ($defmail,$mailing,$defdom,$origmail) = @_;
+ my ($defmail,$mailing,$defdom,$origmail,$requname,$requdom,$reqemail) = @_;
my @recipients;
my ($otheremails,$lastresort,$allbcc,$addtext);
my %domconfig =
@@ -14044,11 +14259,98 @@ sub build_recipient_list {
} elsif ($origmail ne '') {
$lastresort = $origmail;
}
+ if ($mailing eq 'helpdeskmail') {
+ if ((ref($domconfig{'contacts'}{'overrides'}) eq 'HASH') &&
+ (keys(%{$domconfig{'contacts'}{'overrides'}}))) {
+ my ($inststatus,$inststatus_checked);
+ if (($env{'user.name'} ne '') && ($env{'user.domain'} ne '') &&
+ ($env{'user.domain'} ne 'public')) {
+ $inststatus_checked = 1;
+ $inststatus = $env{'environment.inststatus'};
+ }
+ unless ($inststatus_checked) {
+ if (($requname ne '') && ($requdom ne '')) {
+ if (($requname =~ /^$match_username$/) &&
+ ($requdom =~ /^$match_domain$/) &&
+ (&Apache::lonnet::domain($requdom))) {
+ my $requhome = &Apache::lonnet::homeserver($requname,
+ $requdom);
+ unless ($requhome eq 'no_host') {
+ my %userenv = &Apache::lonnet::userenvironment($requdom,$requname,'inststatus');
+ $inststatus = $userenv{'inststatus'};
+ $inststatus_checked = 1;
+ }
+ }
+ }
+ }
+ unless ($inststatus_checked) {
+ if ($reqemail =~ /^[^\@]+\@[^\@]+$/) {
+ my %srch = (srchby => 'email',
+ srchdomain => $defdom,
+ srchterm => $reqemail,
+ srchtype => 'exact');
+ my %srch_results = &Apache::lonnet::usersearch(\%srch);
+ foreach my $uname (keys(%srch_results)) {
+ if (ref($srch_results{$uname}{'inststatus'}) eq 'ARRAY') {
+ $inststatus = join(',',@{$srch_results{$uname}{'inststatus'}});
+ $inststatus_checked = 1;
+ last;
+ }
+ }
+ unless ($inststatus_checked) {
+ my ($dirsrchres,%srch_results) = &Apache::lonnet::inst_directory_query(\%srch);
+ if ($dirsrchres eq 'ok') {
+ foreach my $uname (keys(%srch_results)) {
+ if (ref($srch_results{$uname}{'inststatus'}) eq 'ARRAY') {
+ $inststatus = join(',',@{$srch_results{$uname}{'inststatus'}});
+ $inststatus_checked = 1;
+ last;
+ }
+ }
+ }
+ }
+ }
+ }
+ if ($inststatus ne '') {
+ foreach my $status (split(/\:/,$inststatus)) {
+ if (ref($domconfig{'contacts'}{'overrides'}{$status}) eq 'HASH') {
+ my @contacts = ('adminemail','supportemail');
+ foreach my $item (@contacts) {
+ if ($domconfig{'contacts'}{'overrides'}{$status}{$item}) {
+ my $addr = $domconfig{'contacts'}{'overrides'}{$status};
+ if (!grep(/^\Q$addr\E$/,@recipients)) {
+ push(@recipients,$addr);
+ }
+ }
+ }
+ $otheremails = $domconfig{'contacts'}{'overrides'}{$status}{'others'};
+ if ($domconfig{'contacts'}{'overrides'}{$status}{'bcc'}) {
+ my @bccs = split(/,/,$domconfig{'contacts'}{'overrides'}{$status}{'bcc'});
+ my @ok_bccs;
+ foreach my $bcc (@bccs) {
+ $bcc =~ s/^\s+//g;
+ $bcc =~ s/\s+$//g;
+ if ($bcc =~ m/^[^\@]+\@[^\@]+$/) {
+ if (!(grep(/^\Q$bcc\E$/,@ok_bccs))) {
+ push(@ok_bccs,$bcc);
+ }
+ }
+ }
+ if (@ok_bccs > 0) {
+ $allbcc = join(', ',@ok_bccs);
+ }
+ }
+ $addtext = $domconfig{'contacts'}{'overrides'}{$status}{'include'};
+ last;
+ }
+ }
+ }
+ }
+ }
} elsif ($origmail ne '') {
$lastresort = $origmail;
}
-
- if (($mailing eq 'helpdesk') && ($lastresort ne '')) {
+ if (($mailing eq 'helpdeskmail') && ($lastresort ne '')) {
unless (grep(/^\Q$defdom\E$/,&Apache::lonnet::current_machine_domains())) {
my $lonhost = $Apache::lonnet::perlvar{'lonHostID'};
my $machinedom = $Apache::lonnet::perlvar{'lonDefDomain'};
@@ -14128,7 +14430,7 @@ sub build_recipient_list {
}
}
}
- if ($mailing eq 'helpdesk') {
+ if ($mailing eq 'helpdeskmail') {
if ((!@recipients) && ($lastresort ne '')) {
push(@recipients,$lastresort);
}
@@ -14233,6 +14535,8 @@ jsarray (reference to array of categorie
subcats (reference to hash of arrays containing all subcategories within each
category, -recursive)
+maxd (reference to hash used to hold max depth for all top-level categories).
+
Returns: nothing
Side effects: populates trails and allitems hash references.
@@ -14240,7 +14544,7 @@ Side effects: populates trails and allit
=cut
sub extract_categories {
- my ($categories,$cats,$trails,$allitems,$idx,$jsarray,$subcats) = @_;
+ my ($categories,$cats,$trails,$allitems,$idx,$jsarray,$subcats,$maxd) = @_;
if (ref($categories) eq 'HASH') {
&gather_categories($categories,$cats,$idx,$jsarray);
if (ref($cats->[0]) eq 'ARRAY') {
@@ -14266,12 +14570,15 @@ sub extract_categories {
if (ref($subcats) eq 'HASH') {
push(@{$subcats->{$item}},&escape($category).':'.&escape($name).':1');
}
- &recurse_categories($cats,2,$category,$trails,$allitems,\@parents,$subcats);
+ &recurse_categories($cats,2,$category,$trails,$allitems,\@parents,$subcats,$maxd);
}
} else {
if (ref($subcats) eq 'HASH') {
$subcats->{$item} = [];
}
+ if (ref($maxd) eq 'HASH') {
+ $maxd->{$name} = 1;
+ }
}
}
}
@@ -14309,7 +14616,7 @@ Side effects: populates trails and allit
=cut
sub recurse_categories {
- my ($cats,$depth,$category,$trails,$allitems,$parents,$subcats) = @_;
+ my ($cats,$depth,$category,$trails,$allitems,$parents,$subcats,$maxd) = @_;
my $shallower = $depth - 1;
if (ref($cats->[$depth]{$category}) eq 'ARRAY') {
for (my $k=0; $k<@{$cats->[$depth]{$category}}; $k++) {
@@ -14336,16 +14643,21 @@ sub recurse_categories {
}
}
&recurse_categories($cats,$deeper,$name,$trails,$allitems,$parents,
- $subcats);
+ $subcats,$maxd);
pop(@{$parents});
}
} else {
my $item = &escape($category).':'.&escape($parents->[-1]).':'.$shallower;
- my $trailstr = join(' -> ',(@{$parents},$category));
+ my $trailstr = join(' » ',(@{$parents},$category));
if ($allitems->{$item} eq '') {
push(@{$trails},$trailstr);
$allitems->{$item} = scalar(@{$trails})-1;
}
+ if (ref($maxd) eq 'HASH') {
+ if ($depth > $maxd->{$parents->[0]}) {
+ $maxd->{$parents->[0]} = $depth;
+ }
+ }
}
return;
}
@@ -14377,8 +14689,8 @@ sub assign_categories_table {
my ($cathash,$currcat,$type,$disabled) = @_;
my $output;
if (ref($cathash) eq 'HASH') {
- my (@cats,@trails,%allitems,%idx,@jsarray,@path,$maxdepth);
- &extract_categories($cathash,\@cats,\@trails,\%allitems,\%idx,\@jsarray);
+ my (@cats,@trails,%allitems,%idx,@jsarray,%maxd,@path,$maxdepth);
+ &extract_categories($cathash,\@cats,\@trails,\%allitems,\%idx,\@jsarray,\%maxd);
$maxdepth = scalar(@cats);
if (@cats > 0) {
my $itemcount = 0;
@@ -15396,7 +15708,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);
@@ -16529,10 +16857,10 @@ sub symb_to_docspath {
}
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) {
@@ -16548,9 +16876,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') {
@@ -16562,7 +16890,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);
@@ -16610,6 +16938,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);
}
@@ -16829,6 +17178,159 @@ 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 $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;
+}
+
1;
__END__;