--- loncom/interface/loncommon.pm 2020/02/19 23:30:26 1.1075.2.127.8.1 +++ loncom/interface/loncommon.pm 2019/07/30 11:10:55 1.1075.2.134 @@ -1,7 +1,7 @@ # The LearningOnline Network with CAPA # a pile of common routines # -# $Id: loncommon.pm,v 1.1075.2.127.8.1 2020/02/19 23:30:26 raeburn Exp $ +# $Id: loncommon.pm,v 1.1075.2.134 2019/07/30 11:10:55 raeburn Exp $ # # Copyright Michigan State University Board of Trustees # @@ -80,6 +80,8 @@ use JSON::DWIW; use LWP::UserAgent; use Crypt::DES; use DynaLoader; # for Crypt::DES version +use File::Copy(); +use File::Path(); # ---------------------------------------------- Designs use vars qw(%defaultdesign); @@ -194,7 +196,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); @@ -215,7 +217,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); @@ -229,7 +231,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); @@ -243,7 +245,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); @@ -257,7 +259,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); @@ -272,7 +274,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); @@ -2260,7 +2262,11 @@ sub select_form { if ($onchange) { $onchange = ' onchange="'.$onchange.'"'; } - my $selectform = "\n"; my @keys; if (exists($hashref->{'select_form_order'})) { @keys=@{$hashref->{'select_form_order'}}; @@ -4718,7 +4724,7 @@ sub blockcheck { ($env{'request.role'} !~ m{^st\./\Q$cdom\E/\Q$cnum\E})); 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. my ($start,$end,$trigger) = @@ -4946,14 +4952,8 @@ sub check_ip_acc { if (!defined($acc) || $acc =~ /^\s*$/ || $acc =~/^\s*no\s*$/i) { return 1; } - my $ip; my $allowed=0; - if (($ENV{'REMOTE_ADDR'} eq '127.0.0.1') || - ($ENV{'REMOTE_ADDR'} eq &Apache::lonnet::get_host_ip($Apache::lonnet::perlvar{'lonHostID'}))) { - $ip = $env{'request.host'} || $ENV{'REMOTE_ADDR'} || $clientip; - } else { - $ip = $ENV{'REMOTE_ADDR'} || $env{'request.host'} || $clientip; - } + my $ip=$ENV{'REMOTE_ADDR'} || $clientip || $env{'request.host'}; my $name; foreach my $pattern (split(',',$acc)) { @@ -5138,7 +5138,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); @@ -5394,6 +5394,10 @@ Inputs: =item * $args, optional argument valid values are no_auto_mt_title -> prevents &mt()ing the title arg + use_absolute -> for external resource or syllabus, this will + contain https:// if server uses + https (as per hosts.tab), but request is for http + hostname -> hostname, from $r->hostname(). =item * $advtoolsref, optional argument, ref to an array containing inlineremote items to be added in "Functions" menu below @@ -5419,6 +5423,7 @@ sub bodytag { } if (!$args->{'no_auto_mt_title'}) { $title = &mt($title); } my $httphost = $args->{'use_absolute'}; + my $hostname = $args->{'hostname'}; $function = &get_users_function() if (!$function); my $img = &designparm($function.'.img',$domain); @@ -5507,7 +5512,7 @@ sub bodytag { &Apache::lonmenu::prepare_functions($env{'request.noversionuri'}, $forcereg,$args->{'group'}, $args->{'bread_crumbs'}, - $advtoolsref,'',\$forbodytag); + $advtoolsref,'','',\$forbodytag); unless (ref($args->{'bread_crumbs'}) eq 'ARRAY') { $funclist = $forbodytag; } @@ -5553,17 +5558,19 @@ sub bodytag { $bodytag .= Apache::lonhtmlcommon::scripttag('', 'end'); if ($env{'request.state'} eq 'construct') { $bodytag .= &Apache::lonmenu::innerregister($forcereg, - $args->{'bread_crumbs'}); + $args->{'bread_crumbs'},'','',$hostname); } elsif ($forcereg) { $bodytag .= &Apache::lonmenu::innerregister($forcereg,undef, $args->{'group'}, - $args->{'hide_buttons'}); + $args->{'hide_buttons', + $hostname}); } else { my $forbodytag; &Apache::lonmenu::prepare_functions($env{'request.noversionuri'}, $forcereg,$args->{'group'}, $args->{'bread_crumbs'}, - $advtoolsref,'',\$forbodytag); + $advtoolsref,'',$hostname, + \$forbodytag); unless (ref($args->{'bread_crumbs'}) eq 'ARRAY') { $bodytag .= $forbodytag; } @@ -6077,6 +6084,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; @@ -6749,6 +6761,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; @@ -8089,6 +8102,10 @@ $args - additional optional args support to lonhtmlcommon::breadcrumbs group -> includes the current group, if page is for a specific group + use_absolute -> for request for external resource or syllabus, this + will contain https:// if server uses + https (as per hosts.tab), but request is for http + hostname -> hostname, originally from $r->hostname(), (optional). =back @@ -8394,8 +8411,9 @@ sub end_togglebox { } sub LCprogressbar_script { - my ($id)=@_; - return(< // ENDPROGRESS + } else { + return(< +// + +ENDPROGRESS + } } sub LCprogressbarUpdate_script { return(< .ui-progressbar { position:relative; } +.progress-label {position: absolute; width: 100%; text-align: center; top: 1px; font-weight: bold; text-shadow: 1px 1px 0 #fff;margin: 0; line-height: 200%; } .pblabel { position: absolute; width: 100%; text-align: center; line-height: 1.9em; } @@ -8434,37 +8474,54 @@ my $LCidcnt; my $LCcurrentid; sub LCprogressbar { - my ($r)=(@_); + my ($r,$number_to_do,$preamble)=@_; $LClastpercent=0; $LCidcnt++; $LCcurrentid=$$.'_'.$LCidcnt; - my $starting=&mt('Starting'); - my $content=(< $starting ENDPROGBAR - &r_print($r,$content.&LCprogressbar_script($LCcurrentid)); + } else { + $starting=&mt('Loading...'); + $LClastpercent='false'; + $content=(< +
$starting
+ +ENDPROGBAR + } + &r_print($r,$content.&LCprogressbar_script($LCcurrentid,$number_to_do)); } sub LCprogressbarUpdate { - my ($r,$val,$text)=@_; - unless ($val) { - if ($LClastpercent) { - $val=$LClastpercent; - } else { - $val=0; - } + my ($r,$val,$text,$number_to_do)=@_; + if ($number_to_do) { + unless ($val) { + if ($LClastpercent) { + $val=$LClastpercent; + } else { + $val=0; + } + } + if ($val<0) { $val=0; } + if ($val>100) { $val=0; } + $LClastpercent=$val; + unless ($text) { $text=$val.'%'; } + } else { + $val = 'false'; } - if ($val<0) { $val=0; } - if ($val>100) { $val=0; } - $LClastpercent=$val; - unless ($text) { $text=$val.'%'; } $text=&js_ready($text); &r_print($r,< // ENDUPDATE @@ -11426,7 +11483,7 @@ sub modify_html_refs { return; } } - if (open(my $fh,"<$container")) { + if (open(my $fh,'<',$container)) { $content = join('', <$fh>); close($fh); } else { @@ -11491,7 +11548,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 +12065,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 +12111,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 +12166,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 +12651,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 +12664,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 +12753,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 +12764,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 +12865,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 +12876,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 +13169,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 +13187,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 +13210,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() @@ -14048,7 +14160,7 @@ sub build_recipient_list { $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 +14240,7 @@ sub build_recipient_list { } } } - if ($mailing eq 'helpdesk') { + if ($mailing eq 'helpdeskmail') { if ((!@recipients) && ($lastresort ne '')) { push(@recipients,$lastresort); } @@ -14233,6 +14345,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 +14354,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 +14380,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 +14426,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 +14453,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 +14499,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;