# WEB.pm: Web Command Library package RDA::Request::WEB; # $Id: WEB.pm,v 1.29 2015/06/24 07:05:40 RDA Exp $ # ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Request/WEB.pm,v 1.29 2015/06/24 07:05:40 RDA Exp $ # # Change History # 20150624 MSC Allow to specify the remote Perl path at agent start. =head1 NAME RDA::Request::WEB - Web Command Library =head1 SYNOPSIS require RDA::Request::WEB; =head1 DESCRIPTION The objects of the C class are used to interface with Web commands. The following methods are available: =cut use strict; BEGIN { use Exporter; use IO::File; use RDA::Text qw(debug get_string); use RDA::Agent qw($INTERRUPT); use RDA::Handle::Memory; use RDA::Object; use RDA::Object::Message; use RDA::Object::Rda qw($CREATE $FIL_PERMS); use Socket qw(inet_ntoa sockaddr_in AF_INET INADDR_ANY PF_INET SOCK_STREAM SOL_SOCKET SO_REUSEADDR SOMAXCONN); use Symbol qw(gensym); } # Define the global public variables use vars qw($STRINGS $VERSION @ISA); $VERSION = sprintf('%d.%02d', q$Revision: 1.29 $ =~ /(\d+)\.(\d+)/); @ISA = qw(Exporter); # Define the global constants my $DOC = q{}; my $EOL = qq{\015\012}; my $ERR = $DOC.$EOL.q{}.$EOL. q{}.get_string('Error').q{}.$EOL; my $TTL = q{RDA Viewer}; my $WEB = q{Web}; my $ICO = "\211\120\116\107\015\012\032\012\000\000\000\015\111\110\104\122". "\000\000\000\020\000\000\000\020\010\003\000\000\000\050\055\017". "\123\000\000\000\074\120\114\124\105\377\000\000\377\012\000\377". "\020\026\377\031\023\377\040\045\377\076\065\377\141\130\377\150". "\142\377\153\142\377\176\165\377\202\172\377\306\304\377\332\342". "\377\336\345\377\354\361\377\362\355\377\363\373\377\373\370\377". "\377\376\377\377\377\102\226\243\320\000\000\000\011\160\110\131". "\163\000\000\016\304\000\000\016\304\001\225\053\016\033\000\000". "\000\101\111\104\101\124\170\234\143\140\240\011\020\026\026\346". "\006\021\134\014\014\174\234\140\001\016\006\141\126\141\040\315". "\300\040\050\214\120\301\300\040\300\310\313\306\303\014\126\301". "\042\304\000\126\001\224\342\205\152\001\261\331\231\370\301\372". "\350\002\000\233\056\002\325\121\145\214\073\000\000\000\000\111". "\105\116\104\256\102\140\202"; # Define the global private variables my %tb_cmd = ( 'WEB.EXIT' => \&_do_exit, 'WEB.EXPIRE' => \&_do_expire, 'WEB.HALT' => \&_do_halt, 'WEB.INIT' => \&_do_init, 'WEB.PAGE' => \&_do_page, 'WEB.PROXY' => \&_do_proxy, 'WEB.REQUEST' => \&_do_request, 'WEB.SELECT' => \&_do_select, 'WEB.SERVER' => \&_do_server, ); # Report the package version sub Version { return $VERSION; } =head2 S<$h = RDA::Request::WEB-Enew($agt)> The object constructor. This method enables you to specify the agent reference as an argument. C is represented by a blessed hash reference. The following special key is used: =over 10 =item S< B<'_agt'> > Reference to the agent object =item S< B<'_cfg'> > Reference to the RDA software configuration =item S< B<'_drv'> > Reference to the archive driver =item S< B<'_dsp'> > Reference to the display control object when verbose =item S< B<'_pre'> > URL prefix =item S< B<'_pth'> > Path to the default archive =item S< B<'_prx'> > Proxy indicator =item S< B<'_svc'> > Web service hash =back Internal keys are prefixed by an underscore. =cut sub new { my ($cls, $agt) = @_; # Create the library object and return its reference return bless { _agt => $agt, _cfg => $agt->get_config, _dsp => $agt->is_verbose, }, ref($cls) || $cls; } =head2 S<$h-Edelete_object> This method deletes the library object. =cut sub delete_object ## no critic (Unpack) { RDA::Object::dump_caller($_[0], 'Commands') if $RDA::Object::DELETE; _delete_services($_[0]); undef %{$_[0]}; undef $_[0]; return; } sub _delete_services { my ($slf) = @_; if (exists($slf->{'_svc'})) { $slf->{'_agt'}->delete_registry('WEB.ARC'); delete($slf->{'_drv'}); foreach my $obj (values(%{$slf->{'_svc'}})) { $obj->delete_object; } } return {}; } =head2 S<$h-Eexec_command($req)> This method executes the command specified in the message. =cut sub exec_command { my ($slf, $req) = @_; my $cmd = $req->{'msg'}; return exists($tb_cmd{$cmd}) ? &{$tb_cmd{$cmd}}($slf, $req) : $req->error('NotImplemented', get_string('BAD_COMMAND', $cmd)); } =head1 RDA COMMANDS =head2 WEB.EXIT - End message-based operations This command ends all message-based operations. =cut sub _do_exit { my ($slf, $req) = @_; _delete_services($slf); return $req->new('OK.Exit'); } =head2 WEB.EXPIRE - Remove unused archives This command removes archives that have not been used recently. It supports the following attribute: =over 9 =item B< grace> Specifies the grace period in seconds (3600 by default). =back =cut sub _do_expire { my ($slf, $req) = @_; my ($del); return $req->error('NoInit') unless exists($slf->{'_svc'}); $del = eval {_get_driver($slf)->expire($req->get_first('grace'), 3600)}; return $req->reply($@, 'Expire', deleted => $del); } =head2 WEB.HALT - Halt the running web server This command halts the running web server, using the associated process identifier file. =cut sub _do_halt { my ($slf, $req) = @_; my ($cnt, $ifh, $pid, $pth, $sig); $ifh = IO::File->new; $pth = RDA::Object::Rda->cat_file( defined($pth = $slf->{'_agt'}->get_env('RDA_PID')) ? $pth : $slf->{'_cfg'}->get_group('D_CWD'), 'web.pid'); $sig = $slf->{'_cfg'}->is_windows ? 9 : 2; if ($ifh->open("<$pth")) { $pid = <$ifh>; if ($pid =~ m/^(\d+)/) { $slf->{'_dsp'}->dsp_line(get_string('V_Kill', $1)) if $slf->{'_dsp'}; $cnt += kill($sig, $1); } $ifh->close; 1 while unlink($pth); } return $req->new('OK.Halt', count => $cnt); } =head2 WEB.INIT - Initialize services for message-based operations This command initializes services for message-based operations. It supports the following attribute: =over 12 =item B< archive> Provides a default private archive (none by default) =item B< css> Provides the style definition to include in the HTML pages (RDA styles by default). =item B< notice> Provides the notices to include on the HTML pages (copyright, trademark, legal, and accessibility notices by default). =item B< prefix> Specifies the string to prefix all link references (C<> by default). =item B< services> Specifies the list of authorized services (all by default). =item B< private> Indicates whether it is a private context. =back =cut sub _do_init { my ($slf, $req) = @_; my ($err); return $req->error('BadPrefix') unless $req->get_first('prefix', q{}) =~ m/\A(\/\w\S*|)\z/s; $slf->{'_pre'} = $1; $slf->{'_pth'} = _get_default($slf, $req); return ($err = _load_services($slf, $req)) ? $err : $req->new('OK.Init'); } sub _get_default { my ($slf, $req) = @_; my ($pth); return ($req->get_first('private') && (defined($pth = $req->get_first('archive')) || defined($pth = $slf->{'_agt'}->get_info('zip')) || defined($pth = $slf->{'_agt'}->get_collector->get_data)) && (-f $pth || -d $pth) && -r $pth) ? $pth : undef; } sub _get_driver { my ($slf) = @_; unless (exists($slf->{'_drv'})) { require RDA::Driver::Archive; $slf->{'_drv'} = $slf->{'_agt'}->get_registry('WEB.ARC', \&RDA::Driver::Archive::new, 'RDA::Driver::Archive', ## no critic (Call) $slf->{'_agt'}, $slf->{'_pth'}, 1); } return $slf->{'_drv'}; } =head2 WEB.PAGE - Display a help page This command displays the specified help page. It supports the following attributes: =over 8 =item B< data> When true, returns the page as data. =item B< url> Specifies the URL of the help page. =back =cut sub _do_page { my ($slf, $req) = @_; my ($buf, $url); # Validate the argument return $req->error('NoUrl') unless defined($url = $req->get_first('url')); # Display the web page eval { require RDA::Web::Help; RDA::Web::Help->new($req, $slf->{'_agt'}, {})->display( $req->get_first('data') ? RDA::Handle::Memory->new($buf = q{}) : $slf->{'_agt'}->get_screen, 'GET', split(/\?/, $url, 2)); }; # Indicate the completion status return $req->add_error($@)->has_errors ? $req->error('Display') : $req->new('OK.Continue')->add_data($buf); } =head2 WEB.PROXY - Start the internal proxy server This command starts a basic proxy server to review RDA information. It uses basic authentication to restrict page access. If no password is provided, the proxy server is not started. You can access the start page by using the following URL : http://:/display/ It supports the following attributes: =over 18 =item B< archive> Specifies the path of selected remote result archive or directory (none by default). =item B< authentication> Specifies the web user password. =item B< host> Specifies the remote host (C by default). =item B< login> Specifies the remote login (current login by default). =item B< notice> Provides the notices to include on the HTML pages (copyright, trademark, legal, and accessibility notices by default). =item B< password> Specifies the remote user password. =item B< perl> Specifies the path of the remote Perl command. =item B< pid> When true, saves the process identifier of the web server in a file (false by default). =item B< port> Specifies the port number (C<8778> by default). It accepts ports between 1023 and 65535. =item B< prefix> Specifies the string to prefix all link references (C<> by default). =item B< rda> Specifies the path of the remote RDA software. =item B< services> Specifies the list of authorized services (all by default). =item B< taint> Controls when Perl must run in taint mode (true by default). =item B< user> Specifies the user name (C by default). =item B< work> Specifies the path of the remote work directory. =back =cut sub _do_proxy { my ($slf, $req) = @_; my ($acl, $agt, $msg, $prt); # Treat the arguments return $req->error('NoPassword') unless ($acl->{$req->get_first('user', 'rda')} = $req->get_first('authentication')); return $req->error('BadPrefix') unless $req->get_first('prefix', q{}) =~ m/\A(\/\w\S*|)\z/s; $slf->{'_pre'} = $1; $slf->{'_prx'} = 1; $prt = ($req->get_first('port', 8778) =~ m/^(\d{4,5})$/ && $1 > 1023 && $1 < 65535) ? $1 : 8778; # Start the remote agent $agt = $slf->{'_agt'}; $agt->abort if $agt->submit(q{.}, 'AGENT.START', agent => $WEB, host => $req->get_first('host'), password => $req->get_first('password'), perl => $req->get_first('perl'), rda => $req->get_first('rda'), taint => $req->get_first('taint', $agt->get_system->get_info('flg')), type => 'REM', user => $req->get_first('login'), work => $req->get_first('work'), )->is_error($agt) || $agt->submit($WEB, 'WEB.INIT', archive => $req->get_first('archive'), notice => $req->get_first('notice'), private => $req->get_first('private'), services => $req->is_defined('services') ? [$req->get_value('services')] : undef, )->is_error($agt); # Force the load of the module messages $msg = get_string('V_Start', $prt); # Start the proxy server and treat requests return _exec_web($slf, $req, $prt, $acl, $msg); } =head2 WEB.REQUEST - Treat a request This command treats a request and returns the result as data. It supports the following attribute: =over 7 =item B< url> Specifies the request URL. =back =cut sub _do_request { my ($slf, $req) = @_; my ($buf, $cnt, $drv, $err, $new, $svc, $url); # Validate the request return $req->error('NoInit') unless exists($slf->{'_svc'}); ($url, $cnt) = split(/\?/, $req->get_first('url', q{}), 2); return $req->error('NoUrl') unless defined($url); $url =~ s{\A$slf->{'_pre'}}{}; return $req->error('NoService') unless $url =~ s{^/(\w+)(?:/|\z)}{} && exists($slf->{'_svc'}->{$svc = lc($1)}); # Treat the request eval { $buf = q{}; $drv = _get_driver($slf); $drv->get_recent; $err = $slf->{'_svc'}->{$svc}->request(RDA::Handle::Memory->new($buf), 'GET', $url, $cnt); $new = $drv->get_recent; }; return $req->error('Request', {code => $err}) if $err; # Indicate the completion status return $req->add_error($@)->has_errors ? $req->error('Request') : $req->new('OK.Request', new => $new)->add_data($buf); } =head2 WEB.SELECT - Select a new archive This command defines a new archive and returns the identifier of the preferred result set when applicable. It supports the following attribute: =over 11 =item B< archive> Specifies the path of the archive (in C format) or the related directory. =back =cut sub _do_select { my ($slf, $req) = @_; my ($oid, $pth); return $req->error('NoInit') unless exists($slf->{'_svc'}); return $req->error('NoArchive') unless defined($pth = $req->get_first('archive')) && -r $pth; $oid = eval {_get_driver($slf)->add_archive($pth)->get_current->get_oid}; return $req->reply($@, 'Select', id => $oid); } =head2 WEB.SERVER - Start the internal web server This command starts a basic web server to review RDA information. It uses basic authentication to restrict page access. If no password is provided, the web server is not started. You can access the start page by using the following URL : http://:/display/ It supports the following attributes: =over 18 =item B< authentication> Specifies the web user password. =item B< pid> When true, saves the process identifier of the web server in a file (false by default). =item B< port> Specifies the port number (C<8778> by default). It accepts ports between 1023 and 65535. =item B< prefix> Specifies the string to prefix all link references (C<> by default). =item B< services> Specifies the list of authorized services (all by default). =item B< user> Specifies the user name (C by default). =back =cut sub _do_server { my ($slf, $req) = @_; my ($acl, $agt, $err, $msg, $prt); # Initialization $agt = $slf->{'_agt'}; # Treat the arguments return $req->error('NoPassword') unless ($acl->{$req->get_first('user', 'rda')} = $req->get_first('authentication')); return $req->error('BadPrefix') unless $req->get_first('prefix', q{}) =~ m/\A(\/\w\S*|)\z/s; $slf->{'_pre'} = $1; $slf->{'_prx'} = 0; $prt = ($req->get_first('port', 8778) =~ m/^(\d{4,5})$/ && $1 > 1023 && $1 < 65535) ? $1 : 8778; # Force the load of the module messages $msg = get_string('V_Start', $prt); # Force the character set for the message details $agt->set_info('str', substr($agt->set_info('str', 'en'), 0, 2).'.utf8'); # Load the authorized services return $err if ($err = _load_services($slf, $req)); # Start the web server and treat the web requests return _exec_web($slf, $req, $prt, $acl, $msg); } # Start the web server and treat the web requests sub _exec_web { my ($slf, $req, $prt, $acl, $msg) = @_; my ($agt, $cln, $pid, $srv, $src, %src); # Initialization $agt = $slf->{'_agt'}; $cln = gensym; $srv = gensym; # Start the web server return $req->error('Socket', $!) unless socket($srv, PF_INET, SOCK_STREAM, getprotobyname('tcp')); return $req->error('Setsockopt', $!) unless setsockopt($srv, SOL_SOCKET, SO_REUSEADDR, pack('l', 1)); return $req->error('Bind', $!) unless bind($srv, sockaddr_in($prt, INADDR_ANY)); return $req->error('Listen', $!) unless listen($srv, SOMAXCONN); $slf->{'_dsp'}->dsp_line($msg) if $slf->{'_dsp'}; # Treat the request if (RDA::Object::Rda->is_windows) { eval { # Save the web server process identifier _save_pid($slf) if $req->get_first('pid'); # Treat the web requests local $SIG{'__WARN__'} = sub {}; _treat_request($slf, $cln, $acl, \%src, $src) while ($src = accept($cln, $srv)); }; } else { eval { local $SIG{'INT'} = sub {die "$INTERRUPT\n"}; # Save the web server process identifier _save_pid($slf) if $req->get_first('pid'); # Treat the web requests local $SIG{'__WARN__'} = sub {}; _treat_request($slf, $cln, $acl, \%src, $src) while ($src = accept($cln, $srv)); }; } $slf->{'_dsp'}->dsp_line(get_string('V_Halt')) if $slf->{'_dsp'}; # Stop any remote agent $agt->delete_agent('Web') if $slf->{'_prx'}; # Remove the saved process identifier if (defined($pid)) { 1 while unlink($pid); } # Indicate a successful completion return $req->new('INFO.Exit'); } # Extract a line from the message data sub _get_line { my ($cln, $ctl) = @_; my ($buf); for (;; _load_buffer($cln, $ctl)) ## no critic (Loop) { # Extract the first line from the buffer if (length($ctl->{'buf'})) { _sync_line($cln, $ctl); return $1 if $ctl->{'buf'} =~ s/^(.*?)\015\012//; if ($ctl->{'buf'} =~ s/^(.*?)([\012\015])//) { $ctl->{'nxt'} = ($2 eq qq{\012}) ? qq{\015} : qq{\012}; return $1; } } # Accept an incomplete last line if ($ctl->{'eof'}) { return unless length($ctl->{'buf'}); ($buf, $ctl->{'buf'}) = ($ctl->{'buf'}, q{}); return $buf; } } } # Load more input in the buffer sub _load_buffer { my ($cln, $ctl) = @_; $ctl->{'eof'} = 1 unless sysread($cln, $ctl->{'buf'}, 1024, length($ctl->{'buf'})); return; } # Load the web services sub _load_services { my ($slf, $req) = @_; my ($agt, $cls, $ctl, $dir, $flg, $nam, $skp, $svc, @svc); # Determine the authorized services unless ((@svc = $req->get_value('services')) || (@svc = $slf->{'_cfg'}->is_compiled('SVC'))) { $dir = $slf->{'_cfg'}->get_dir('D_RDA_INC', 'RDA/Web'); return $req->error('NoAccess', get_string('ERR_OPEN', $dir, $!)) unless opendir(SVC, $dir); foreach my $pkg (readdir(SVC)) { push(@svc, lc($1)) if $pkg =~ m/^(\w+)\.pm$/i; } closedir(SVC); } # Prepare a new sevice context $agt = $slf->{'_agt'}; $slf->{'_svc'} = $svc = _delete_services($slf); # Load the authorized services $skp = {map {$_ => 1} $slf->{'_cfg'}->get_obsolete('web')}; foreach my $key (@svc) { $nam = ucfirst($key); $cls = "RDA::Web::$nam"; next if $skp->{$cls}; eval "require $cls"; return $req->error('LoadError', get_string('ERR_LOAD', $nam, $@)) if $@; ($flg, $svc->{$key}) = (1, $ctl) if ($ctl = $cls->new($req, $agt, $svc)); } # Indicate the completion status return $flg ? undef : $req->error('NoServices'); } # Validate the authentication sub _need_authen { my ($req, $acl) = @_; my ($enc, $pwd, $str, $usr); # Check if an authentication is present return 1 unless exists($req->{'authorization'}) && ($req->{'authorization'} =~ m{^Basic\s+([A-Za-z0-9+/=]*)}i) && (length($enc = $1) % 4) == 0; # Decode the authentication local ($^W) = 0 ; $enc =~ s/=+$//; # Remove padding $enc =~ tr|A-Za-z0-9+/| -_|; # Convert to uuencode $str = q{}; $str .= unpack('u', chr(32 + 3 * length($1) / 4).$1) while $enc =~ /(.{1,60})/gs; # Validate the authentication ($usr, $pwd) = split(/\:/, $str, 2); return !exists($acl->{$usr}) || $acl->{$usr} ne $pwd; } # Save the process identifier sub _save_pid { my ($slf) = @_; my ($buf, $ofh, $pid); $ofh = IO::File->new; $pid = RDA::Object::Rda->cat_file( defined($pid = $slf->{'_agt'}->get_env('RDA_PID')) ? $pid : $slf->{'_cfg'}->get_group('D_CWD'), 'web.pid'); $ofh->open($pid, $CREATE, $FIL_PERMS) or die get_string('ERR_SAVE', $!); $buf = "$$\n"; $ofh->syswrite($buf, length($buf)); $ofh->close; return; } # Skip trailing characters from previous line sub _sync_line { my ($cln, $ctl) = @_; my ($nxt); if (defined($nxt = delete($ctl->{'nxt'}))) { _load_buffer($cln, $ctl) unless length($ctl->{'buf'}) || $ctl->{'eof'}; $ctl->{'buf'} =~ s/^$nxt?// } return; } # Treat a request sub _treat_request ## no critic (Complex) { my ($slf, $cln, $acl, $tbl, $src) = @_; my ($adr, $agt, $buf, $ctl, $cnt, $err, $htp, $lin, $lvl, $met, $nam, $prt, $req, $rsp, $url, $svc); local $SIG{'PIPE'} = 'IGNORE'; # Get the client address if (exists($tbl->{$src})) { ($nam, $adr, $prt) = @{$tbl->{$src}}; } else { ($prt, $adr) = sockaddr_in($src); $nam = gethostbyaddr($adr, AF_INET); $adr = inet_ntoa($adr); $nam = $adr unless defined($nam); $tbl->{$src} = [$nam, $adr, $prt]; } # Get the HTTP header $agt = $slf->{'_agt'}; $ctl = {buf => q{}}; $lvl = $agt->get_level; $req = {}; binmode($cln); while (defined($lin = _get_line($cln, $ctl))) { $lin =~ s/[\n\r]+//; debug(get_string('T_Header', $lin)) if $lvl >= 40 && $lin; if ($lin =~ m{^([A-Z][A-Za-z\-]*):\s+(.*)$}) { $req->{lc($1)} = $2; } elsif ($lin =~ m{^(GET)\s+(.*)\s+HTTP/(\d\.\d)$}) { ($met, $htp) = ($1, $3); ($url, $cnt) = split(/\?/, $2, 2); } elsif ($lin =~ m{^(POST)\s+(.*)\s+HTTP/(\d\.\d)$}) { ($met, $htp) = ($1, $3); ($url) = split(/\?/, $2, 2); } elsif ($lin eq q{}) { last; } } $url = q{} unless defined($url); $agt->trace(get_string('Request', qq{$nam [$adr]}, $prt), qq{:\n }, $url) unless $lvl < 10; ## no critic (Unless) $url =~ s{\A$slf->{'_pre'}}{}; $url =~ s{/{2,}}{/}g; # Load the request content if (exists($req->{'content-length'})) { my ($lgt, $off, $siz); $siz = $req->{'content-length'}; $agt->trace(get_string('T_Content', $siz)) unless $lvl < 40; ## no critic (Unless) $cnt = substr($ctl->{'buf'}, 0, $siz); $off = length($cnt); for ($siz -= $off ## no critic (Loop) ; $siz > 0 ; $siz -= $lgt, $off += $lgt) ## no critic (Comma) { $agt->trace(get_string('T_Content', $siz)) unless $lvl < 40; ## no critic (Unless) last unless defined($lgt = sysread($cln, $cnt, $siz, $off)); } } # Treat the request if (_need_authen($req, $acl)) { # Request an authentication $buf = q{HTTP/1.0 401 Authentication required}.$EOL .q{WWW-Authenticate: basic realm="RDA Viewer"}.$EOL .q{Content-Type: text/html; charset=UTF-8}.$EOL.$EOL.$ERR .q{

}.$TTL.q{

}.$EOL .q{

HTTP Code 401: Authentication required

}.$EOL .q{}.$EOL; syswrite($cln, $buf, length($buf)); } elsif ($url eq '/favicon.ico') { $buf = q{HTTP/1.0 200 OK}.$EOL .q{Content-Type: image/x-png}.$EOL .q{Content-Length: }.length($ICO).$EOL.$EOL.$ICO; syswrite($cln, $buf, length($buf)); } elsif ($slf->{'_prx'}) { $rsp = $agt->submit($WEB, 'WEB.REQUEST', url => join(q{?}, $url, $cnt)); if ($rsp->is_success) { $buf = $rsp->get_data; } elsif ($rsp->is_error eq 'Send') { close($cln); die get_string('ERR_SEND'); } else { $buf = q{HTTP/1.0 500 Invalid request}.$EOL .q{Content-Type: text/html; charset=UTF-8}.$EOL.$EOL.$ERR .q{

}.$TTL.q{

}.$EOL .q{

HTTP Code 500: Invalid request

}.$EOL .q{}.$EOL; } syswrite($cln, $buf, length($buf)); } elsif ($url !~ s{^/(\w+)(?:/|\z)}{} || !exists($slf->{'_svc'}->{$svc = lc($1)})) { $buf = q{HTTP/1.0 500 Invalid request}.$EOL .q{Content-Type: text/html; charset=UTF-8}.$EOL.$EOL.$ERR .q{

}.$TTL.q{

}.$EOL .q{

HTTP Code 500: Invalid request

}.$EOL .q{}.$EOL; syswrite($cln, $buf, length($buf)); } elsif ($err = eval{$slf->{'_svc'}->{$svc}->request($cln, $met, $url, $cnt)} || $@) { $err = (ref($err) eq 'ARRAY') ? join('
', @{$err}) : "Error: $err"; $err =~ s{\n}{
}g; $err =~ s{\s}{ }g; $buf = q{HTTP/1.0 404 Invalid page}.$EOL .q{Content-Type: text/html; charset=UTF-8}.$EOL.$EOL.$ERR .q{

}.$TTL.q{

}.$EOL .q{

HTTP Code 404: Invalid request

}.$EOL.$err.$EOL .q{}.$EOL; syswrite($cln, $buf, length($buf)); } # Close the client socket close($cln); return; } 1; __END__ =head1 SEE ALSO 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