# Explorer.pm: Oracle Explorer Web Service package RDA::Web::Explorer; # $Id: Explorer.pm,v 1.20 2015/05/08 18:23:43 RDA Exp $ # ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Web/Explorer.pm,v 1.20 2015/05/08 18:23:43 RDA Exp $ # # Change History # 20150508 MSC Improve the documentation. =head1 NAME RDA::Web::Explorer - Oracle Explorer Web Service =head1 SYNOPSIS require RDA::Web::Explorer; =head1 DESCRIPTION The objects of the C class are used to display Oracle Explorer 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::Rda; } # Define the global public variables use vars qw($STRINGS $VERSION @DELETE @ISA); $VERSION = sprintf('%d.%02d', q$Revision: 1.20 $ =~ /(\d+)\.(\d+)/); @DELETE = qw(_ctl); @ISA = qw(Exporter); # Define the global constants my $DOC = q{}; my $EOL = qq{\015\012}; my $NAM = q{explorer}; # Define the main tabs 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 ); # Define the global private variables my %tb_dsp = ( f => \&_dsp_file, C => \&_dsp_cfm, D => \&_dsp_page, F => \&_dsp_file, L => \&_dsp_link, N => \&_dsp_page, U => \&_dsp_page, ); my %tb_fct = ( D => \&_gen_dir, N => \&_gen_none, U => \&_gen_unknown, ); # Report the package version sub Version { return $VERSION; } =head2 S<$h = RDA::Web::Explorer-Enew($req,$agt)> The object constructor. This method enables you to specify the request and the agent 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<'_not'> > Page notice definition =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<'max'> > Maximum customer file management level =item S< B<'oid'> > Result set identifier =item S< B<'res'> > Oracle Explorer result tree =item S< B<'slf'> > Reference to the result set control object =item S< B<'sta'> > File status information hash =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 = (_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; } =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)> 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) = @_; my ($cur, $dat, $ifh, $typ); # 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)); # Define the available tabs on first use unless (exists($dat->{'tab'})) { my ($nam, $svc, $tab, $ttl, $tid, $url); $dat->{'tab'} = $tab = []; $svc = $slf->{'_svc'}; foreach my $rec (@tb_tab) { ($nam, $ttl, $url, $tid) = @{$rec}; push(@{$tab}, [get_string($ttl), sprintf($url, $dat->{'oid'}), $tid]) if exists($svc->{$nam}); } } # Analyze the archive on first use unless (exists($dat->{'sta'})) { $dat->{'max'} = 3 unless exists($dat->{'max'}); $dat->{'sta'} = {}; # Build the report tree foreach my $nam ($dat->{'slf'}->get_files('E')) { _extract_reports($dat, $ifh) if defined($ifh = $dat->{'slf'}->find_handle($nam)); $nam =~ s/_E\.fil$/_D.fil/i; _extract_stat($dat, $ifh) if defined($ifh = $dat->{'slf'}->find_handle($nam)); } _extract_files($dat); } # Validate the request $req = decode_uri($req); return 1 if $req =~ m{(^|\/)\.}; $typ = ($req =~ s{^cfm/}{}) ? 'C' : !exists($dat->{'res'}) ? 'N' : defined($cur = _get_node($dat, $req)) ? $cur->[0] : 'U'; return &{$tb_dsp{$typ}}($slf, $ofh, $dat, $cur, $req, $typ); } # --- Page generation routines ------------------------------------------------ # Treat a CFM request sub _dsp_cfm { my ($slf, $ofh, $dat, $cur, $req) = @_; my ($buf); # Force rediscovery if ($req =~ m/^(\d)$/) { $dat->{'max'} = $1; delete($dat->{'res'}); delete($dat->{'sta'}); } # Redirect to the new result set $buf = q{HTTP/1.0 302 OK}.$EOL .q{Location: }.encode_uri($slf->{'_pre'}, 'explorer', $dat->{'oid'}).$EOL .q{Cache-Control: no-cache}.$EOL .q{Expires: }.gmtime().$EOL.$EOL; syswrite($ofh, $buf, length($buf)); # Indicate a successful completion return 0; } # Treat a report sub _dsp_file { my ($slf, $ofh, $dat, $cur, $req) = @_; my ($bfh, $buf, $hdr, $ifh, $lgt, $suf, $typ); # Generate the page foreach my $blk (@{$cur->[1]}) { if (ref($blk)) { next unless $blk->[1]; $ifh = $dat->{'slf'}->find_handle($SUB_DIRS{$blk->[2]}.q{/}.$blk->[3]); return 4 unless defined($ifh); binmode($ifh); return 5 unless ($bfh = RDA::Handle::Block->new($ifh, $blk->[0], $blk->[1])); } else { $ifh = undef; $bfh = $dat->{'slf'}->find_handle($blk, 1); return 4 unless defined($bfh); binmode($bfh); } while ($lgt = $bfh->sysread($buf, 8192)) { # Display the header on the first iteration unless ($hdr) { # Determine the MIME type $typ = ($req =~ m/\.([a-z][a-z0-9]*)$/i && exists($MIMES{$suf = lc($1)})) ? $MIMES{$suf} : ($buf =~ m/[^\b\f\n\r\t\040-\176]/) ? 'application/octet-stream' : 'text/plain'; # Display the HTTP header $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)); } # Display the data syswrite($ofh, $buf, $lgt); } $bfh->close; $ifh->close if $ifh; } # Treat empty page unless ($hdr) { $hdr = q{HTTP/1.0 200 OK}.$EOL .q{Content-Type: text/plain; charset=UTF-8}.$EOL .q{Cache-Control: no-cache}.$EOL .q{Expires: }.gmtime().$EOL.$EOL; syswrite($ofh, $hdr, length($hdr)); } # Indicate a successful completion return 0; } # Treat a link sub _dsp_link { my ($slf, $ofh, $dat, $cur) = @_; my ($buf); # Redirect $buf = q{HTTP/1.0 302 OK}.$EOL .q{Location: } .encode_uri($slf->{'_pre'}, 'explorer', $dat->{'oid'}, $cur->[2]).$EOL .q{Cache-Control: no-cache}.$EOL .q{Expires: }.gmtime().$EOL.$EOL; syswrite($ofh, $buf, length($buf)); # Indicate a successful completion return 0; } # Treat a page sub _dsp_page { my ($slf, $ofh, $dat, $cur, $req, $typ) = @_; my ($buf, $det, $nam, $rel, $ttl); ($nam, $ttl, $det, $rel) = eval {&{$tb_fct{$typ}}($slf, $dat, $req, $cur)}; return [$slf->{'_agt'}->add_error($@)->pop_errors(1)] if $@; return 4 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 => $rel, tab => $dat->{'tab'}, ttl => $ttl, }); }; syswrite($ofh, $@, length($@)) if $@; # Indicate a successful completion return 0; } # Generate a directory report sub _gen_dir { my ($slf, $dat, $req, $cur) = @_; my ($bas, $buf, $dir, $lnk, $oid, $rec, $rel, $sta, $ttl, $typ, @dir, @rel, %dir); # Generate the report body $oid = $dat->{'oid'}; $bas = join(q{/}, 'explorer', $oid, $req); $bas =~ s{\/+$}{}; $dir = join(q{/}, @{$cur->[2]}); $ttl = get_string(length($dir) ? 'TtlSubDir' : 'TtlTopDir', $dir); $buf = qq{

