version 1.1075.2.127.2.7, 2019/02/06 16:10:34
|
version 1.1075.2.129, 2018/09/03 20:43:15
|
Line 82 use Crypt::DES;
|
Line 82 use Crypt::DES;
|
use DynaLoader; # for Crypt::DES version |
use DynaLoader; # for Crypt::DES version |
use File::Copy(); |
use File::Copy(); |
use File::Path(); |
use File::Path(); |
use String::CRC32(); |
|
use Short::URL(); |
|
|
|
# ---------------------------------------------- Designs |
# ---------------------------------------------- Designs |
use vars qw(%defaultdesign); |
use vars qw(%defaultdesign); |
Line 2264 sub select_form {
|
Line 2262 sub select_form {
|
if ($onchange) { |
if ($onchange) { |
$onchange = ' onchange="'.$onchange.'"'; |
$onchange = ' onchange="'.$onchange.'"'; |
} |
} |
my $selectform = "<select name=\"$name\" size=\"1\"$onchange>\n"; |
my $disabled; |
|
if ($readonly) { |
|
$disabled = ' disabled="disabled"'; |
|
} |
|
my $selectform = "<select name=\"$name\" size=\"1\"$onchange$disabled>\n"; |
my @keys; |
my @keys; |
if (exists($hashref->{'select_form_order'})) { |
if (exists($hashref->{'select_form_order'})) { |
@keys=@{$hashref->{'select_form_order'}}; |
@keys=@{$hashref->{'select_form_order'}}; |
Line 4722 sub blockcheck {
|
Line 4724 sub blockcheck {
|
($env{'request.role'} !~ m{^st\./\Q$cdom\E/\Q$cnum\E})); |
($env{'request.role'} !~ m{^st\./\Q$cdom\E/\Q$cnum\E})); |
next if ($no_userblock); |
next if ($no_userblock); |
|
|
# Retrieve blocking times and identity of locker for course |
# Retrieve blocking times and identity of blocker for course |
# of specified user, unless user has 'evb' privilege. |
# of specified user, unless user has 'evb' privilege. |
|
|
my ($start,$end,$trigger) = |
my ($start,$end,$trigger) = |
Line 4996 sub check_ip_acc {
|
Line 4998 sub check_ip_acc {
|
return $allowed; |
return $allowed; |
} |
} |
|
|
sub check_slotip_acc { |
|
my ($acc,$clientip)=@_; |
|
&Apache::lonxml::debug("acc is $acc"); |
|
if (!defined($acc) || $acc =~ /^\s*$/ || $acc =~/^\s*no\s*$/i) { |
|
return 1; |
|
} |
|
my $allowed; |
|
my $ip=$ENV{'REMOTE_ADDR'} || $clientip || $env{'request.host'}; |
|
|
|
my $name; |
|
my %access = ( |
|
allowfrom => 1, |
|
denyfrom => 0, |
|
); |
|
my @allows; |
|
my @denies; |
|
foreach my $item (split(',',$acc)) { |
|
$item =~ s/^\s*//; |
|
$item =~ s/\s*$//; |
|
my $pattern; |
|
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'; |
|
} |
|
if ($pattern =~ /\*$/) { |
|
#35.8.* |
|
$pattern=~s/\*//; |
|
if ($ip =~ /^\Q$pattern\E/) { $allowed=$access{$acctype}; } |
|
} elsif ($pattern =~ /(\d+\.\d+\.\d+)\.\[(\d+)-(\d+)\]$/) { |
|
#35.8.3.[34-56] |
|
my $low=$2; |
|
my $high=$3; |
|
$pattern=$1; |
|
if ($ip =~ /^\Q$pattern\E/) { |
|
my $last=(split(/\./,$ip))[3]; |
|
if ($last <=$high && $last >=$low) { $allowed=$access{$acctype}; } |
|
} |
|
} elsif ($pattern =~ /^\*/) { |
|
#*.msu.edu |
|
$pattern=~s/\*//; |
|
if (!defined($name)) { |
|
use Socket; |
|
my $netaddr=inet_aton($ip); |
|
($name)=gethostbyaddr($netaddr,AF_INET); |
|
} |
|
if ($name =~ /\Q$pattern\E$/i) { $allowed=$access{$acctype}; } |
|
} elsif ($pattern =~ /\d+\.\d+\.\d+\.\d+/) { |
|
#127.0.0.1 |
|
if ($ip =~ /^\Q$pattern\E/) { $allowed=$access{$acctype}; } |
|
} else { |
|
#some.name.com |
|
if (!defined($name)) { |
|
use Socket; |
|
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; |
|
} |
|
} |
|
return $allowed; |
|
} |
|
|
|
############################################### |
############################################### |
|
|
=pod |
=pod |
Line 12188 sub process_decompression {
|
Line 12109 sub process_decompression {
|
if (ref($newdirlistref) eq 'ARRAY') { |
if (ref($newdirlistref) eq 'ARRAY') { |
foreach my $dir_line (@{$newdirlistref}) { |
foreach my $dir_line (@{$newdirlistref}) { |
my ($item,undef,undef,$testdir)=split(/\&/,$dir_line,5); |
my ($item,undef,undef,$testdir)=split(/\&/,$dir_line,5); |
unless (($item =~ /^\.+$/) || ($item eq $file) || |
unless (($item =~ /^\.+$/) || ($item eq $file)) { |
((@to_skip > 0) && (grep(/^\Q$item\E$/,@to_skip)))) { |
|
push(@newitems,$item); |
push(@newitems,$item); |
if ($dirptr&$testdir) { |
if ($dirptr&$testdir) { |
$is_dir{$item} = 1; |
$is_dir{$item} = 1; |
Line 12777 sub process_extracted_files {
|
Line 12697 sub process_extracted_files {
|
$newseqid{$i} = $newidx; |
$newseqid{$i} = $newidx; |
unless ($errtext) { |
unless ($errtext) { |
$result .= '<li>'.&mt('Folder: [_1] added to course', |
$result .= '<li>'.&mt('Folder: [_1] added to course', |
&HTML::Entities::encode($docstitle,'<>&"')). |
&HTML::Entities::encode($docstitle,'<>&"')).. |
'</li>'."\n"; |
'</li>'."\n"; |
} |
} |
} |
} |
Line 12802 sub process_extracted_files {
|
Line 12722 sub process_extracted_files {
|
$fetch =~ s/^\Q$prefix$dir\E//; |
$fetch =~ s/^\Q$prefix$dir\E//; |
$prompttofetch{$fetch} = 1; |
$prompttofetch{$fetch} = 1; |
} |
} |
} |
} |
} |
} |
$LONCAPA::map::resources[$newidx]= |
$LONCAPA::map::resources[$newidx]= |
$docstitle.':'.$url.':false:normal:res'; |
$docstitle.':'.$url.':false:normal:res'; |
Line 12902 sub process_extracted_files {
|
Line 12822 sub process_extracted_files {
|
$result .= '<li>'.&mt('[_1] included as a dependency', |
$result .= '<li>'.&mt('[_1] included as a dependency', |
&HTML::Entities::encode($showpath,'<>&"')). |
&HTML::Entities::encode($showpath,'<>&"')). |
'</li>'."\n"; |
'</li>'."\n"; |
} |
unless ($ishome) { |
unless ($ishome) { |
my $fetch = "$fullpath/$title"; |
my $fetch = "$fullpath/$title"; |
$fetch =~ s/^\Q$prefix$dir\E//; |
$fetch =~ s/^\Q$prefix$dir\E//; |
$prompttofetch{$fetch} = 1; |
$prompttofetch{$fetch} = 1; |
} |
} |
} |
} |
} |
} |
} |
Line 13193 sub upfile_store {
|
Line 13113 sub upfile_store {
|
$env{'form.upfile'}=~s/\n+$//gs; |
$env{'form.upfile'}=~s/\n+$//gs; |
|
|
my $datatoken = &valid_datatoken($env{'user.name'}.'_'.$env{'user.domain'}. |
my $datatoken = &valid_datatoken($env{'user.name'}.'_'.$env{'user.domain'}. |
'_enroll_'.$env{'request.course.id'}.'_'. |
'_enroll_'.$env{'request.course.id'}.'_'. |
time.'_'.$$); |
time.'_'.$$); |
return if ($datatoken eq ''); |
return if ($datatoken eq ''); |
|
|
{ |
{ |
my $datafile = $r->dir_config('lonDaemons'). |
my $datafile = $r->dir_config('lonDaemons'). |
'/tmp/'.$datatoken.'.tmp'; |
'/tmp/'.$datatoken.'.tmp'; |
Line 13234 sub load_tmp_file {
|
Line 13155 sub load_tmp_file {
|
|
|
sub valid_datatoken { |
sub valid_datatoken { |
my ($datatoken) = @_; |
my ($datatoken) = @_; |
if ($datatoken =~ /^$match_username\_$match_domain\_enroll_(|$match_domain\_$match_courseid)\_\d+_\d+$/) { |
if ($datatoken =~ /^$match_username\_$match_domain\_enroll_$match_domain\_$match_courseid\_\d+_\d+$/) { |
return $datatoken; |
return $datatoken; |
} |
} |
return; |
return; |
Line 14128 defdom (domain for which to retrieve con
|
Line 14049 defdom (domain for which to retrieve con
|
origmail (scalar - email address of recipient from loncapa.conf, |
origmail (scalar - email address of recipient from loncapa.conf, |
i.e., predates configuration by DC via domainprefs.pm |
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. |
Returns: comma separated list of addresses to which to send e-mail. |
|
|
=back |
=back |
Line 14144 Returns: comma separated list of address
|
Line 14058 Returns: comma separated list of address
|
############################################################ |
############################################################ |
############################################################ |
############################################################ |
sub build_recipient_list { |
sub build_recipient_list { |
my ($defmail,$mailing,$defdom,$origmail,$requname,$requdom,$reqemail) = @_; |
my ($defmail,$mailing,$defdom,$origmail) = @_; |
my @recipients; |
my @recipients; |
my ($otheremails,$lastresort,$allbcc,$addtext); |
my ($otheremails,$lastresort,$allbcc,$addtext); |
my %domconfig = |
my %domconfig = |
Line 14185 sub build_recipient_list {
|
Line 14099 sub build_recipient_list {
|
} elsif ($origmail ne '') { |
} elsif ($origmail ne '') { |
$lastresort = $origmail; |
$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 '') { |
} elsif ($origmail ne '') { |
$lastresort = $origmail; |
$lastresort = $origmail; |
} |
} |
Line 15660 sub init_user_environment {
|
Line 15486 sub init_user_environment {
|
|
|
my %userenv = &Apache::lonnet::dump('environment',$domain,$username); |
my %userenv = &Apache::lonnet::dump('environment',$domain,$username); |
my ($tmp) = keys(%userenv); |
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); |
undef(%userenv); |
} |
} |
if (($userenv{'interface'}) && (!$form->{'interface'})) { |
if (($userenv{'interface'}) && (!$form->{'interface'})) { |
Line 17057 sub des_decrypt {
|
Line 16884 sub des_decrypt {
|
return $plaintext; |
return $plaintext; |
} |
} |
|
|
sub make_short_symbs { |
|
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); |
|
my %tocreate; |
|
if (keys(%resources)) { |
|
foreach my $item (sort {$a <=> $b} (@toshorten)) { |
|
my $symb = $resources{$item}; |
|
if ($symb) { |
|
$tocreate{$cnum.'&'.$symb} = 1; |
|
} |
|
} |
|
} |
|
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; |
|
my $lockhash = { |
|
"lock\0$now" => $env{'user.name'}. |
|
':'.$env{'user.domain'}, |
|
}; |
|
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; |
|
} |
|
} |
|
} |
|
return $init; |
|
} |
|
|
|
1; |
1; |
__END__; |
__END__; |
|
|