version 1.1075.2.127.2.3, 2017/11/01 02:54:35
|
version 1.1075.2.127.2.7, 2019/02/06 16:10:34
|
Line 81 use LWP::UserAgent;
|
Line 81 use LWP::UserAgent;
|
use Crypt::DES; |
use Crypt::DES; |
use DynaLoader; # for Crypt::DES version |
use DynaLoader; # for Crypt::DES version |
use File::Copy(); |
use File::Copy(); |
use File::Path::Tiny(); |
use File::Path(); |
|
use String::CRC32(); |
|
use Short::URL(); |
|
|
# ---------------------------------------------- Designs |
# ---------------------------------------------- Designs |
use vars qw(%defaultdesign); |
use vars qw(%defaultdesign); |
Line 196 BEGIN {
|
Line 198 BEGIN {
|
{ |
{ |
my $langtabfile = $Apache::lonnet::perlvar{'lonTabDir'}. |
my $langtabfile = $Apache::lonnet::perlvar{'lonTabDir'}. |
'/language.tab'; |
'/language.tab'; |
if ( open(my $fh,"<$langtabfile") ) { |
if ( open(my $fh,'<',$langtabfile) ) { |
while (my $line = <$fh>) { |
while (my $line = <$fh>) { |
next if ($line=~/^\#/); |
next if ($line=~/^\#/); |
chomp($line); |
chomp($line); |
Line 217 BEGIN {
|
Line 219 BEGIN {
|
{ |
{ |
my $copyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}. |
my $copyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}. |
'/copyright.tab'; |
'/copyright.tab'; |
if ( open (my $fh,"<$copyrightfile") ) { |
if ( open (my $fh,'<',$copyrightfile) ) { |
while (my $line = <$fh>) { |
while (my $line = <$fh>) { |
next if ($line=~/^\#/); |
next if ($line=~/^\#/); |
chomp($line); |
chomp($line); |
Line 231 BEGIN {
|
Line 233 BEGIN {
|
{ |
{ |
my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}. |
my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}. |
'/source_copyright.tab'; |
'/source_copyright.tab'; |
if ( open (my $fh,"<$sourcecopyrightfile") ) { |
if ( open (my $fh,'<',$sourcecopyrightfile) ) { |
while (my $line = <$fh>) { |
while (my $line = <$fh>) { |
next if ($line =~ /^\#/); |
next if ($line =~ /^\#/); |
chomp($line); |
chomp($line); |
Line 245 BEGIN {
|
Line 247 BEGIN {
|
# -------------------------------------------------------------- default domain designs |
# -------------------------------------------------------------- default domain designs |
my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors'; |
my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors'; |
my $designfile = $designdir.'/default.tab'; |
my $designfile = $designdir.'/default.tab'; |
if ( open (my $fh,"<$designfile") ) { |
if ( open (my $fh,'<',$designfile) ) { |
while (my $line = <$fh>) { |
while (my $line = <$fh>) { |
next if ($line =~ /^\#/); |
next if ($line =~ /^\#/); |
chomp($line); |
chomp($line); |
Line 259 BEGIN {
|
Line 261 BEGIN {
|
{ |
{ |
my $categoryfile = $Apache::lonnet::perlvar{'lonTabDir'}. |
my $categoryfile = $Apache::lonnet::perlvar{'lonTabDir'}. |
'/filecategories.tab'; |
'/filecategories.tab'; |
if ( open (my $fh,"<$categoryfile") ) { |
if ( open (my $fh,'<',$categoryfile) ) { |
while (my $line = <$fh>) { |
while (my $line = <$fh>) { |
next if ($line =~ /^\#/); |
next if ($line =~ /^\#/); |
chomp($line); |
chomp($line); |
Line 274 BEGIN {
|
Line 276 BEGIN {
|
{ |
{ |
my $typesfile = $Apache::lonnet::perlvar{'lonTabDir'}. |
my $typesfile = $Apache::lonnet::perlvar{'lonTabDir'}. |
'/filetypes.tab'; |
'/filetypes.tab'; |
if ( open (my $fh,"<$typesfile") ) { |
if ( open (my $fh,'<',$typesfile) ) { |
while (my $line = <$fh>) { |
while (my $line = <$fh>) { |
next if ($line =~ /^\#/); |
next if ($line =~ /^\#/); |
chomp($line); |
chomp($line); |
Line 5215 sub get_legacy_domconf {
|
Line 5217 sub get_legacy_domconf {
|
my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors'; |
my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors'; |
my $designfile = $designdir.'/'.$udom.'.tab'; |
my $designfile = $designdir.'/'.$udom.'.tab'; |
if (-e $designfile) { |
if (-e $designfile) { |
if ( open (my $fh,"<$designfile") ) { |
if ( open (my $fh,'<',$designfile) ) { |
while (my $line = <$fh>) { |
while (my $line = <$fh>) { |
next if ($line =~ /^\#/); |
next if ($line =~ /^\#/); |
chomp($line); |
chomp($line); |
Line 11503 sub modify_html_refs {
|
Line 11505 sub modify_html_refs {
|
return; |
return; |
} |
} |
} |
} |
if (open(my $fh,"<$container")) { |
if (open(my $fh,'<',$container)) { |
$content = join('', <$fh>); |
$content = join('', <$fh>); |
close($fh); |
close($fh); |
} else { |
} else { |
Line 11568 sub modify_html_refs {
|
Line 11570 sub modify_html_refs {
|
} |
} |
} |
} |
} else { |
} else { |
if (open(my $fh,">$container")) { |
if (open(my $fh,'>',$container)) { |
print $fh $content; |
print $fh $content; |
close($fh); |
close($fh); |
$output = '<p>'.&mt('Updated [quant,_1,reference] in [_2].', |
$output = '<p>'.&mt('Updated [quant,_1,reference] in [_2].', |
Line 12149 sub process_decompression {
|
Line 12151 sub process_decompression {
|
if (-f "$dir/$tempdir/$item") { |
if (-f "$dir/$tempdir/$item") { |
unlink("$dir/$tempdir/$item"); |
unlink("$dir/$tempdir/$item"); |
} elsif (-d "$dir/$tempdir/$item") { |
} elsif (-d "$dir/$tempdir/$item") { |
&File::Path::Tiny::rm("$dir/$tempdir/$item"); |
&File::Path::remove_tree("$dir/$tempdir/$item",{ safe => 1 }); |
} |
} |
} |
} |
} |
} |
Line 12159 sub process_decompression {
|
Line 12161 sub process_decompression {
|
if (-f "$dir/$item") { |
if (-f "$dir/$item") { |
unlink("$dir/$item"); |
unlink("$dir/$item"); |
} elsif (-d "$dir/$item") { |
} elsif (-d "$dir/$item") { |
&File::Path::Tiny::rm("$dir/$item"); |
&File::Path::remove_tree("$dir/$item",{ safe => 1 }); |
} |
} |
&File::Copy::move("$dir/$tempdir/$item","$dir/$item"); |
&File::Copy::move("$dir/$tempdir/$item","$dir/$item"); |
} |
} |
} |
} |
} |
} |
if (&File::Copy::move("$dir/$tempdir/$file","$dir/$file")) { |
if (&File::Copy::move("$dir/$tempdir/$file","$dir/$file")) { |
&File::Path::Tiny::rm("$dir/$tempdir"); |
&File::Path::remove_tree("$dir/$tempdir",{ safe => 1 }); |
} |
} |
} |
} |
} else { |
} else { |
Line 12811 sub process_extracted_files {
|
Line 12813 sub process_extracted_files {
|
'.'.$containers{$outer},1,1); |
'.'.$containers{$outer},1,1); |
unless ($errtext) { |
unless ($errtext) { |
if (-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx/$title") { |
if (-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx/$title") { |
$result .= '<li>'.&mt('File: [_1] added to course',$docstitle).'</li>'."\n"; |
$result .= '<li>'.&mt('File: [_1] added to course', |
|
&HTML::Entities::encode($docstitle,'<>&"')). |
|
'</li>'."\n"; |
} |
} |
} |
} |
} else { |
} else { |
Line 12884 sub process_extracted_files {
|
Line 12888 sub process_extracted_files {
|
} |
} |
if ($fullpath ne '') { |
if ($fullpath ne '') { |
if (-e "$prefix$path") { |
if (-e "$prefix$path") { |
system("mv $prefix$path $fullpath/$title"); |
unless (rename("$prefix$path","$fullpath/$title")) { |
|
$warning .= &mt('Failed to rename dependency').'<br />'; |
|
} |
} |
} |
if (-e "$fullpath/$title") { |
if (-e "$fullpath/$title") { |
my $showpath; |
my $showpath; |
Line 13186 sub upfile_store {
|
Line 13192 sub upfile_store {
|
$env{'form.upfile'}=~s/\n+/\n/gs; |
$env{'form.upfile'}=~s/\n+/\n/gs; |
$env{'form.upfile'}=~s/\n+$//gs; |
$env{'form.upfile'}=~s/\n+$//gs; |
|
|
my $datatoken=$env{'user.name'}.'_'.$env{'user.domain'}. |
my $datatoken = &valid_datatoken($env{'user.name'}.'_'.$env{'user.domain'}. |
'_enroll_'.$env{'request.course.id'}.'_'.time.'_'.$$; |
'_enroll_'.$env{'request.course.id'}.'_'. |
|
time.'_'.$$); |
|
return if ($datatoken eq ''); |
{ |
{ |
my $datafile = $r->dir_config('lonDaemons'). |
my $datafile = $r->dir_config('lonDaemons'). |
'/tmp/'.$datatoken.'.tmp'; |
'/tmp/'.$datatoken.'.tmp'; |
if ( open(my $fh,">$datafile") ) { |
if ( open(my $fh,'>',$datafile) ) { |
print $fh $env{'form.upfile'}; |
print $fh $env{'form.upfile'}; |
close($fh); |
close($fh); |
} |
} |
Line 13216 sub load_tmp_file {
|
Line 13224 sub load_tmp_file {
|
{ |
{ |
my $studentfile = $r->dir_config('lonDaemons'). |
my $studentfile = $r->dir_config('lonDaemons'). |
'/tmp/'.$datatoken.'.tmp'; |
'/tmp/'.$datatoken.'.tmp'; |
if ( open(my $fh,"<$studentfile") ) { |
if ( open(my $fh,'<',$studentfile) ) { |
@studentdata=<$fh>; |
@studentdata=<$fh>; |
close($fh); |
close($fh); |
} |
} |
Line 13226 sub load_tmp_file {
|
Line 13234 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 15652 sub init_user_environment {
|
Line 15660 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 17050 sub des_decrypt {
|
Line 17057 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__; |
|
|