--- loncom/interface/loncommon.pm 2019/02/07 16:45:53 1.1075.2.127.2.8 +++ loncom/interface/loncommon.pm 2017/08/15 23:46:15 1.1075.2.127.4.1 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # a pile of common routines # -# $Id: loncommon.pm,v 1.1075.2.127.2.8 2019/02/07 16:45:53 raeburn Exp $ +# $Id: loncommon.pm,v 1.1075.2.127.4.1 2017/08/15 23:46:15 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -80,10 +80,6 @@ use JSON::DWIW; use LWP::UserAgent; use Crypt::DES; use DynaLoader; # for Crypt::DES version -use File::Copy(); -use File::Path(); -use String::CRC32(); -use Short::URL(); # ---------------------------------------------- Designs use vars qw(%defaultdesign); @@ -198,7 +194,7 @@ BEGIN { { my $langtabfile = $Apache::lonnet::perlvar{'lonTabDir'}. '/language.tab'; - if ( open(my $fh,'<',$langtabfile) ) { + if ( open(my $fh,"<$langtabfile") ) { while (my $line = <$fh>) { next if ($line=~/^\#/); chomp($line); @@ -219,7 +215,7 @@ BEGIN { { my $copyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}. '/copyright.tab'; - if ( open (my $fh,'<',$copyrightfile) ) { + if ( open (my $fh,"<$copyrightfile") ) { while (my $line = <$fh>) { next if ($line=~/^\#/); chomp($line); @@ -233,7 +229,7 @@ BEGIN { { my $sourcecopyrightfile = $Apache::lonnet::perlvar{'lonIncludes'}. '/source_copyright.tab'; - if ( open (my $fh,'<',$sourcecopyrightfile) ) { + if ( open (my $fh,"<$sourcecopyrightfile") ) { while (my $line = <$fh>) { next if ($line =~ /^\#/); chomp($line); @@ -247,7 +243,7 @@ BEGIN { # -------------------------------------------------------------- default domain designs my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors'; my $designfile = $designdir.'/default.tab'; - if ( open (my $fh,'<',$designfile) ) { + if ( open (my $fh,"<$designfile") ) { while (my $line = <$fh>) { next if ($line =~ /^\#/); chomp($line); @@ -261,7 +257,7 @@ BEGIN { { my $categoryfile = $Apache::lonnet::perlvar{'lonTabDir'}. '/filecategories.tab'; - if ( open (my $fh,'<',$categoryfile) ) { + if ( open (my $fh,"<$categoryfile") ) { while (my $line = <$fh>) { next if ($line =~ /^\#/); chomp($line); @@ -276,7 +272,7 @@ BEGIN { { my $typesfile = $Apache::lonnet::perlvar{'lonTabDir'}. '/filetypes.tab'; - if ( open (my $fh,'<',$typesfile) ) { + if ( open (my $fh,"<$typesfile") ) { while (my $line = <$fh>) { next if ($line =~ /^\#/); chomp($line); @@ -4996,87 +4992,6 @@ sub check_ip_acc { 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 @@ -5217,7 +5132,7 @@ sub get_legacy_domconf { my $designdir=$Apache::lonnet::perlvar{'lonTabDir'}.'/lonDomColors'; my $designfile = $designdir.'/'.$udom.'.tab'; if (-e $designfile) { - if ( open (my $fh,'<',$designfile) ) { + if ( open (my $fh,"<$designfile") ) { while (my $line = <$fh>) { next if ($line =~ /^\#/); chomp($line); @@ -6156,6 +6071,11 @@ td.LC_menubuttons_text { background: $tabbg; } +td.LC_zero_height { + line-height: 0; + cellpadding: 0; +} + table.LC_data_table { border: 1px solid #000000; border-collapse: separate; @@ -6828,6 +6748,7 @@ table.LC_data_table tr > td.LC_docs_entr color: #990000; } +.LC_domprefs_email, .LC_docs_reinit_warn, .LC_docs_ext_edit { font-size: x-small; @@ -11505,7 +11426,7 @@ sub modify_html_refs { return; } } - if (open(my $fh,'<',$container)) { + if (open(my $fh,"<$container")) { $content = join('', <$fh>); close($fh); } else { @@ -11570,7 +11491,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].', @@ -12087,18 +12008,6 @@ 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.'). @@ -12133,44 +12042,30 @@ sub process_decompression { } } my $numskip = scalar(@to_skip); - my $numoverwrite = scalar(@to_overwrite); - if (($numskip) && (!$numoverwrite)) { + if (($numskip > 0) && + ($numskip == $env{'form.archive_itemcount'})) { $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) || ($numoverwrite)) { + if ($numskip > 0) { my $tempdir = time.'_'.$$.int(rand(10000)); mkdir("$dir/$tempdir",0755); - 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"); - } + 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/$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); @@ -12674,7 +12569,7 @@ END sub process_extracted_files { my ($context,$docudom,$docuname,$destination,$dir_root,$hiddenelem) = @_; my $numitems = $env{'form.archive_count'}; - return if ((!$numitems) || ($numitems =~ /\D/)); + return unless ($numitems); my @ids=&Apache::lonnet::current_machine_ids(); my ($prefix,$pathtocheck,$dir,$ishome,$error,$warning,%toplevelitems,%is_dir, %folders,%containers,%mapinner,%prompttofetch); @@ -12687,7 +12582,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+)/}); @@ -12776,9 +12671,7 @@ sub process_extracted_files { '.'.$containers{$outer},1,1); $newseqid{$i} = $newidx; unless ($errtext) { - $result .= '
  • '.&mt('Folder: [_1] added to course', - &HTML::Entities::encode($docstitle,'<>&"')). - '
    • '."\n"; + $result .= '
  • '.&mt('Folder: [_1] added to course',$docstitle).'
    • '."\n"; } } } else { @@ -12787,47 +12680,38 @@ sub process_extracted_files { my $url = '/uploaded/'.$docudom.'/'.$docuname.'/'. $docstype.'/'.$mapinner{$outer}.'/'.$newidx.'/'. $title; - if (($outer !~ /\D/) && ($mapinner{$outer} !~ /\D/) && ($newidx !~ /\D/)) { - 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") { - 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; - } - } + 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; } - $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"; - } + } + $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"; } - } 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.', - &HTML::Entities::encode($path,'<>&"')).'
    '; + $warning .= &mt('Item extracted from archive: [_1] has unexpected path.',$path).'
    '; } } for (my $i=1; $i<=$numitems; $i++) { @@ -12888,9 +12772,7 @@ sub process_extracted_files { } if ($fullpath ne '') { if (-e "$prefix$path") { - unless (rename("$prefix$path","$fullpath/$title")) { - $warning .= &mt('Failed to rename dependency').'
    '; - } + system("mv $prefix$path $fullpath/$title"); } if (-e "$fullpath/$title") { my $showpath; @@ -12899,9 +12781,7 @@ sub process_extracted_files { } else { $showpath = "/$title"; } - $result .= '
  • '.&mt('[_1] included as a dependency', - &HTML::Entities::encode($showpath,'<>&"')). - '
    • '."\n"; + $result .= '
  • '.&mt('[_1] included as a dependency',$showpath).'
    • '."\n"; } unless ($ishome) { my $fetch = "$fullpath/$title"; @@ -12912,13 +12792,10 @@ sub process_extracted_files { } } elsif ($env{'form.archive_'.$referrer{$i}} eq 'discard') { $warning .= &mt('[_1] is a dependency of [_2], which was discarded.', - &HTML::Entities::encode($path,'<>&"'), - &HTML::Entities::encode($env{'form.archive_content_'.$referrer{$i}},'<>&"')). - '
    '; + $path,$env{'form.archive_content_'.$referrer{$i}}).'
    '; } } else { - $warning .= &mt('Item extracted from archive: [_1] has unexpected path.', - &HTML::Entities::encode($path)).'
    '; + $warning .= &mt('Item extracted from archive: [_1] has unexpected path.',$path).'
    '; } } if (keys(%todelete)) { @@ -13192,14 +13069,12 @@ sub upfile_store { $env{'form.upfile'}=~s/\n+/\n/gs; $env{'form.upfile'}=~s/\n+$//gs; - my $datatoken = &valid_datatoken($env{'user.name'}.'_'.$env{'user.domain'}. - '_enroll_'.$env{'request.course.id'}.'_'. - time.'_'.$$); - return if ($datatoken eq ''); + my $datatoken=$env{'user.name'}.'_'.$env{'user.domain'}. + '_enroll_'.$env{'request.course.id'}.'_'.time.'_'.$$; { 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); } @@ -13209,22 +13084,21 @@ sub upfile_store { =pod -=item * &load_tmp_file($r,$datatoken) +=item * &load_tmp_file($r) Load uploaded file from tmp, $r should be the HTTP Request object, -$datatoken is the name to assign to the temporary file. +needs $env{'form.datatoken'}, sets $env{'form.upfile'} to the contents of the file =cut sub load_tmp_file { - my ($r,$datatoken) = @_; - return if ($datatoken eq ''); + my $r=shift; my @studentdata=(); { my $studentfile = $r->dir_config('lonDaemons'). - '/tmp/'.$datatoken.'.tmp'; - if ( open(my $fh,'<',$studentfile) ) { + '/tmp/'.$env{'form.datatoken'}.'.tmp'; + if ( open(my $fh,"<$studentfile") ) { @studentdata=<$fh>; close($fh); } @@ -13232,14 +13106,6 @@ 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() @@ -14128,13 +13994,6 @@ 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 @@ -14144,7 +14003,7 @@ Returns: comma separated list of address ############################################################ ############################################################ sub build_recipient_list { - my ($defmail,$mailing,$defdom,$origmail,$requname,$requdom,$reqemail) = @_; + my ($defmail,$mailing,$defdom,$origmail) = @_; my @recipients; my ($otheremails,$lastresort,$allbcc,$addtext); my %domconfig = @@ -14185,99 +14044,11 @@ 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 'helpdeskmail') && ($lastresort ne '')) { + if (($mailing eq 'helpdesk') && ($lastresort ne '')) { unless (grep(/^\Q$defdom\E$/,&Apache::lonnet::current_machine_domains())) { my $lonhost = $Apache::lonnet::perlvar{'lonHostID'}; my $machinedom = $Apache::lonnet::perlvar{'lonDefDomain'}; @@ -14357,7 +14128,7 @@ sub build_recipient_list { } } } - if ($mailing eq 'helpdeskmail') { + if ($mailing eq 'helpdesk') { if ((!@recipients) && ($lastresort ne '')) { push(@recipients,$lastresort); } @@ -15660,7 +15431,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'})) { @@ -17057,130 +16829,6 @@ sub des_decrypt { 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; __END__;