$ttl

\n\n} .q{} .q{} .q{} .q{} .q{} .q{} .qq{\n}; foreach my $key (sort keys(%{$cur->[1]})) { $rec = $cur->[1]->{$key}; $typ = $rec->[0]; $buf .= q{}; if ($typ eq 'D') { $buf .= q{} .q{} .q{} .q{} .q{} .q{} .qq{\n}; } elsif ($typ eq 'L') { $buf .= q{} .q{} .q{} .q{} .q{} .q{} .qq{\n}; } else { $lnk = q{}; if (defined($sta = _get_stat($dat, $rec->[2], \$lnk))) { $buf .= q{} .q{} .q{} .q{}; } elsif ($typ eq 'f') { $buf .= q{} .q{} .q{} .q{}; } else { $buf .= q{} .q{} .q{} .q{}; } $buf .= q{} .q{} .qq{\n}; $dir{RDA::Object::Rda->dirname($lnk)} = 1 if defined($lnk = $rec->[2]); } } $buf .= qq{

Mode	UID	GID	Last Modification	Size	Name
`d`					}.encode($key).q{
`l`					}.encode($key).q{ → } .encode($rec->[1]).q{
`}.fmt_mode($sta->[2]) .q{`	}.$sta->[4].q{	}.$sta->[5].q{	}.fmt_date($sta->[9]).q{	`-`	} .$dat->{'slf'}->get_uid(@{$rec->[1]}, 1, q{}).q{	} .$dat->{'slf'}->get_gid(@{$rec->[1]}, 1, q{}).q{	} .fmt_date($dat->{'slf'}->get_time(@{$rec->[1]}, 1)).q{	`-`	}._get_size($dat, $rec->[1]) .q{	}.encode($key).qq{$lnk

\n}; # Generate related links push(@rel, [[get_string('SctSystem'), [map {[encode($_), join(q{/}, '/system', $oid, 'root', RDA::Object::Rda->split_dir($_)), q{sys}]} sort @dir ]]]) if $slf->{'_svc'}->{'system'} && (@dir = keys(%dir)); push(@rel, [[get_string('SctCfm'), [map {[encode(get_string('Level', $_)), qq{/explorer/$oid/cfm/$_}, qq{cfm_$_}]} grep {$_ != $dat->{'max'}} qw(0 1 2 3)]]]) if $bas eq qq{explorer/$oid}; $rel = [@rel] if @rel; # Return the report descriptor return (join(q{_}, 'exp_dir', @{$cur->[2]}), $ttl, [[\&_write, $buf]], $rel); } # Indicate the absence of Oracle Explorer results sub _gen_none { my ($slf, $dat, $req) = @_; my ($oid, $rel); # Generate related links $rel = [[[get_string('SctCfm'), [map {[encode(get_string('Level', $_)), encode_uri($slf->{'_pre'}, 'explorer', $dat->{'oid'}, 'cfm', $_), qq{cfm_$_}]} grep {$_ != $dat->{'max'}} qw(0 1 2 3)]]]]; # Return the report descriptor return ('exp_none', $req, [[\&_write, q{
}.get_string('None')]], $rel); } # Indicate a missing element sub _gen_unknown { my ($slf, $dat, $req) = @_; # Return the report descriptor return ('exp_unknown', $req, [[\&_write, q{
}.get_string('Unknown', $req)]]); } # Write the buffer sub _write { my ($ofh, $buf) = @_; return syswrite($ofh, $buf, length($buf)); } # --- Oracle Explorer report management routines ------------------------------ # Add a directory in the result tree sub _add_dir { my ($dat, $nam) = @_; my ($cur); $cur = $dat->{'res'}; $nam = [split(/\//, $nam)] unless ref($nam) eq 'ARRAY'; foreach my $sub (@{$nam}) { next unless length($sub); $cur->[1]->{$sub} = ['D', {q{..}, $cur}, [@{$cur->[2]}, $sub]] unless exists($cur->[1]->{$sub}); $cur = $cur->[1]->{$sub}; } return $cur; } # Add a file in the result tree sub _add_file { my ($dat, $nam) = @_; my ($cur, $fil); $nam = [split(/\//, $nam)] unless ref($nam) eq 'ARRAY'; $fil = pop(@{$nam}); $cur = _add_dir($dat, $nam)->[1]; $cur->{$fil} = ['F', []] unless exists($cur->{$fil}); return $cur->{$fil}; } # Add a link in the result tree sub _add_link { my ($dat, $nam, $lnk) = @_; my ($cur, $fil); $nam = [split(/\//, $nam)] unless ref($nam) eq 'ARRAY'; $fil = pop(@{$nam}); $cur = _add_dir($dat, $nam); return $cur->[1]->{$fil} = ['L', $lnk, join(q{/}, @{$cur->[2]}, $lnk)]; } # Extract all Oracle Explorer files sub _extract_files { my ($dat) = @_; my ($cur, $nam, @fil); if (@fil = $dat->{'slf'}->get_files('XPL')) { $dat->{'res'} = ['D', {}, []] unless exists($dat->{'res'}); foreach my $rec (@fil) { next unless $rec->[0] =~ m/^([\/\+\-\=\#\@\.\,\:\w]+)$/; $nam = $1; next if $nam =~ m/\/symlink_list$/; $cur = _add_file($dat, $nam); next unless $cur->[0] eq 'F' && (scalar @{$cur->[1]}) == 0; $cur->[0] = 'f'; $cur->[1] = [$rec->[1]]; } } return; } # Extract all Oracle Explorer reports sub _extract_reports { my ($dat, $ifh) = @_; my ($blk, $cur, $max, $nam, $pth, $typ, @alt); $max = $dat->{'max'}; $dat->{'res'} = ['D', {}, []] unless exists($dat->{'res'}); while (<$ifh>) { ($typ, undef, $blk, $nam, @alt) = split(/\|/, $_, -1); # Needs all fields next unless $nam =~ m/^([\/\+\-\=\#\@\.\,\:\w]+)$/; $nam = $1; pop(@alt); if ($typ eq 'T') { next unless $blk; $blk = [split(/\//, $blk, 6)]; next if (defined($blk->[4]) ? $blk->[4] : 2) > $max; push(@{_add_file($dat, $nam)->[1]}, $blk); } elsif ($typ eq 'G') { _add_dir($dat, $nam); } elsif ($typ eq 'L') { _add_link($dat, $nam, $pth) if defined($pth = shift(@alt)); } else { next unless $blk; $blk = [split(/\//, $blk, 6)]; next if (defined($blk->[4]) ? $blk->[4] : 2) > $max; $cur = _add_file($dat, $nam); $cur->[1] = [$blk]; $cur->[2] = ($pth =~ m/^"([^"]*)"$/) ? decode($1) : $pth if defined($pth = shift(@alt)); } } $ifh->close; return; } # Extract file status information sub _extract_stat { my ($dat, $ifh) = @_; my ($nam, $sta, @sta); $sta = $dat->{'sta'}; while (<$ifh>) { ($nam, @sta) = split(/\|/, $_, -1); # Needs all fields for the pop $nam = decode($1) if $nam =~ m/^"([^"]*)"$/; pop(@sta); $sta->{$nam} = [@sta] if @sta; } $ifh->close; return; } # Get a node sub _get_node { my ($dat, $nam) = @_; my ($cur); $cur = $dat->{'res'}; foreach my $sub (split(/\//, $nam)) { next unless length($sub); return unless $cur->[0] eq 'D' && exists($cur->[1]->{$sub}); $cur = $cur->[1]->{$sub}; } return $cur; } # Get the report size sub _get_size { my ($dat, $tbl) = @_; my ($tot); $tot = 0; foreach my $blk (@{$tbl}) { $tot += ref($blk) ? $blk->[1] : $dat->{'slf'}->get_size($blk, 1); } return $tot; } # Get the file information sub _get_stat { my ($dat, $pth, $lnk) = @_; my ($sta); if (defined($pth) && exists($dat->{'sta'}->{$pth})) { $sta = $dat->{'sta'}->{$pth}; while (defined($pth = $sta->[14])) { $pth = decode($1) if $pth =~ m/^"([^"]*)"$/; $sta = $dat->{'sta'}->{$pth}; $$lnk = q{ → }.encode($pth) if $lnk; } } return $sta; } 1; __END__ =head1 SEE ALSO 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