# Package.pm: Package Web Service package RDA::Web::Package; # $Id: Package.pm,v 1.21 2015/05/08 18:23:43 RDA Exp $ # ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Web/Package.pm,v 1.21 2015/05/08 18:23:43 RDA Exp $ # # Change History # 20150508 MSC Improve the documentation. =head1 NAME RDA::Web::Package - Package Web Service =head1 SYNOPSIS require RDA::Web::Package; =head1 DESCRIPTION The objects of the C class are used to display content of 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; 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; 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.21 $ =~ /(\d+)\.(\d+)/); @DELETE = qw(_ctl); @ISA = qw(Exporter); # Define the global constants my $DOC = q{}; my $EOL = qq{\015\012}; my $NAM = q{package}; # 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 ); # Report the package version sub Version { return $VERSION; } =head2 S<$h = RDA::Web::Package-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<'_cfg'> > Reference to the RDA software configuration =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<'cur'> > Current result set =item S< B<'dft'> > Default request =item S< B<'idx'> > File tree =item S< B<'nam'> > Default name =item S< B<'oid'> > Archive identifier =item S< B<'slf'> > Reference to the archive object =item S< B<'tab'> > Tab definition =back =cut sub new { my ($cls, $req, $agt, $svc) = @_; my ($cfg, $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 $cfg = $agt->get_config; return bless { _agt => $agt, _cfg => $cfg, _css => $req->get_first('css'), _not => $req->get_first('notice'), _pre => $req->get_first('prefix', q{}), _svc => $svc, _web => RDA::Driver::Web->new($cfg), @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 ($buf, $dat, $det, $ifh, $nam, $rel, $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)); # Build the directory tree unless (exists($dat->{'cur'})) { $dat->{'cur'} = $dat->{'slf'}->get_current; $dat->{'nam'} = _get_name($dat->{'dft'} = $dat->{'cur'}->get_prefix); _build_index($slf, $dat); } # Define the available tabs on first use unless (exists($dat->{'tab'})) { my ($oid, $svc, $tab, $tid, $url); $dat->{'tab'} = $tab = []; $svc = $slf->{'_svc'}; $oid = $dat->{'cur'}->get_oid; foreach my $rec (@tb_tab) { ($nam, $ttl, $url, $tid) = @{$rec}; if ($tid eq 'pkg_dir') { push(@{$tab}, [get_string($ttl), sprintf($url, $dat->{'oid'}), $dat->{'nam'}]); } elsif (exists($svc->{$nam})) { push(@{$tab}, [get_string($ttl), sprintf($url, $oid), $tid]); } } } # Validate the request $req = 'dir/'.$dat->{'dft'} unless ($req = decode_uri($req)); return _dive($slf, $ofh, $dat, $req) if $req =~ s/^dive\///; return _dsp_file($slf, $ofh, $dat, $req) if $req =~ s/^file\///; return _refresh($slf, $ofh, $dat) if $req =~ s/^refresh(\/|\z)//; return _rise($slf, $ofh, $dat) if $req =~ s/^rise(\/|\z)//; return _select($slf, $ofh, $dat, $req) if $req =~ s/^set\///; return 1 unless $req =~ s/^dir(\/|\z)//; ($nam, $ttl, $det, $rel) = eval {_dsp_dir($slf, $dat, $req, _get_name($req) eq $dat->{'nam'})}; return [$slf->{'_agt'}->add_error($@)->pop_errors(1)] if $@; return 2 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; } # --- Page generation routines ------------------------------------------------ # Select another archive sub _dive { my ($slf, $ofh, $dat, $req) = @_; return _redirect($slf, $ofh, $dat->{'slf'}->dive($req)); } # Treat the directory request sub _dsp_dir { my ($slf, $dat, $req, $flg) = @_; my ($buf, $cur, $nam, $oid, $rec, $rel, $tbl, $ttl, @pre, @rel); # Determine the node return ('pkg_none', $req, [[\&_write, q{
}.get_string('None')]]) unless exists($dat->{'idx'}); return ('pkg_unknown', $req, [[\&_write, q{
}.get_string('Unknown', $req)]]) unless defined($cur = _get_node($dat, $req)); # Generate the report body $oid = $dat->{'slf'}->get_oid; $ttl = defined($cur->[0]) ? get_string('TtlSubDir', $cur->[0]) : get_string('TtlTopDir'); $buf = qq{

$ttl

\n\n} .q{} .q{} ."\n"; if (defined($rec = $cur->[1])) { $buf .= q{} .q{\n}; } foreach my $key (sort keys(%{$cur->[2]})) { $rec = $cur->[2]->{$key}; $nam = encode(length($key) ? $key : q{/}); if (ref($rec->[2]) eq 'HASH') { $buf .= q{} .q{\n}; } else { $buf .= q{} .q{\n}; } } $buf .= "

