# Rda.pm: RDA Web Service package RDA::Web::Rda; # $Id: Rda.pm,v 1.16 2015/05/05 13:58:25 RDA Exp $ # ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Web/Rda.pm,v 1.16 2015/05/05 13:58:25 RDA Exp $ # # Change History # 20150505 MSC Change redirections. =head1 NAME RDA::Web::Rda - RDA Web Service =head1 SYNOPSIS require RDA::Web::Rda; =head1 DESCRIPTION The objects of the C class are used to review RDA results from a zipped or expanded result 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::Web qw(%MIMES); use RDA::Object; use RDA::Object::Rda; } # Define the global public variables use vars qw($STRINGS $VERSION @DELETE @ISA); $VERSION = sprintf('%d.%02d', q$Revision: 1.16 $ =~ /(\d+)\.(\d+)/); @DELETE = qw(_ctl); @ISA = qw(Exporter); # Define the global constants my $DOC = q{}; my $EOL = qq{\015\012}; my $NAM = q{rda}; # Define the global private variables # Report the package version sub Version { return $VERSION; } =head2 S<$h = RDA::Web::Rda-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<'_ctl'> > Reference to the archive control object =item S< B<'_pre'> > URL prefix =item S< B<'_prt'> > Current port =item S< B<'_pth'> > Archive path =back Internal keys are prefixed by an underscore. =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, _pre => $req->get_first('prefix', q{}), _prt => $agt->get_system->is_port($req->get_first('port'), 1) || 8778, @att, }, ref($cls) || $cls; } =head2 S<$h-Edelete_object> This method deletes the display object. =cut sub delete_object ## no critic (Unpack) { RDA::Object::dump_caller($_[0], 'Web') if $RDA::Object::DELETE; $_[0]->{'_ctl'}->delete_object if exists( $_[0]->{'_ctl'}); 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, $url) = @_; my ($buf, $dat, $hdr, $ifh, $lgt, $suf, $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 = ($url =~ s{\A([\dA-Fa-f]{32}(?:-\d+)?)(?:\/|\z)}{}) ? $slf->{'_ctl'}->get_data($NAM, $1) : $slf->{'_ctl'}->get_data($NAM, $DFT_SET)); $dat->{'tmp'} = $dat->{'slf'}->set_temp($slf->{'_prt'}); # Check for default URL unless (defined($url) && length($url)) { return 2 unless defined($url = $dat->{'slf'}->get_start); $hdr = q{HTTP/1.0 302 OK}.$EOL .q{Location: }.$slf->{'_pre'}.q{/rda/}.$dat->{'oid'}.q{/}.$url.$EOL .q{Cache-Control: no-cache}.$EOL .q{Expires: }.gmtime().$EOL.$EOL; syswrite($ofh, $hdr, length($hdr)); return 0; } # Validate the request return 1 if $url =~ m{(^|\/)\.}; return 3 unless defined($ifh = $dat->{'slf'}->find_render($url)); # Determine the MIME type $typ = 'application/octet-stream'; $lgt = 0; if ($url =~ m/\.([a-z][a-z0-9]*)$/i) { $suf = lc($1); if (exists($MIMES{$suf})) { $typ = $MIMES{$suf}; } elsif ($suf eq 'dat') { $lgt = $ifh->sysread($buf, 4096); $typ = 'text/plain' unless $buf =~ m/[^\b\f\n\r\t\040-\176]/ } } # 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; } 1; __END__ =head1 SEE ALSO 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