version 1.1075.2.127.2.2, 2017/10/15 14:10:08
|
version 1.1075.2.127.2.7, 2019/02/06 16:10:34
|
Line 80 use JSON::DWIW;
|
Line 80 use JSON::DWIW;
|
use LWP::UserAgent; |
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::Path(); |
|
use String::CRC32(); |
|
use Short::URL(); |
|
|
# ---------------------------------------------- Designs |
# ---------------------------------------------- Designs |
use vars qw(%defaultdesign); |
use vars qw(%defaultdesign); |
Line 194 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 215 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 229 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 243 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 257 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 272 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 5213 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 11501 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 11566 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 12083 sub decompress_uploaded_file {
|
Line 12087 sub decompress_uploaded_file {
|
|
|
sub process_decompression { |
sub process_decompression { |
my ($docudom,$docuname,$file,$destination,$dir_root,$hiddenelem) = @_; |
my ($docudom,$docuname,$file,$destination,$dir_root,$hiddenelem) = @_; |
|
unless (($dir_root eq '/userfiles') && ($destination =~ m{^(docs|supplemental)/(default|\d+)/\d+$})) { |
|
return '<p class="LC_error">'.&mt('Not extracted.').'<br />'. |
|
&mt('Unexpected file path.').'</p>'."\n"; |
|
} |
|
unless (($docudom =~ /^$match_domain$/) && ($docuname =~ /^$match_courseid$/)) { |
|
return '<p class="LC_error">'.&mt('Not extracted.').'<br />'. |
|
&mt('Unexpected course context.').'</p>'."\n"; |
|
} |
|
unless ($file eq &Apache::lonnet::clean_filename($file)) { |
|
return '<p class="LC_error">'.&mt('Not extracted.').'<br />'. |
|
&mt('Filename contained unexpected characters.').'</p>'."\n"; |
|
} |
my ($dir,$error,$warning,$output); |
my ($dir,$error,$warning,$output); |
if ($file !~ /\.(zip|tar|bz2|gz|tar.gz|tar.bz2|tgz)$/i) { |
if ($file !~ /\.(zip|tar|bz2|gz|tar.gz|tar.bz2|tgz)$/i) { |
$error = &mt('Filename not a supported archive file type.'). |
$error = &mt('Filename not a supported archive file type.'). |
Line 12117 sub process_decompression {
|
Line 12133 sub process_decompression {
|
} |
} |
} |
} |
my $numskip = scalar(@to_skip); |
my $numskip = scalar(@to_skip); |
if (($numskip > 0) && |
my $numoverwrite = scalar(@to_overwrite); |
($numskip == $env{'form.archive_itemcount'})) { |
if (($numskip) && (!$numoverwrite)) { |
$warning = &mt('All items in the archive file already exist, and no overwriting of existing files has been requested.'); |
$warning = &mt('All items in the archive file already exist, and no overwriting of existing files has been requested.'); |
} elsif ($dir eq '') { |
} elsif ($dir eq '') { |
$error = &mt('Directory containing archive file unavailable.'); |
$error = &mt('Directory containing archive file unavailable.'); |
} elsif (!$error) { |
} elsif (!$error) { |
my ($decompressed,$display); |
my ($decompressed,$display); |
if ($numskip > 0) { |
if (($numskip) || ($numoverwrite)) { |
my $tempdir = time.'_'.$$.int(rand(10000)); |
my $tempdir = time.'_'.$$.int(rand(10000)); |
mkdir("$dir/$tempdir",0755); |
mkdir("$dir/$tempdir",0755); |
system("mv $dir/$file $dir/$tempdir/$file"); |
if (&File::Copy::move("$dir/$file","$dir/$tempdir/$file")) { |
($decompressed,$display) = |
($decompressed,$display) = |
&decompress_uploaded_file($file,"$dir/$tempdir"); |
&decompress_uploaded_file($file,"$dir/$tempdir"); |
foreach my $item (@to_skip) { |
foreach my $item (@to_skip) { |
if (($item ne '') && ($item !~ /\.\./)) { |
if (($item ne '') && ($item !~ /\.\./)) { |
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") { |
system("rm -rf $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 { |
} else { |
($decompressed,$display) = |
($decompressed,$display) = |
&decompress_uploaded_file($file,$dir); |
&decompress_uploaded_file($file,$dir); |
Line 12644 END
|
Line 12674 END
|
sub process_extracted_files { |
sub process_extracted_files { |
my ($context,$docudom,$docuname,$destination,$dir_root,$hiddenelem) = @_; |
my ($context,$docudom,$docuname,$destination,$dir_root,$hiddenelem) = @_; |
my $numitems = $env{'form.archive_count'}; |
my $numitems = $env{'form.archive_count'}; |
return unless ($numitems); |
return if ((!$numitems) || ($numitems =~ /\D/)); |
my @ids=&Apache::lonnet::current_machine_ids(); |
my @ids=&Apache::lonnet::current_machine_ids(); |
my ($prefix,$pathtocheck,$dir,$ishome,$error,$warning,%toplevelitems,%is_dir, |
my ($prefix,$pathtocheck,$dir,$ishome,$error,$warning,%toplevelitems,%is_dir, |
%folders,%containers,%mapinner,%prompttofetch); |
%folders,%containers,%mapinner,%prompttofetch); |
Line 12657 sub process_extracted_files {
|
Line 12687 sub process_extracted_files {
|
} else { |
} else { |
$prefix = $Apache::lonnet::perlvar{'lonDocRoot'}; |
$prefix = $Apache::lonnet::perlvar{'lonDocRoot'}; |
$pathtocheck = "$dir_root/$docudom/$docuname/$destination"; |
$pathtocheck = "$dir_root/$docudom/$docuname/$destination"; |
$dir = "$dir_root/$docudom/$docuname"; |
$dir = "$dir_root/$docudom/$docuname"; |
} |
} |
my $currdir = "$dir_root/$destination"; |
my $currdir = "$dir_root/$destination"; |
(my $docstype,$mapinner{'0'}) = ($destination =~ m{^(docs|supplemental)/(\w+)/}); |
(my $docstype,$mapinner{'0'}) = ($destination =~ m{^(docs|supplemental)/(\w+)/}); |
Line 12746 sub process_extracted_files {
|
Line 12776 sub process_extracted_files {
|
'.'.$containers{$outer},1,1); |
'.'.$containers{$outer},1,1); |
$newseqid{$i} = $newidx; |
$newseqid{$i} = $newidx; |
unless ($errtext) { |
unless ($errtext) { |
$result .= '<li>'.&mt('Folder: [_1] added to course',$docstitle).'</li>'."\n"; |
$result .= '<li>'.&mt('Folder: [_1] added to course', |
|
&HTML::Entities::encode($docstitle,'<>&"')). |
|
'</li>'."\n"; |
} |
} |
} |
} |
} else { |
} else { |
Line 12755 sub process_extracted_files {
|
Line 12787 sub process_extracted_files {
|
my $url = '/uploaded/'.$docudom.'/'.$docuname.'/'. |
my $url = '/uploaded/'.$docudom.'/'.$docuname.'/'. |
$docstype.'/'.$mapinner{$outer}.'/'.$newidx.'/'. |
$docstype.'/'.$mapinner{$outer}.'/'.$newidx.'/'. |
$title; |
$title; |
if (!-e "$prefix$dir/$docstype/$mapinner{$outer}") { |
if (($outer !~ /\D/) && ($mapinner{$outer} !~ /\D/) && ($newidx !~ /\D/)) { |
mkdir("$prefix$dir/$docstype/$mapinner{$outer}",0755); |
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 (!-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx") { |
$LONCAPA::map::resources[$newidx]= |
mkdir("$prefix$dir/$docstype/$mapinner{$outer}/$newidx"); |
$docstitle.':'.$url.':false:normal:res'; |
} |
push(@LONCAPA::map::order, $newidx); |
if (-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx") { |
my ($outtext,$errtext)= |
if (rename("$prefix$path","$prefix$dir/$docstype/$mapinner{$outer}/$newidx/$title")) { |
&LONCAPA::map::storemap('/uploaded/'.$docudom.'/'. |
$newdest{$i} = "$prefix$dir/$docstype/$mapinner{$outer}/$newidx"; |
$docuname.'/'.$folders{$outer}. |
unless ($ishome) { |
'.'.$containers{$outer},1,1); |
my $fetch = "$newdest{$i}/$title"; |
unless ($errtext) { |
$fetch =~ s/^\Q$prefix$dir\E//; |
if (-e "$prefix$dir/$docstype/$mapinner{$outer}/$newidx/$title") { |
$prompttofetch{$fetch} = 1; |
$result .= '<li>'.&mt('File: [_1] added to course',$docstitle).'</li>'."\n"; |
} |
|
} |
} |
} |
|
$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 .= '<li>'.&mt('File: [_1] added to course', |
|
&HTML::Entities::encode($docstitle,'<>&"')). |
|
'</li>'."\n"; |
|
} |
|
} |
|
} else { |
|
$warning .= &mt('Item extracted from archive: [_1] has unexpected path.', |
|
&HTML::Entities::encode($path,'<>&"')).'<br />'; |
} |
} |
} |
} |
} |
} |
} |
} |
} else { |
} else { |
$warning .= &mt('Item extracted from archive: [_1] has unexpected path.',$path).'<br />'; |
$warning .= &mt('Item extracted from archive: [_1] has unexpected path.', |
|
&HTML::Entities::encode($path,'<>&"')).'<br />'; |
} |
} |
} |
} |
for (my $i=1; $i<=$numitems; $i++) { |
for (my $i=1; $i<=$numitems; $i++) { |
Line 12847 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 12856 sub process_extracted_files {
|
Line 12899 sub process_extracted_files {
|
} else { |
} else { |
$showpath = "/$title"; |
$showpath = "/$title"; |
} |
} |
$result .= '<li>'.&mt('[_1] included as a dependency',$showpath).'</li>'."\n"; |
$result .= '<li>'.&mt('[_1] included as a dependency', |
|
&HTML::Entities::encode($showpath,'<>&"')). |
|
'</li>'."\n"; |
} |
} |
unless ($ishome) { |
unless ($ishome) { |
my $fetch = "$fullpath/$title"; |
my $fetch = "$fullpath/$title"; |
Line 12867 sub process_extracted_files {
|
Line 12912 sub process_extracted_files {
|
} |
} |
} elsif ($env{'form.archive_'.$referrer{$i}} eq 'discard') { |
} elsif ($env{'form.archive_'.$referrer{$i}} eq 'discard') { |
$warning .= &mt('[_1] is a dependency of [_2], which was discarded.', |
$warning .= &mt('[_1] is a dependency of [_2], which was discarded.', |
$path,$env{'form.archive_content_'.$referrer{$i}}).'<br />'; |
&HTML::Entities::encode($path,'<>&"'), |
|
&HTML::Entities::encode($env{'form.archive_content_'.$referrer{$i}},'<>&"')). |
|
'<br />'; |
} |
} |
} else { |
} else { |
$warning .= &mt('Item extracted from archive: [_1] has unexpected path.',$path).'<br />'; |
$warning .= &mt('Item extracted from archive: [_1] has unexpected path.', |
|
&HTML::Entities::encode($path)).'<br />'; |
} |
} |
} |
} |
if (keys(%todelete)) { |
if (keys(%todelete)) { |
Line 13144 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 13159 sub upfile_store {
|
Line 13209 sub upfile_store {
|
|
|
=pod |
=pod |
|
|
=item * &load_tmp_file($r) |
=item * &load_tmp_file($r,$datatoken) |
|
|
Load uploaded file from tmp, $r should be the HTTP Request object, |
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 |
sets $env{'form.upfile'} to the contents of the file |
|
|
=cut |
=cut |
|
|
sub load_tmp_file { |
sub load_tmp_file { |
my $r=shift; |
my ($r,$datatoken) = @_; |
|
return if ($datatoken eq ''); |
my @studentdata=(); |
my @studentdata=(); |
{ |
{ |
my $studentfile = $r->dir_config('lonDaemons'). |
my $studentfile = $r->dir_config('lonDaemons'). |
'/tmp/'.$env{'form.datatoken'}.'.tmp'; |
'/tmp/'.$datatoken.'.tmp'; |
if ( open(my $fh,"<$studentfile") ) { |
if ( open(my $fh,'<',$studentfile) ) { |
@studentdata=<$fh>; |
@studentdata=<$fh>; |
close($fh); |
close($fh); |
} |
} |
Line 13181 sub load_tmp_file {
|
Line 13232 sub load_tmp_file {
|
$env{'form.upfile'}=join('',@studentdata); |
$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 |
=pod |
|
|
=item * &upfile_record_sep() |
=item * &upfile_record_sep() |
Line 15601 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 16999 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__; |
|
|