# Tool.pm: Tool Web Service package RDA::Web::Tool; # $Id: Tool.pm,v 1.30 2015/05/04 13:38:26 RDA Exp $ # ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Web/Tool.pm,v 1.30 2015/05/04 13:38:26 RDA Exp $ # # Change History # 20140504 MSC Extend the default archive concept. =head1 NAME RDA::Web::Tool - Tool Web Service =head1 SYNOPSIS require RDA::Web::Tool; =head1 DESCRIPTION The objects of the C class are used to access the tools that can be applied on the results from a zipped or expanded report package. The following methods are available: =cut use strict; BEGIN { use Exporter; use RDA::Text qw(get_string); use RDA::Driver::Archive qw($DFT_SET); use RDA::Driver::Sgml qw(encode); use RDA::Driver::Web qw(decode_uri encode_uri fmt_date fmt_mode %MIMES); use RDA::Handle::Block; use RDA::Object qw(decode); use RDA::Object::Collect qw(%SUB_DIRS); use RDA::Object::Index; use RDA::Object::Rda; } # Define the global public variables use vars qw($STRINGS $VERSION @DELETE @ISA); $VERSION = sprintf('%d.%02d', q$Revision: 1.30 $ =~ /(\d+)\.(\d+)/); @DELETE = qw(_ctl); @ISA = qw(Exporter); # Define the global constants my $DOC = q{}; my $EOL = qq{\015\012}; my $NAM = q{tool}; my $DFT_LVL = 8; my $DFT_MAX = 100; my $FLG_CNT = 4; my $FLG_CTX = 2; my $FLG_HIT = 1; my $FLG_LIN = 16; my $FLG_FIL = 32; my $FLG_OFF = 8; # Define the global variables my @tb_lvl = ( 0 => q{0}, 1 => q{1}, 2 => q{2}, 4 => q{4}, 8 => q{8}, 16 => q{16}, 24 => q{24}, 32 => q{32}, ); my @tb_max = ( 1 => q{1}, 2 => q{2}, 5 => q{5}, 10 => q{10}, 20 => q{20}, 50 => q{50}, 100 => q{100}, 200 => q{200}, 500 => q{500}, 1000 => q{1000}, unlimited => q{}, ); my %tb_typ = map {$_ => 1} qw(c l L); # Define the main tabs my @tb_rel = ( [get_string('LnkCat'), '/tool/%s/cat', 'tool_cat'], [get_string('LnkExtract'), '/tool/%s/extract', 'tool_extract'], [get_string('LnkFind'), '/tool/%s/find', 'tool_find'], [get_string('LnkGrep'), '/tool/%s/grep', 'tool_grep'], [get_string('LnkList'), '/tool/%s/list', 'tool_list'], ); my @tb_tab = ( ['rda', 'TabRda', '/rda/%s/', 'rda_menu'], # Text:TabRda ['explorer', 'TabExplorer', '/explorer/%s/', 'exp_dir'], # Text:TabExplorer ['system', 'TabSystem', '/system/%s', 'sys_dir'], # Text:TabSystem ['tool', 'TabTool', '/tool/%s', 'tool_menu'], # Text:TabTool ['package', 'TabPackage', '/package/%s', 'pkg_dir'], # Text:TabPackage ['help', 'TabHelp', '/help/man', 'rda_man'], # Text:TabHelp ); my %tb_act = ( cat => \&_do_cat, extract => \&_do_extract, find => \&_do_find, grep => \&_do_grep, list => \&_do_list, menu => \&_do_menu, ); my %tb_req = ( view => \&_exe_view, ); my %tb_srt = ( n => \&_ls_n, s => \&_ls_s, t => \&_ls_t, rn => \&_ls_rn, rs => \&_ls_rs, rt => \&_ls_rt, ); # Report the package version sub Version { return $VERSION; } =head2 S<$h = RDA::Web::Tool-Enew($req,$agt,$svc)> The object constructor. This method enables you to specify the request, the agent and service hash references as arguments. C is represented by a blessed hash reference. The following special key is used: =over 12 =item S< B<'_agt'> > Reference to the agent object =item S< B<'_css'> > Style definition =item S< B<'_ctl'> > Reference to the archive control object =item S< B<'_ext'> > Extract indicator =item S< B<'_not'> > Page notice definition =item S< B<'_ofh'> > Output file handle =item S< B<'_pre'> > URL prefix =item S< B<'_pth'> > Archive path =item S< B<'_svc'> > Service hash =item S< B<'_web'> > Reference to the Web rendering object =back Internal keys are prefixed by an underscore. The associated data are stored in a control hash containing the following keys: =over 11 =item S< B<'oid'> > Last result set identifier =item S< B<'rel'> > Related link definition =item S< B<'slf'> > Reference to the result set control object =item S< B<'tab'> > Tab definition =back =cut sub new { my ($cls, $req, $agt, $svc) = @_; my ($pth, @att); # Validate the archive if ($req->get_first('private')) { return unless defined($pth = $req->get_first('archive')) || defined($pth = $agt->get_info('zip')) || defined($pth = $agt->get_collector->get_data); return unless (-f $pth || -d $pth) && -r $pth; @att = (_ext => 1, _pth => $pth); } else { @att = (_ctl => $agt->get_registry('WEB.ARC', \&RDA::Driver::Archive::new, 'RDA::Driver::Archive', ## no critic (Call) $agt)); } # Create the service object and return its reference return bless { _agt => $agt, _css => $req->get_first('css'), _not => $req->get_first('notice'), _pre => $req->get_first('prefix', q{}), _svc => $svc, _web => RDA::Driver::Web->new($agt->get_config), @att, }, ref($cls) || $cls; } sub new_dsp { my ($cls, $ofh) = @_; return bless { _ofh => $ofh, }, ref($cls); } =head2 S<$h-Edelete_object> This method deletes the display object. =cut sub delete_object { RDA::Object::dump_caller($_[0], 'Web') if $RDA::Object::DELETE; undef %{$_[0]}; undef $_[0]; return; } =head2 S<$h-Erequest($ofh,$met,$url,$qry)> This method executes a display request. It returns 0 on successful completion. Otherwise, it returns a non-zero value. =cut sub request { my ($slf, $ofh, $met, $req, $qry) = @_; my ($act, $buf, $dat, $det, $nam, $ttl); # Get the archive control object $slf->{'_ctl'} = $slf->{'_agt'}->get_registry('WEB.ARC', \&RDA::Driver::Archive::new, 'RDA::Driver::Archive', ## no critic (Call) $slf->{'_agt'}, $slf->{'_pth'}, 1) unless exists($slf->{'_ctl'}); # Select the package return 10 unless ($dat = ($req =~ s{\A([\dA-Fa-f]{32}(?:-\d+)?)(?:\/|\z)}{}) ? $slf->{'_ctl'}->get_data($NAM, $1) : $slf->{'_ctl'}->get_data($NAM, $DFT_SET)); # Create the index object unless (exists($dat->{'idx'})) { $dat->{'idx'} = RDA::Object::Index->new($slf->{'_agt'}, ctl => $dat->{'slf'})->refresh; $dat->{'pre'} = $slf->{'_pre'}.q{/tool/}.$dat->{'oid'}.q{/view?req=Submit&fil=}; } # Define the available links and tabs on first use unless (exists($dat->{'tab'})) { my ($svc, $tbl, $url, $tid); $dat->{'rel'} = [[[get_string('SctTool'), $tbl = []]]]; foreach my $rec (@tb_rel) { ($ttl, $url, $tid) = @{$rec}; push(@{$tbl}, [$ttl, sprintf($url, $dat->{'oid'}), $tid]) if $slf->{'_ext'} || $tid ne 'tool_extract'; } $dat->{'tab'} = $tbl = []; $svc = $slf->{'_svc'}; foreach my $rec (@tb_tab) { ($nam, $ttl, $url, $tid) = @{$rec}; push(@{$tbl}, [get_string($ttl), sprintf($url, $dat->{'oid'}), $tid]) if exists($svc->{$nam}); } } # Validate the request ($act, $req) = split(/\//, $req, 2); $act = 'menu' unless $act && $dat->{'idx'}; return &{$tb_req{$act}}($ofh, $slf, $dat, decode_uri($req), $qry) if exists($tb_req{$act}); return 1 unless exists($tb_act{$act}); ($nam, $ttl, $det) = eval {&{$tb_act{$act}}($slf, $dat, decode_uri($req), $qry)}; return [$slf->{'_agt'}->add_error($@)->pop_errors(1)] if $@; return 3 unless defined($det); # Generate the page $buf = q{HTTP/1.0 200 OK}.$EOL .q{Content-Type: text/html; charset=UTF-8}.$EOL .q{Cache-Control: no-cache}.$EOL .q{Expires: }.gmtime().$EOL.$EOL; syswrite($ofh, $buf, length($buf)); eval { $slf->{'_web'}->render($ofh, { css => $slf->{'_css'}, det => $det, nam => $nam, not => $slf->{'_not'}, pre => $slf->{'_pre'}, rel => $dat->{'rel'}, tab => $dat->{'tab'}, ttl => $ttl, }); }; syswrite($ofh, $@, length($@)) if $@; # Indicate a successful completion return 0; } # Treat a cat request sub _do_cat { my ($slf, $dat, $req, $qry) = @_; return ('tool_cat', get_string('TtlCat'), [[\&_exe_cat, $slf, $dat, $qry]]); } sub _ask_cat { my ($ofh, $qry, @arg) = @_; my ($buf, $max); $max = @arg; $max = ($max < 3) ? 3 : $max + 1; # Generate the request form $buf = q{

}.get_string('ReqCat').qq{

\n} .qq{\n}; _write($ofh, $buf); return; } sub _exe_cat { my ($ofh, $slf, $dat, $qry) = @_; my ($all, $cnt, $ifh, $lin, $max, $res, @arg, %qry); # Generate a request form when no request is submitted return _ask_cat($ofh, {}) unless _parse_query(\%qry, $qry) eq get_string('FormExe'); # Extract the options $all = $qry{'all'} ? 1 : 0; $max = $qry{'max'} if exists($qry{'max'}) && $qry{'max'} =~ m/^\d+$/; # Extract the files foreach my $key (sort {substr($a, 3) <=> substr($b, 3)} grep {m/^arg\d+$/} keys(%qry)) { push(@arg, $qry{$key}); } _ask_cat($ofh, \%qry, @arg); # Cat the requested file _write($ofh, q{

}.get_string('ResCat').qq{

\n}); eval { $dat->{'idx'}->set_info('all', $all); foreach my $fil (@arg) { next unless ($ifh = $dat->{'idx'}->get_file($fil)); binmode($ifh); while ( !$ifh->eof) { $lin = $ifh->getline; _write($ofh,q{

}) unless $cnt++ ;
        if (defined($max) && --$max < 0)
        { _write($ofh,qq{...
\n});
          last;
        }
        _write($ofh, encode($lin));
      }
    }
    _write($ofh, $cnt ? q{

} : get_string('ResCatEmpty')); }; return; } # Treat an extract request sub _do_extract { my ($slf, $dat, $req, $qry) = @_; return ('tool_extract', get_string('TtlExtract'), [[\&_exe_extract, $slf, $dat, $qry]]); } sub _ask_extract { my ($ofh, $qry, @arg) = @_; my ($buf, $max); $max = @arg; $max = ($max < 3) ? 3 : $max + 1; # Generate the request form $buf = q{

}.get_string('ReqExtract').qq{

\n} .qq{\n}; _write($ofh, $buf); return; } sub _exe_extract { my ($ofh, $slf, $dat, $qry) = @_; my ($all, $dir, $dsp, $res, $vrb, @arg, %qry); # Generate a request form when no request is submitted return _ask_extract($ofh, {}) unless _parse_query(\%qry, $qry) eq get_string('FormExe'); # Extract the options $all = $qry{'all'} ? 1 : 0; $dir = $qry{'d'} if exists($qry{'d'}); $vrb = exists($qry{'v'}); # Extract the arguments foreach my $key (sort {substr($a, 3) <=> substr($b, 3)} grep {m/^arg\d+$/} keys(%qry)) { push(@arg, $qry{$key}); } _ask_extract($ofh, \%qry, @arg); # Extract the requested elements _write($ofh, q{

}.get_string('ResExtract').qq{

\n}); $dsp = $dat->{'idx'}->set_info('dsp', $slf->new_dsp($ofh)) if $vrb; eval { $dat->{'idx'}->set_info('all', $all); $res = $dat->{'idx'}->extract($dir, @arg); _write($ofh, q{
}.get_string('ResExtractCnt', $res).q{
}); }; $dat->{'idx'}->set_info('dsp', $dsp) if $vrb; return; } # Treat a find request sub _do_find { my ($slf, $dat, $req, $qry) = @_; return ('tool_find', get_string('TtlFind'), [[\&_exe_find, $slf, $dat, $qry]]); } sub _ask_find { my ($ofh, $qry, @arg) = @_; my ($buf, $max); $max = @arg; $max = ($max < 6) ? 6 : $max + 1; # Generate the request form $buf = q{

}.get_string('ReqFind').qq{

\n} .qq{\n}; _write($ofh, $buf); return; } sub _exe_find { my ($ofh, $slf, $dat, $qry) = @_; my ($all, $lnk, $lvl, $max, $pat, $pre, @arg, %qry); # Generate a request form when no request is submitted return _ask_find($ofh, {}) unless _parse_query(\%qry, $qry) eq get_string('FormExe'); # Extract the options $all = $qry{'all'} ? 1 : 0; $lvl = $qry{'lvl'} if exists($qry{'lvl'}) && $qry{'lvl'} =~ m/^\d+$/; $max = $qry{'max'} if exists($qry{'max'}) && $qry{'max'} =~ m/^\d+$/; $pat = $qry{'pat'} if exists($qry{'pat'}); # Extract the directories foreach my $key (sort {substr($a, 3) <=> substr($b, 3)} grep {m/^arg\d+$/} keys(%qry)) { push(@arg, $qry{$key}); } _ask_find($ofh, \%qry, @arg); # Display the matching files _write($ofh, q{

}.get_string('ResFind').qq{

\n}); eval { $dat->{'idx'}->set_info('all', $all); $pre = $dat->{'pre'}; foreach my $hit ($dat->{'idx'}->find($pat, $lvl, @arg)) { if (defined($max) && --$max < 0) { _write($ofh, qq{...
\n}); last; } $lnk = $pre.encode_uri($hit); $hit =~ s/[\000-\037]/?/g; _write($ofh, qq{}.encode($hit).qq{
\n}); } }; return; } # Treat a grep request sub _do_grep { my ($slf, $dat, $req, $qry) = @_; return ('tool_grep', get_string('TtlGrep'), [[\&_exe_grep, $slf, $dat, $qry]]); } sub _ask_grep { my ($ofh, $qry, @arg) = @_; my ($buf, $max); $max = @arg; $max = ($max < 8) ? 8 : $max + 1; # Generate the request form $buf = q{

}.get_string('ReqGrep').qq{

\n} .qq{

\n} .q{\n\n}; $buf .= _add_check('all', get_string('FormGrepAll'), $qry->{'all'}); $buf .= _add_filler(8); $buf .= _add_select('lvl', get_string('FormGrepLvl'), _get_best($qry->{'lvl'}, 0, @tb_lvl), @tb_lvl); $buf .= _add_filler(7); $buf .= _add_text('pat', get_string('FormGrepPat'), 24, $qry->{'pat'}); $buf .= _add_filler($max); $buf .= _add_array('arg', get_string('FormGrepArg'), $max, 32, @arg); $buf .= qq{\n}; $buf .= _add_check('i', get_string('FormGrepLi'), $qry->{'i'}); $buf .= q{\n}; $buf .= _add_radio('typ', q{}, get_string('FormGrepTyp'), !exists($qry->{'typ'}) || !exists($tb_typ{$qry->{'typ'}})); $buf .= qq{\n}; $buf .= _add_check('j', get_string('FormGrepLj'), $qry->{'j'}); $buf .= _add_text('B', get_string('FormGrepUB'), 1, $qry->{'B'} || 0); $buf .= _add_radio('typ', q{c}, get_string('FormGrepLc'), exists($qry->{'typ'}) && $qry->{'typ'} eq 'c'); $buf .= qq{\n}; $buf .= _add_check('v', get_string('FormGrepLv'), $qry->{'v'}); $buf .= _add_text('A', get_string('FormGrepUA'), 1, $qry->{'A'} || 0); $buf .= _add_radio('typ', q{l}, get_string('FormGrepLl'), exists($qry->{'typ'}) && $qry->{'typ'} eq 'l'); $buf .= qq{\n}; $buf .= _add_text('C', get_string('FormGrepUC'), 1, $qry->{'C'} || 0); $buf .= _add_radio('typ', q{L}, get_string('FormGrepUL'), exists($qry->{'typ'}) && $qry->{'typ'} eq 'L'); $buf .= qq{\n}; $buf .= _add_check('H', get_string('FormGrepUH'), $qry->{'H'}); $buf .= qq{\n}; $buf .= _add_check('n', get_string('FormGrepLn'), $qry->{'n'}); $buf .= _add_text('F', get_string('FormGrepUF'), 1, $qry->{'F'}); $buf .= qq{\n}; $buf .= _add_check('b', get_string('FormGrepLb'), $qry->{'b'}); $buf .= _add_select('max', get_string('FormMax'), _get_best($qry->{'max'}, $DFT_MAX, @tb_max), @tb_max); for (8..$max) { $buf .= qq{\n}; } $buf .= q{

}.get_string('FormGrepCtl').qq{

}; $buf .= _add_button('req', get_string('FormExe')); $buf .= _add_button('req', get_string('FormClr')); $buf .= qq{

\n}; _write($ofh, $buf); return; } sub _exe_grep ## no critic (Complex) { my ($ofh, $slf, $dat, $qry) = @_; my ($all, $cmd, $col, $ctx, $flg, $lvl, $max, $pat, $pre, $typ, $val, @arg, @hit, @res, %qry); # Generate a request form when no request is submitted return _ask_grep($ofh, {}) unless _parse_query(\%qry, $qry) eq get_string('FormExe'); # Extract the options ## no critic (Bit) $all = $qry{'all'} ? 1 : 0; $lvl = $qry{'lvl'} ? 20 : 0; $max = $qry{'max'} if exists($qry{'max'}) && $qry{'max'} =~ m/^\d+$/; $pat = $qry{'pat'} if exists($qry{'pat'}); $cmd = q{e}; $typ = $FLG_HIT; $flg = !(exists($qry{'h'}) || exists($qry{'H'})); foreach my $key (qw(b f h i j n v H)) { $cmd .= $key if exists($qry{$key}); } foreach my $key (qw(A B C F)) { next unless exists($qry{$key}) && $qry{$key} =~ m/^([1-9]\d*)$/; $cmd .= "$key$1"; $typ |= $FLG_CTX unless $key eq 'F'; } $typ |= $FLG_LIN if exists($qry{'n'}); $typ |= $FLG_OFF if exists($qry{'b'}); if (exists($qry{'typ'})) { $cmd .= $qry{'typ'} if exists($tb_typ{$qry{'typ'}}); if ($qry{'typ'} eq 'l' || $qry{'typ'} eq 'L') { $typ = $FLG_FIL; } else { $typ = $FLG_CNT if $qry{'typ'} eq 'c'; $typ |= $FLG_FIL if exists($qry{'H'}); } } else { $typ |= $FLG_FIL if exists($qry{'H'}); } # Extract the directories foreach my $key (sort {substr($a, 3) <=> substr($b, 3)} grep {m/^arg\d+$/} keys(%qry)) { push(@arg, $qry{$key}); $typ |= $FLG_FIL if $flg && $qry{$key} =~ m/[\*\?\[\]]/; } $typ |= $FLG_FIL if $flg && ($lvl > 0 || (scalar @arg) > 1); _ask_grep($ofh, \%qry, @arg); # Open the result table $col = push(@res, q{}.get_string('ResGrepFil').q{}) if $typ & $FLG_FIL; $col = push(@res, q{}.get_string('ResGrepLin').q{}) if $typ & $FLG_LIN; $col = push(@res, q{}.get_string('ResGrepOff').q{}) if $typ & $FLG_OFF; $col = push(@res, q{}.get_string('ResGrepCnt').q{}) if $typ & $FLG_CNT; $col = push(@res, q{}.get_string('ResGrepCtx').q{}) if $typ & $FLG_CTX; $col = push(@res, q{}.get_string('ResGrepHit').q{}) if $typ & $FLG_HIT; --$col if $typ & $FLG_CTX; _write($ofh, q{

}.get_string('ResGrep').qq{

\n\n}.join(q{}, @res).qq{\n}); # Treat all files eval { $dat->{'idx'}->set_info('all', $all); $pre = $dat->{'pre'}; foreach my $hit ($dat->{'idx'}->grep($cmd, $lvl, $pat, @arg)) { if (defined($max) && --$max < 0) { _write($ofh, qq{...\n}); last; } if ($hit =~ s/\|\|/\|/g) { $ctx = '*'; $hit =~ s/^\|//; } else { $ctx = ''; } (@hit, @res) = split(/\|/, $hit, $col); unshift(@hit, '') while (scalar @hit) < $col; if ($typ & $FLG_FIL) { $val = shift(@hit); $val = decode($1) if $val =~ m/^"(.*)"$/; push(@res, q{} .encode($val).q{}); } push(@res, q{}.shift(@hit).q{}) if $typ & $FLG_LIN; push(@res, q{}.shift(@hit).q{}) if $typ & $FLG_OFF; push(@res, q{}.$ctx.q{}) if $typ & $FLG_CTX; push(@res, q{}.shift(@hit).q{}) if $typ & $FLG_CNT; if ($typ & $FLG_HIT) { $val = shift(@hit); $val = q{

}.encode($val).q{

} unless $val eq q{}; push(@res, qq{$val}); } _write($ofh, q{}.join(q{}, @res).qq{\n}); } }; # Close the result table _write($ofh, qq{\n}); return; } # Treat a list request sub _do_list { my ($slf, $dat, $req, $qry) = @_; return ('tool_list', get_string('TtlList'), [[\&_exe_list, $slf, $dat, $qry]]); } sub _ask_list { my ($ofh, $qry, @arg) = @_; my ($buf, $max); $max = @arg; $max = ($max < 6) ? 6 : $max + 1; # Generate the request form $buf = q{

}.get_string('ReqList').qq{

\n} .qq{

\n} .q{\n\n}; $buf .= _add_check('all', get_string('FormListAll'), $qry->{'all'}); $buf .= _add_filler(2); $buf .= _add_select('lvl', get_string('FormListLvl'), _get_best($qry->{'lvl'}, 24, @tb_lvl), @tb_lvl); $buf .= _add_filler($max); $buf .= _add_array('arg', get_string('FormListArg'), $max, 32, @arg); $buf .= qq{\n}; $buf .= _add_check('i', get_string('FormListInd'), $qry->{'i'}); $buf .= _add_select('max', get_string('FormMax'), _get_best($qry->{'max'}, $DFT_MAX, @tb_max), @tb_max); $buf .= qq{\n}; $buf .= _add_radio('dsp', q{m}, get_string('FormListMti'), !exists($qry->{'dsp'}) || $qry->{'dsp'} eq 'm'); $buf .= _add_radio('typ', q{n}, get_string('FormListSbn'), !exists($qry->{'typ'}) || $qry->{'typ'} eq 'n'); $buf .= qq{\n}; $buf .= _add_radio('dsp', q{c}, get_string('FormListCti'), exists($qry->{'dsp'}) && $qry->{'dsp'} eq 'c'); $buf .= _add_radio('typ', q{t}, get_string('FormListSbt'), exists($qry->{'typ'}) && $qry->{'typ'} eq 't'); $buf .= qq{\n}; $buf .= _add_radio('dsp', q{u}, get_string('FormListAti'), exists($qry->{'dsp'}) && $qry->{'dsp'} eq 'u'); $buf .= _add_radio('typ', q{s}, get_string('FormListSbs'), exists($qry->{'typ'}) && $qry->{'typ'} eq 's'); $buf .= qq{\n}; $buf .= qq{\n}; $buf .= _add_check('r', get_string('FormListRev'), $qry->{'r'}); for (7..$max) { $buf .= qq{\n}; } $buf .= q{

}; $buf .= _add_button('req', get_string('FormExe')); $buf .= _add_button('req', get_string('FormClr')); $buf .= qq{

\n}; _write($ofh, $buf); return; } sub _exe_list ## no critic (Complex) { my ($ofh, $slf, $dat, $qry) = @_; my ($all, $buf, $cnt, $fct, $ino, $lnk, $lvl, $max, $nam, $tim, @arg, @max, %qry); # Generate a request form when no request is submitted return _ask_list($ofh, {}) unless _parse_query(\%qry, $qry) eq get_string('FormExe'); # Extract the options $all = $qry{'all'} ? 1 : 0; $lvl = $qry{'lvl'} if exists($qry{'lvl'}) && $qry{'lvl'} =~ m/^\d+$/; $max = $qry{'max'} if exists($qry{'max'}) && $qry{'max'} =~ m/^\d+$/; # Determine the display options $ino = $qry{'i'}; $tim = !exists($qry{'dsp'}) ? 10 : ($qry{'dsp'} eq 'u') ? 9 : ($qry{'dsp'} eq 'c') ? 11 : 10; # Determine the sort criteria $fct = $qry{'typ'} ? $qry{'typ'} : 'n'; $fct = $tb_srt{$qry{'r'} ? "r$fct" : $fct}; # Extract the directories and files foreach my $key (sort {substr($a, 3) <=> substr($b, 3)} grep {m/^arg\d+$/} keys(%qry)) { push(@arg, $qry{$key}); } _ask_list($ofh, \%qry, @arg); # List the matching files _write($ofh, q{

}.get_string('ResList').qq{

\n}); eval { $dat->{'idx'}->set_info('all', $all); LOOP: foreach my $hit ($dat->{'idx'}->ls($lvl, @arg)) { _write($ofh, qq{

\n}) unless $cnt++;
      if (defined($max) && --$max < 0)
      { _write($ofh, qq{...\n});
        last LOOP;
      }
      _write($ofh, shift(@{$hit}).qq{\n});

      # Determine the column sizes
      @max = (0, 1, -1, -1, 0);
      foreach my $rec (@{$hit})
      { $max[0] = $rec->[2] if $rec->[2] > $max[0];
        $max[1] = $rec->[4] if $rec->[4] > $max[1];
        $max[2] = $rec->[5] if $rec->[5] > $max[2];
        $max[3] = $rec->[6] if $rec->[6] > $max[3];
        $max[4] = $rec->[8] if $rec->[8] > $max[4];
      }
      $max[0] = length($max[0]) if $ino;
      $max[1] = length(sprintf(' %d', $max[1]));
      $max[2] = length(sprintf(' %d', $max[2]));
      $max[3] = length(sprintf(' %d', $max[3]));
      $max[4] = length(sprintf(' %d', $max[4]));

      # Display the file information
      foreach my $rec (&$fct($hit, $tim))
      { if (defined($max) && --$max < 0)
        { _write($ofh, qq{...\n});
          last LOOP;
        }
        $nam = $rec->[0];
        if (defined($lnk = $rec->[14]))
        { $lnk = RDA::Object::decode($1) if $lnk =~ m/^"([^"]*)"$/;
          $nam .= ' -> '.$lnk;
        }
        $nam =~ s/[\000-\037]/?/g;
        $buf = q{};
        $buf .= sprintf('%*s ', $max[0], $rec->[2]) if $ino;
        $buf .= sprintf('%s%*d%*d%*d%*d%18s %s', fmt_mode($rec->[3]),
          $max[1], $rec->[4],
          $max[2], $rec->[5],
          $max[3], $rec->[6],
          $max[4], $rec->[8],
          fmt_date($rec->[$tim]),
          $nam);
        _write($ofh, qq{$buf\n});
      }
      _write($ofh, qq{\n});
      --$max if defined($max);
    }
    _write($ofh, $cnt ? qq{

\n} : get_string('ResListNone')); }; return; } # Treat a menu request sub _do_menu { my ($slf, $dat) = @_; return ('tool_menu', get_string('TtlTools'), [[\&_write, $dat->{'idx'} ? q{
} : get_string('NoFiles')]]); } # Treat a view request sub _exe_view { my ($ofh, $slf, $dat, $req, $qry) = @_; my ($buf, $fil, $hdr, $ifh, $lgt, $ret, $suf, $typ, %qry); # Validate the request _parse_query(\%qry, $qry); return 1 unless exists($qry{'fil'}); $fil = $qry{'fil'}; # Execute the request $ret = 2; eval { $dat->{'idx'}->set_info('all', 1); if ($ifh = $dat->{'idx'}->get_file($fil)) { binmode($ifh); # Determine the MIME type $lgt = 0; if ($fil =~ m/\.([a-z][a-z0-9]*)$/i && exists($MIMES{$suf = lc($1)})) { $typ = $MIMES{$suf}; } else { $lgt = $ifh->sysread($buf, 4096); $typ = ( $buf =~ m/[^\b\f\n\r\t\040-\176]/) ? 'application/octet-stream' : 'text/plain'; } # Generate the page $hdr = q{HTTP/1.0 200 OK}.$EOL .qq{Content-Type: $typ; charset=UTF-8}.$EOL .q{Cache-Control: no-cache}.$EOL .q{Expires: }.gmtime().$EOL.$EOL; syswrite($ofh, $hdr, length($hdr)); syswrite($ofh, $buf, $lgt) if $lgt; while ($lgt = $ifh->sysread($buf, 4096)) { syswrite($ofh, $buf, $lgt); } $ifh->close; $ret = 0; } }; # Indicate completion status return $ret; } # --- Internal routines ------------------------------------------------------- # Add an array of text boxes sub _add_array { my ($nam, $txt, $max, $siz, @arg) = @_; my ($buf, $lbl, $val); $lbl = $txt; for my $off (1..$max) { $lbl = qq{$lbl} } $buf = qq{$lbl\n}; for my $off (1..$max) { $val = $arg[$off - 1]; $val = defined($val) ? encode($val) : q{}; $buf .= qq{
}; } return $buf.qq{\n}; } # Add a submit button sub _add_button { my ($nam, $txt) = @_; return qq{\n}; } # Add a check box sub _add_check { my ($nam, $txt, $flg) = @_; my ($uid); $uid = $nam; $uid =~ s/([A-Z])/u\L$1\E/g; return qq{$txt\n}; } # Add a filler sub _add_filler { my ($row) = @_; return qq{ \n}; } sub _add_radio { my ($nam, $val, $txt, $flg) = @_; my ($uid); $uid = $nam.$val; $uid =~ s/([A-Z])/u\L$1\E/g; return q{} .qq{$txt\n}; } # Generate a selection sub _add_select { my ($nam, $txt, $sel, @arg) = @_; my ($buf, $dsc, $uid, $val); $uid = $nam; $uid =~ s/([A-Z])/u\L$1\E/g; $buf = qq{$txt\n} .qq{\n}; } # Generate a selection sub _add_text { my ($nam, $txt, $siz, $cur) = @_; my ($uid); $uid = $nam; $uid =~ s/([A-Z])/u\L$1\E/g; $cur = defined($cur) ? encode($cur) : q{}; return qq{$txt\n} .qq{\n}; } # Identify the current selection sub _get_best { my ($cur, $dft, @arg) = @_; my ($dsc, $prv, $val); $cur = $dft unless defined($cur); while (($dsc, $val) = splice(@arg, 0, 2)) { return $dsc if $val =~ m/^\d+$/ && $cur <= $val; $prv = $dsc; } return $prv; } # Parse the query string sub _parse_query { my ($hsh, $qry) = @_; my ($val); if (defined($qry)) { foreach my $arg (split(/\&/, $qry)) { next unless $arg =~ m/^(\w+)=(.*)$/; $hsh->{$1} = $val if length($val = decode_uri($2)); } } return exists($hsh->{'req'}) ? $hsh->{'req'} : q{?}; } # Write the buffer sub _write { my ($ofh, $buf) = @_; return syswrite($ofh, $buf, length($buf)); } # Define the sort functions sub _ls_n { my ($tbl) = @_; return (sort {$a->[0] cmp $b->[0]} @{$tbl}); } ## no critic (Reverse) sub _ls_s { my ($tbl) = @_; return (sort {$b->[8] <=> $a->[8] || $a->[0] cmp $b->[0]} @{$tbl}); } sub _ls_t { my ($tbl, $key) = @_; return (sort {$b->[$key] <=> $a->[$key] || $a->[0] cmp $b->[0]} @{$tbl}); } sub _ls_rn { my ($tbl) = @_; return (sort {$b->[0] cmp $a->[0]} @{$tbl}); } sub _ls_rs { my ($tbl) = @_; return (sort {$a->[8] <=> $b->[8] || $b->[0] cmp $a->[0]} @{$tbl}); } sub _ls_rt { my ($tbl, $key) = @_; return (sort {$a->[$key] <=> $b->[$key] || $b->[0] cmp $a->[0]} @{$tbl}); } # --- Emulate a display object ------------------------------------------------ sub dsp_line { my ($slf, $txt) = @_; _write($slf->{'_ofh'}, qq{$txt
\n}) if $slf->{'_ofh'}; return; } 1; __END__ =head1 SEE ALSO L, L, L, L, L, L, L, L, L, L, L, L, L =head1 COPYRIGHT NOTICE Copyright (c) 2002, 2016, Oracle and/or its affiliates. All rights reserved. =head1 TRADEMARK NOTICE Oracle and Java are registered trademarks of Oracle and/or its affiliates. Other names may be trademarks of their respective owners. =cut