# Display.pm: Display Web Service package RDA::Web::Display; # $Id: Display.pm,v 1.10 2015/05/05 13:58:25 RDA Exp $ # ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Web/Display.pm,v 1.10 2015/05/05 13:58:25 RDA Exp $ # # Change History # 20150505 MSC Change redirections. =head1 NAME RDA::Web::Display - Display Web Service =head1 SYNOPSIS require RDA::Web::Display; =head1 DESCRIPTION The objects of the C class are used to perform display requests. The following methods are available: =cut use strict; BEGIN { use Exporter; use IO::File; use RDA::Text qw(get_string); use RDA::Driver::Web qw(%MIMES); use RDA::Object; use RDA::Object::Message; use RDA::Object::Rda; } # Define the global public variables use vars qw($STRINGS $VERSION @ISA); $VERSION = sprintf('%d.%02d', q$Revision: 1.10 $ =~ /(\d+)\.(\d+)/); @ISA = qw(Exporter); # Define the global constants my $DOC = q{}; my $EOL = qq{\015\012}; # Define the global private variables # Report the package version sub Version { return $VERSION; } =head2 S<$h = RDA::Web::Display-Enew($req,$agt)> The object constructor. This method enables you to specify the request and the agent references as argument. C is represented by a blessed hash reference. The following special key is used: =over 12 =item S< B<'_dat'> > Diagnostic data directory =item S< B<'_dft'> > Default page =back Internal keys are prefixed by an underscore. =cut sub new { my ($cls, $req, $agt) = @_; # Create the service object and return its reference return bless { _dat => $agt->get_collector->get_data, _dft => 'RDA__start.htm', }, 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, $url) = @_; my ($buf, $dir, $hdr, $ifh, $lgt, $pth, $suf, $typ); # Check for default URL unless (defined($url) && length($url)) { $hdr = q{HTTP/1.0 302 OK}.$EOL .q{Location: /display/}.$slf->{'_dft'}.$EOL .q{Cache-Control: no-cache}.$EOL .q{Expires: }.gmtime().$EOL.$EOL; syswrite($ofh, $hdr, length($hdr)); return 0; } # Validate the request $dir = $slf->{'_dat'}; return 1 if $url =~ m{(^|\/)\.}; return 2 unless -f ($pth = RDA::Object::Rda->cat_file($dir, $url)) || -f ($pth = RDA::Object::Rda->cat_file($dir, lc($url))); return 3 unless ($ifh = IO::File->new)->open("<$pth"); # Determine the MIME type $typ = 'application/octet-stream'; $lgt = 0; if ($pth =~ 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 =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