Type	Name
D	[0]) ? $rec->[0] : q{}) .qq{'>..
D	[0]) .qq{'>$nam
F	[0]) .qq{'>$nam

\n"; # Add related links if ($flg) { push(@rel, [[get_string('SctPrefix'), [map {[encode($_), qq{/package/$oid/set/$_}, 'set_prefix']} sort @pre]]]) if (@pre = $dat->{'slf'}->get_prefixes); push(@rel, [[get_string('SctDive'), [map {[encode($_), qq{/package/$oid/dive/$_}, 'dive']} sort @{$tbl}]]]) if ($tbl = $dat->{'slf'}->can_dive); if ($dat->{'slf'}->can_refresh) { push(@rel, [[get_string('SctAction'), [[encode(get_string('Refresh')), qq{/package/$oid/refresh}, 'refresh']]]]); } elsif ($dat->{'slf'}->can_rise) { push(@rel, [[get_string('SctAction'), [[encode(get_string('Rise')), qq{/package/$oid/rise}, 'rise']]]]); } $rel = [@rel] if @rel; } # Return the report descriptor return (_get_name($req), $ttl, [[\&_write, $buf]], $rel); } # Treat the file request sub _dsp_file { my ($slf, $ofh, $dat, $req) = @_; my ($blk, $buf, $cur, $hdr, $ifh, $lgt, $suf, $typ); # Open the file return 3 unless exists($dat->{'idx'}) ## no critic (Unless) && defined($cur = _get_node($dat, $req)) && ref($blk) ne 'HASH'; return 4 unless defined($ifh = $dat->{'slf'}->find_handle($cur->[0])); binmode($ifh); # Determine the MIME type $lgt = 0; if ($req =~ 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; # Indicate a successful completion return 0; } # Generate the page name sub _get_name { my ($req) = @_; my ($nam); $nam = 'pkg_dir_'.$req; $nam =~ s/[_\W]+/_/g; $nam =~ s/_$//; return $nam; } # Redirect to the new result set sub _redirect { my ($slf, $ofh, $pkg) = @_; my ($buf); # Redirect to the new result set $buf = q{HTTP/1.0 302 OK}.$EOL .q{Location: }.encode_uri($slf->{'_pre'}, 'package', $pkg, q{}).$EOL .q{Cache-Control: no-cache}.$EOL .q{Expires: }.gmtime().$EOL.$EOL; syswrite($ofh, $buf, length($buf)); # Indicate a successful completion return 0; } # Refresh the archive sub _refresh { my ($slf, $ofh, $dat) = @_; my ($dft, $oid); # Get the current default $dft = $dat->{'dft'}; $oid = $dat->{'oid'}; # Refresh the archive $dat->{'slf'}->refresh and $dat->{'slf'}->select($dft); # Redirect to the new context return _redirect($slf, $ofh, $oid); } # Return to the previous context sub _rise { my ($slf, $ofh, $dat) = @_; return _redirect($slf, $ofh, $dat->{'slf'}->rise); } # Select another result set sub _select { my ($slf, $ofh, $dat, $req) = @_; # Force tab redefinition on next request delete($dat->{'tab'}); # Change the current result set $dat->{'slf'}->select($req); $dat->{'cur'} = $dat->{'slf'}->get_current; $dat->{'nam'} = _get_name($dat->{'dft'} = $dat->{'cur'}->get_prefix); # Redirect to the new result set return _redirect($slf, $ofh, $dat->{'oid'}); } # Write the buffer sub _write { my ($ofh, $buf) = @_; return syswrite($ofh, $buf, length($buf)); } # --- Catalog management routines --------------------------------------------- # Build the package index sub _build_index { my ($slf, $dat) = @_; my ($cur); # Create the file tree $dat->{'idx'} = [] unless exists($dat->{'idx'}); # Load the index information eval { foreach my $nam ($dat->{'slf'}->get_catalog) { $cur = $dat->{'idx'}; foreach my $sub (split(/\//, $nam)) { next unless length($sub); unless (exists($cur->[2]->{$sub})) { $cur->[2]->{$sub} = defined($cur->[0]) ? [join(q{/}, $cur->[0], $sub), $cur] : [$sub, $cur]; } $cur = $cur->[2]->{$sub}; } $cur->[0] = $nam; } }; $slf->{'_agt'}->add_error($@) if $@; return; } # Get a node sub _get_node { my ($dat, $nam) = @_; my ($cur); $cur = $dat->{'idx'}; foreach my $sub (split(/\//, $nam)) { next unless length($sub); return unless exists($cur->[2]->{$sub}); $cur = $cur->[2]->{$sub}; } return $cur; } 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