lib/Vend/Server.pm

   1 # Vend::Server - Listen for Interchange CGI requests as a background server
   2 #
   3 # Copyright (C) 2002-2009 Interchange Development Group
   4 # Copyright (C) 1996-2002 Red Hat, Inc.
   5 #
   6 # This program was originally based on Vend 0.2 and 0.3
   7 # Copyright 1995 by Andrew M. Wilcox <amw@wilcoxsolutions.com>
   8 #
   9 # This program is free software; you can redistribute it and/or modify
  10 # it under the terms of the GNU General Public License as published by
  11 # the Free Software Foundation; either version 2 of the License, or
  12 # (at your option) any later version.
  13 #
  14 # This program is distributed in the hope that it will be useful,
  15 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 # GNU General Public License for more details.
  18 #
  19 # You should have received a copy of the GNU General Public
  20 # License along with this program; if not, write to the Free
  21 # Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
  22 # MA  02110-1301  USA.
  23
  24 package Vend::Server;
  25
  26 use vars qw($VERSION);
  27 $VERSION = '2.106';
  28
  29 use Cwd;
  30 use POSIX qw(setsid strftime);
  31 use Vend::Util;
  32 use Vend::CharSet qw/ to_internal decode_urlencode default_charset /;
  33 use Fcntl;
  34 use Errno qw/:POSIX/;
  35 use Config;
  36 use Socket;
  37 use Symbol;
  38 use strict;
  39
  40 no warnings qw(uninitialized);
  41
  42 my $ppidsub = sub { return getppid };
  43
  44 sub new {
  45     my ($class, $fh, $env, $entity) = @_;
  46     populate($env);
  47     my $http = {
  48                                         fh => $fh,
  49                                         entity => $entity,
  50                                         env => $env,
  51                                 };
  52         eval {
  53                 map_cgi($http);
  54         };
  55         if($@) {
  56                 my $msg = errmsg("CGI mapping error: %s", $@);
  57                 ::logGlobal({ level => 'error' }, $msg);
  58                 return undef;
  59         }
  60     bless $http, $class;
  61 }
  62
  63 my @Map = qw/
  64     authorization         AUTHORIZATION
  65     content_length        CONTENT_LENGTH
  66     content_type          CONTENT_TYPE
  67     content_encoding      HTTP_CONTENT_ENCODING
  68     cookie                HTTP_COOKIE
  69     http_host             HTTP_HOST
  70     http_x_forwarded_for  HTTP_X_FORWARDED_FOR
  71     path_info             PATH_INFO
  72     pragma                HTTP_PRAGMA
  73     query_string          QUERY_STRING
  74     referer               HTTP_REFERER
  75     remote_addr           REMOTE_ADDR
  76     remote_host           REMOTE_HOST
  77     remote_user           REMOTE_USER
  78     request_method        REQUEST_METHOD
  79     request_uri           REQUEST_URI
  80     script_name           SCRIPT_NAME
  81     secure                HTTPS
  82     server_name           SERVER_NAME
  83     server_host           HTTP_HOST
  84     server_port           SERVER_PORT
  85     useragent             HTTP_USER_AGENT
  86
  87 /;
  88
  89 my @RedirMap = qw/
  90     path_info          REDIRECT_URL
  91     query_string       REDIRECT_QUERY_STRING
  92     error_notes        REDIRECT_ERROR_NOTES
  93     redirect_status    REDIRECT_STATUS
  94     request_method     REDIRECT_REQUEST_METHOD
  95 /;
  96
  97 ### This is to account for some bad Socket.pm implementations
  98 ### which don't set SOMAXCONN, I think SCO is the big one
  99
 100 my $SOMAXCONN;
 101 if(defined &SOMAXCONN) {
 102         $SOMAXCONN = SOMAXCONN;
 103 }
 104 else {
 105         $SOMAXCONN = 128;
 106 }
 107
 108 ###
 109 ###
 110
 111 sub populate {
 112     my ($cgivar) = @_;
 113
 114         if($Global::Environment) {
 115                 for(@{$Global::Environment}) {
 116                         $ENV{$_} = $cgivar->{$_} if defined $cgivar->{$_};
 117                 }
 118         }
 119
 120     my @map = @Map;
 121     my ($field, $cgi);
 122         no strict 'refs';
 123     while (($field, $cgi) = splice(@map, 0, 2)) {
 124         ${"CGI::$field"} = $cgivar->{$cgi} if defined $cgivar->{$cgi};
 125 #::logDebug("CGI::$field=" . ${"CGI::$field"});
 126     }
 127
 128         # try to get originating host's IP address if request was
 129         # forwarded through a trusted proxy
 130         if (
 131                 $Global::TrustProxy
 132                 and (
 133                         $CGI::remote_addr =~ $Global::TrustProxy
 134                         or $CGI::remote_host =~ $Global::TrustProxy
 135                 )
 136                 and my $forwarded_for = $cgivar->{HTTP_X_FORWARDED_FOR}
 137         ) {
 138                 # multiple source IP addresses may appear in X-Forwarded-For header
 139                 # in a comma-separated list
 140                 for my $ip (reverse grep /\S/, split /\s*,\s*/, $forwarded_for) {
 141                         # do we have a valid-looking IP address?
 142                         if ($ip !~ /^\d\d?\d?\.\d\d?\d?\.\d\d?\d?\.\d\d?\d?$/) {
 143                                 # if not, log error and ignore X-Forwarded-For header
 144                                 ::logGlobal(
 145                                         { level => 'info' },
 146                                         "Unknown X-Forwarded-For header set from trusted proxy %s: %s",
 147                                         $CGI::remote_addr,
 148                                         $forwarded_for,
 149                                 );
 150                                 last;
 151                         }
 152
 153                         # skip any other upstream trusted proxies
 154                         next if $ip =~ $Global::TrustProxy;
 155
 156                         # rightmost IP address that's not a trusted proxy is the customer IP
 157                         # address as far as we're concerned, so keep that and exit loop
 158                         $CGI::remote_addr = $ip;
 159                         undef $CGI::remote_host;
 160                         last;
 161                 }
 162         }
 163 }
 164
 165 sub log_http_data {
 166         return unless $Global::Logging > 4;
 167         my $ref = shift;
 168         my @parms = split /\s+/,
 169          ($Global::Syslog->{http_items} ||
 170                 q{
 171                         REQUEST_URI
 172                         HTTP_COOKIE
 173                         SERVER_NAME
 174                         REMOTE_ADDR
 175                         HTTP_HOST
 176                         HTTP_USER_AGENT
 177                         REMOTE_USER
 178                 });
 179         my $string = 'access: ';
 180         for(@parms) {
 181                 next unless $ref->{env}{$_};
 182                 $string .= " $_=$ref->{env}{$_}";
 183         }
 184         ::logGlobal( { level => 'info' }, $string);
 185         return unless $Global::Logging > 5;
 186         my $ent = $ref->{entity};
 187         return unless $$ent;
 188         ::logGlobal( { level => 'debug' }, "POST=" . $$ent);
 189         return;
 190 }
 191
 192 sub map_misc_cgi {
 193         $CGI::host = $CGI::remote_host || $CGI::remote_addr;
 194         $CGI::user = $CGI::remote_user;
 195
 196         my $server_host_without_port = $CGI::server_host;
 197         $server_host_without_port =~ s/:.*// if $Global::FullUrlIgnorePort;
 198         $CGI::script_path = $CGI::script_name;
 199         $CGI::script_name = $server_host_without_port . $CGI::script_path
 200                 if $Global::FullUrl;
 201 }
 202
 203 sub map_cgi {
 204         my $h = shift;
 205     die "REQUEST_METHOD is not defined" unless defined $CGI::request_method
 206                 or @Global::argv;
 207
 208         map_misc_cgi() if $h;
 209
 210         # Initialize since always used elsewhere, never will be 0
 211         $CGI::content_type ||= '';
 212
 213         my $g = $Global::Selector{$CGI::script_name}
 214                 or do {
 215                         my $msg = ::get_locale_message(
 216                                                 404,
 217                                                 "Undefined catalog: %s",
 218                                                 $CGI::script_name,
 219                                                 );
 220                         my $content_type = $msg =~ /<html/i ? 'text/html' : 'text/plain';
 221                         my $len = length($msg);
 222                         $Vend::StatusLine = <<EOF;
 223 Status: 404 Not found
 224 Content-Type: $content_type
 225 Content-Length: $len
 226 EOF
 227                         respond('', \$msg);
 228                         die($msg);
 229                 };
 230
 231         if($Global::DNSBL) {
 232                 my @quads = split /\./, $CGI::remote_addr;
 233                 my $intro = join ".", reverse(@quads), '';
 234                 my $blocked;
 235                 for(@{$Global::DNSBL}) {
 236                         my $addr = gethostbyname($intro . $_)
 237                          or next;
 238                         $blocked = 1;
 239                 }
 240                 if($blocked) {
 241                         my $msg = ::get_locale_message( 403, "Listed on avoid list.",);
 242                         my $content_type = $msg =~ /<html/i ? 'text/html' : 'text/plain';
 243                         my $len = length($msg);
 244                         $Vend::StatusLine = <<EOF;
 245 Status: 403 Forbidden
 246 Content-Type: $content_type
 247 Content-Length: $len
 248 EOF
 249                         respond('', \$msg);
 250                         die($msg);
 251                 }
 252         }
 253
 254         ($::IV, $::VN, $::SV) = $g->{VarName}
 255                         ? ($g->{IV}, $g->{VN}, $g->{IgnoreMultiple})
 256                         : ($Global::IV, $Global::VN, $Global::IgnoreMultiple);
 257
 258         # Vend::ModPerl has already handled GET/POST parsing
 259         return if $Global::mod_perl;
 260
 261 #::logDebug("CGI::query_string=" . $CGI::query_string);
 262 #::logDebug("entity=" . ${$h->{entity}});
 263
 264 #::logDebug("Check robot UA=$Global::RobotUA IP=$Global::RobotIP");
 265         if ($Global::RobotIP and $CGI::remote_addr =~ $Global::RobotIP) {
 266 #::logDebug("It is a robot by IP!");
 267                 $Vend::Robot = 1;
 268         }
 269         elsif ($Global::HostnameLookups && $Global::RobotHost) {
 270                 if (!$CGI::remote_host && $CGI::remote_addr) {
 271                         $CGI::remote_host = gethostbyaddr(Socket::inet_aton($CGI::remote_addr),Socket::AF_INET);
 272                         $CGI::host = $CGI::remote_host || $CGI::remote_addr;
 273                 }
 274                 if ($CGI::remote_host && $CGI::remote_host =~ $Global::RobotHost) {
 275 #::logDebug("It is a robot by host!");
 276                         $Vend::Robot = 1;
 277                 }
 278         }
 279         unless ($Vend::Robot) {
 280                 if ($Global::NotRobotUA and $CGI::useragent =~ $Global::NotRobotUA) {
 281                         # do nothing
 282                 }
 283                 elsif ($Global::RobotUA and $CGI::useragent =~ $Global::RobotUA) {
 284 #::logDebug("It is a robot by UA!");
 285                         $Vend::Robot = 1;
 286                 }
 287         }
 288
 289         $CGI::values{mv_tmp_session} ||= 1 if $Vend::Robot;
 290 }
 291
 292 # This is called by parse_multipart
 293 # Doesn't do unhexify
 294 sub store_cgi_kv {
 295         my ($key, $value) = @_;
 296
 297         $key = lc ($key) if
 298                 $Global::DowncaseVarname
 299                 && $Global::DowncaseVarname =~ /\b\Q$key\E\b/i;
 300
 301         $key = $::IV->{$key} if defined $::IV->{$key};
 302         if(defined $CGI::values{$key} and ! defined $::SV{$key}) {
 303                 $CGI::values{$key} = "$CGI::values{$key}\0$value";
 304                 push ( @{$CGI::values_array{$key}}, $value)
 305         }
 306         else {
 307                 $CGI::values{$key} = $value;
 308                 $CGI::values_array{$key} = [$value];
 309         }
 310 }
 311
 312 sub parse_cgi {
 313         my $h = shift;
 314
 315         my $request_method = "\U$CGI::request_method";
 316         if ($request_method eq 'POST') {
 317 #::logDebug("content type header: " . $CGI::content_type);
 318                 ## check for valid content type
 319                 if ($CGI::content_type =~ m{^(?:multipart/form-data|application/x-www-form-urlencoded|application/xml|application/json)\b}i) {
 320                         parse_post(\$CGI::query_string, 1)
 321                                 if $Global::TolerateGet;
 322                         parse_post($h->{entity});
 323                 }
 324                 else {
 325                         ## invalid content type for POST
 326                         ## XXX we may want to be a little more forgiving here
 327                         my $msg = ::get_locale_message(415, "Unsupported Content-Type for POST method");
 328                         my $content_type = $msg =~ /<html/i ? 'text/html' : 'text/plain';
 329                         my $len = length($msg);
 330                         $Vend::StatusLine = <<EOF;
 331 Status: 415 Unsupported Media Type
 332 Content-Type: $content_type
 333 Content-Length: $len
 334 EOF
 335                         respond('', \$msg);
 336                         die($msg);
 337                 }
 338         }
 339         elsif ($request_method eq 'PUT') {
 340 #::logDebug("Put operation.");
 341                 parse_post(\$CGI::query_string);
 342                 $CGI::put_ref = $h->{entity};
 343 #::logDebug("Put contents: $$CGI::put_ref");
 344                 $$CGI::put_ref =~ s/^\s*--+\s+begin\s+content\s+--+\r?\n//i;
 345                 $$CGI::put_ref =~ s/^\r?\n--+\s+end\s+content\s+--+\s*$//i;
 346         }
 347         else {
 348                  parse_post(\$CGI::query_string);
 349         }
 350 }
 351
 352 sub parse_post {
 353         my ($sref, $is_get) = @_;
 354         return unless length $$sref;
 355
 356         my (@pairs, $pair, $key, $value, $charset);
 357
 358         if ($CGI::content_type =~ m/\bcharset=(["']?)([-a-zA-Z0-9]+)\1/i) {
 359                 $charset = $2;
 360         }
 361         else {
 362                 $charset = default_charset();
 363         }
 364
 365         $CGI::values{mv_form_charset} = $charset;
 366
 367         if ($CGI::content_type =~ m{^multipart/}i && ! $is_get) {
 368                 return parse_multipart($sref) if $CGI::useragent !~ /MSIE\s+5/i;
 369                 # try and work around an apparent IE5 bug that sends the content type
 370                 # of the next POST after a multipart/form POST as multipart also -
 371                 # even though it's sent as non-multipart data
 372                 # Contributed by Bill Randle
 373                 my ($boundary) = $CGI::content_type =~ /\bboundary="?([^";]+)"?/i;
 374                 $boundary = '--' . quotemeta $boundary;
 375                 return parse_multipart($sref) if $$sref =~ /^\s*$boundary\s+/;
 376         }
 377         @pairs = split($Global::UrlSplittor, $$sref);
 378         if( defined $pairs[0] and $pairs[0] =~ /^       (\w{8,32})? ; /x)  {
 379                 @CGI::values{qw/ mv_session_id mv_arg mv_pc /}
 380                         = split /;/, $pairs[0], 3;
 381 #::logDebug("found session stuff: $CGI::values{mv_session_id} --> $CGI::values{mv_arg}  --> $CGI::values{mv_pc} ");
 382                 shift @pairs;
 383         }
 384         elsif (scalar(@pairs) == 1 and $pairs[0] !~ /=/) {      # Must be an isindex
 385                 $CGI::values{ISINDEX} = $pairs[0];
 386                 $CGI::values_array{ISINDEX} =  [ split /\+/, $pairs[0] ];
 387                 @pairs = ();
 388         }
 389         my $request_method = "\U$CGI::request_method";
 390         my $redo;
 391   CGIVAL: {
 392         # This loop semi-duplicated in store_cgi_kv
 393         foreach $pair (grep length, @pairs) {
 394                 ($key, $value) = ($pair =~ m/([^=]+)=(.*)/)
 395                         or do {
 396                                 if ($Global::TolerateGet) {
 397                                         $key = $pair;
 398                                         $value = undef;
 399                                 }
 400                                 elsif ($request_method eq 'POST') {
 401                                         die ::errmsg("Syntax error in POST input: %s\n%s", $pair, $$sref);
 402                                 }
 403                                 else {
 404                                         die ::errmsg("Syntax error in GET input: %s\n", $pair);
 405                                 }
 406                         };
 407
 408 #::logDebug("incoming --> $key");
 409                 $key = lc ($key) if
 410                         $Global::DowncaseVarname
 411                         && $Global::DowncaseVarname =~ /\b\Q$key\E\b/i;
 412
 413                 $key = $::IV->{$key} if defined $::IV->{$key};
 414
 415                 Vend::CharSet::decode_urlencode(\$key, $charset);
 416
 417 #::logDebug("mapping  --> $key");
 418                 if ($key) {
 419                         decode_urlencode(\$value, $charset);
 420                         # Handle multiple keys
 421                         if(defined $CGI::values{$key} and ! defined $::SV{$key}) {
 422                                 $CGI::values{$key} = "$CGI::values{$key}\0$value";
 423                                 push @{$CGI::values_array{$key}}, $value;
 424                         }
 425                         else {
 426                                 $CGI::values{$key} = $value;
 427                                 $CGI::values_array{$key} = [$value];
 428                         }
 429                 }
 430         }
 431         if (! $redo and $request_method eq 'POST') {
 432                 @pairs = split $Global::UrlSplittor, $CGI::query_string;
 433                 if( defined $pairs[0] and $pairs[0] =~ /^       (\w{8,32}) ; /x)  {
 434                         my (@old) = split /;/, $pairs[0], 3;
 435                         $CGI::values{mv_session_id} = $old[0]
 436                                 if ! defined $CGI::values{mv_session_id};
 437                         $CGI::values{mv_arg} = $old[1]
 438                                 if ! defined $CGI::values{mv_arg};
 439                         $CGI::values{mv_pc} = $old[3]
 440                                 if ! defined $CGI::values{mv_pc};
 441 #::logDebug("found session stuff: $CGI::values{mv_session_id} --> $CGI::values{mv_arg}  --> $CGI::values{mv_pc} ");
 442                         shift @pairs;
 443                 }
 444                 $redo = 1;
 445         }
 446   } # End CGIVAL
 447 }
 448
 449 sub parse_multipart {
 450         my $sref = shift;
 451
 452         my ($boundary) = $CGI::content_type =~ /boundary=\"?([^\";]+)\"?/;
 453         $boundary = quotemeta $boundary;
 454
 455         # Stolen from CGI.pm, thanks Lincoln
 456         $boundary = "--$boundary"
 457                 unless $CGI::useragent =~ /MSIE 3\.0[12];  Mac/i;
 458
 459         unless ($$sref =~ s/^\s*$boundary\s+//) {
 460                 die ::errmsg("multipart/form-data sent incorrectly:\n%s\n", $$sref);
 461         }
 462
 463         my @parts;
 464         @parts = split /\r?\n$boundary/, $$sref;
 465
 466         DOMULTI: {
 467                 for (@parts) {
 468                     last if ! $_ || ($_ =~ /^--(\r?\n)?$/);
 469                         s/^\s+//;
 470                         my($header, $data) = split /\r?\n\r?\n/, $_, 2;
 471                         my $token = '[-\w!\#$%&\'*+.^_\`|{}~]';
 472                         my %header;
 473                         $header =~ s/\r?\n\s+/ /og;           # merge continuation lines
 474                         while ($header=~/($token+):\s+([^\r\n]*)/mgox) {
 475                                 my ($field_name,$field_value) = ($1,$2); # avoid taintedness
 476                                 $field_name =~ s/\b(\w)/uc($1)/eg; #canonicalize
 477                                 $header{$field_name} = $field_value;
 478                         }
 479
 480 #::logDebug("Content-Disposition: " .  $header{'Content-Disposition'});
 481                         my($param)= $header{'Content-Disposition'}=~/ name="?([^\";]+)"?/;
 482
 483                         # Bug:  Netscape doesn't escape quotation marks in file names!!!
 484                         my($filename) = $header{'Content-Disposition'}=~/ filename="?([^\";]*)"?/;
 485 #::logDebug("param='$param' filename='$filename'" );
 486                         if(not defined $param) {
 487                                 ::logGlobal({ level => 'debug' }, "unsupported multipart header: \n%s\n", $header);
 488                                 next;
 489                         }
 490
 491                         my ($content_type) = $header{'Content-Type'} =~ /^([^\s;]+)/;
 492                         my ($charset) = $header{'Content-Type'} =~ / charset="?([-a-zA-Z0-9]+)"?/;
 493
 494                         $content_type ||= 'text/plain';
 495                         $charset ||= default_charset();
 496
 497                         if ($content_type =~ m{^text/}i && ($::Variable->{MV_UTF8} || $Global::Variable->{MV_UTF8})) {
 498                                 Vend::CharSet::to_internal($charset, \$data);
 499                                 # use our character set instead of the client's one
 500                                 # to store the file
 501                                 $charset = default_charset();
 502                         }
 503                         else {
 504                                 $charset = 'raw';
 505                         }
 506
 507                         if($filename) {
 508                                 $CGI::file{$param} = $data;
 509                                 $CGI::file_encoding{$param} = $charset;
 510                                 $data = $filename;
 511                         }
 512                         else {
 513                                 $data =~ s/\r?\n$//;
 514                         }
 515                         store_cgi_kv($param, $data);
 516                 }
 517         }
 518         return 1;
 519 }
 520
 521
 522 sub create_cookie {
 523         my($domain,$path) = @_;
 524         my  $out;
 525         return '' if $Vend::tmp_session;
 526         my @jar;
 527         push @jar, [
 528                                 ($::Instance->{CookieName} || 'MV_SESSION_ID'),
 529                                 defined $::Instance->{ClearCookie} ? '' : $Vend::SessionName,
 530                                 $Vend::Expire || undef,
 531                                 undef,
 532                                 undef,
 533                                 $Vend::Cfg->{SessionCookieSecure} ? $CGI::secure : undef,
 534                         ]
 535                 unless $Vend::CookieID;
 536         push @jar, @{$::Instance->{Cookies}}
 537                 if defined $::Instance->{Cookies};
 538         $out = '';
 539         foreach my $cookie (@jar) {
 540                 my ($name, $value, $expire, $d, $p, $secure) = @$cookie;
 541                 $d = $domain if ! $d;
 542                 $p = $path   if ! $p;
 543 #::logDebug("create_cookie: name=$name value=$value expire=$expire");
 544                 $value = Vend::Interpolate::esc($value)
 545                         if $value !~ /^[-\w:.]+$/;
 546                 $out .= "Set-Cookie: $name=$value;";
 547                 $out .= " path=$p;";
 548                 $out .= " domain=" . $d . ";" if $d;
 549                 if (defined $expire or $Vend::Expire) {
 550                         my $expstring;
 551                         if(! $expire) {
 552                                 $expire = $Vend::Expire;
 553                         }
 554                         elsif($expire =~ /\s\S+\s/) {
 555                                 $expstring = $expire;
 556                         }
 557                         $expstring = strftime "%a, %d-%b-%Y %H:%M:%S GMT ", gmtime($expire)
 558                                 unless $expstring;
 559                         $expstring = "expires=$expstring" if $expstring !~ /^\s*expires=/i;
 560                         $expstring =~ s/^\s*/ /;
 561                         $out .= $expstring;
 562                 }
 563                 $out .= '; secure' if $secure;
 564                 $out .= '; HttpOnly' if $::Pragma->{set_httponly};
 565                 $out .= "\r\n";
 566         }
 567         return $out;
 568 }
 569
 570 sub canon_status {
 571         local($_);
 572         $_ = shift;
 573         s:^\s+::;
 574         s:\s+$::;
 575         s:\s*\n\s*:\r\n:g;
 576         return "$_\r\n";
 577 }
 578
 579 sub get_cache_headers {
 580         my @headers;
 581
 582         my $cc = $::Pragma->{cache_control};
 583         push @headers, "Cache-Control: $cc" if $cc;
 584
 585         push @headers, "Pragma: no-cache" if delete $::Scratch->{mv_no_cache};
 586
 587         return @headers;
 588 }
 589
 590 sub add_cache_headers {
 591         return unless my @headers = get_cache_headers();
 592
 593         $Vend::StatusLine .= "\r\n" unless $Vend::StatusLine =~ /\n\z/;
 594         $Vend::StatusLine .= "$_\r\n" for @headers;
 595         return 1;
 596 }
 597
 598 sub respond {
 599         # $body is now a reference
 600         my ($s, $body) = @_;
 601 #show_times("begin response send") if $Global::ShowTimes;
 602
 603         # Safe kludge: duplicate Vend::CharSet::default_charset method here
 604         # so that $Document->send() will work from within Safe
 605         my $c = $Global::Selector{$CGI::script_name};
 606         my $response_charset = $c->{Variable}{MV_HTTP_CHARSET} || $Global::Variable->{MV_HTTP_CHARSET};
 607
 608         my $status;
 609         return if $Vend::Sent;
 610         if($Vend::StatusLine) {
 611                 $status = $Vend::StatusLine =~ /(?:^|\n)Status:\s+(.*)/i
 612                                 ? "$1"
 613                                 : "200 OK";
 614         }
 615
 616         if($CGI::redirect_status and ! $Vend::StatusLine) {
 617                 $status = "200 OK";
 618                 $Vend::StatusLine = "Status: 200 OK\nContent-Type: text/html";
 619         }
 620
 621         $$body =~ s/^\s+//
 622                 if ! $Vend::ResponseMade and $::Pragma->{strip_white};
 623
 624         $Vend::StatusLine =~ s/\s*$/\r\n/ if $Vend::StatusLine;
 625
 626         # NOTE: if we're supporting arbitrary encodings here in the
 627         # response_charset, we should really be setting the binmode to
 628         # :encoding($response_charset);  if we're considering the case of
 629         # UTF-8 vs undeclared, we should set the response charset to UTF-8
 630         # iff MV_UTF8 is set, otherwise omit the charset declaration
 631         # entirely.
 632
 633         if (
 634                 $response_charset =~ /^utf-?8$/i
 635                 and (
 636                         ! $Vend::StatusLine
 637                         or $Vend::StatusLine =~ m{^Content-Type: text/}i
 638                 )
 639         ) {
 640                 binmode(MESSAGE, ':utf8');
 641         }
 642
 643         if(! $s and $Vend::StatusLine) {
 644                 if ($Vend::StatusLine !~ /^Content-Type:/im) {
 645                 $Vend::StatusLine .= "\r\nContent-Type: text/html";
 646                 if ($response_charset) {
 647                         $Vend::StatusLine .= "; charset=$response_charset\r\n";
 648                 }
 649
 650                 else {
 651                         $Vend::StatusLine .= "\r\n";
 652                 }
 653         }
 654
 655 # TRACK
 656                 $Vend::StatusLine .= "X-Track: " . $Vend::Track->header() . "\r\n"
 657                         if $Vend::Track and $Vend::Cfg->{UserTrack};
 658 # END TRACK
 659
 660                 add_cache_headers();
 661
 662                 print MESSAGE canon_status($Vend::StatusLine);
 663                 print MESSAGE "\r\n";
 664                 print MESSAGE $$body;
 665                 undef $Vend::StatusLine;
 666                 $Vend::ResponseMade = 1;
 667 #show_times("end response send") if $Global::ShowTimes;
 668                 return;
 669         }
 670
 671         my $fh = $s->{fh};
 672
 673 # SUNOSDIGITAL
 674 #        Fix for SunOS, Ultrix, Digital UNIX
 675 #       my($oldfh) = select($fh);
 676 #       $| = 1;
 677 #       select($oldfh);
 678 # END SUNOSDIGITAL
 679
 680         my $rfh = $s->{rfh};
 681         if($Vend::write_redirect and ! $rfh) {
 682                 $rfh = gensym();
 683                 my $fn = $Vend::Cfg->{RedirectCache} . $CGI::path_info;
 684                 my $save = umask(022);
 685                 open $rfh, "> $fn"
 686                         or do {
 687                                 ::logError("Unable to write redirected page %s: %s", $fn, $!);
 688                                 undef $Vend::write_redirect;
 689                                 undef $rfh;
 690                         };
 691                 $s->{rfh} = $rfh;
 692                 umask $save;
 693         }
 694
 695         if($Vend::ResponseMade || $CGI::values{mv_no_header} ) {
 696                 print $fh $$body;
 697                 print $rfh $$body if $rfh;
 698 #show_times("end response send") if $Global::ShowTimes;
 699                 return 1;
 700         }
 701
 702         if (defined $ENV{MOD_PERL} or $CGI::script_name =~ m:/nph-[^/]+$:) {
 703 # TRACK
 704                 my $save = select $fh;
 705                 $| = 1;
 706                 select $save;
 707                 $Vend::StatusLine .= "\r\nX-Track: " . $Vend::Track->header() . "\r\n"
 708                         if $Vend::Track and $Vend::Cfg->{UserTrack};
 709 # END TRACK
 710
 711                 add_cache_headers();
 712
 713                 $status = '200 OK' if ! $status;
 714                 if(defined $Vend::StatusLine) {
 715                         $Vend::StatusLine = "HTTP/1.0 $status\r\n$Vend::StatusLine"
 716                                 if $Vend::StatusLine !~ m{^HTTP/};
 717                         print $fh canon_status($Vend::StatusLine);
 718                         $Vend::ResponseMade = 1;
 719                         undef $Vend::StatusLine;
 720                 }
 721                 else { print $fh "HTTP/1.0 $status\r\n"; }
 722         }
 723
 724         if ( ! $Vend::tmp_session
 725                 and (
 726                         ! $Vend::CookieID && ! $::Instance->{CookiesSet}
 727                         or defined $Vend::Expire
 728                         or defined $::Instance->{Cookies}
 729                   )
 730                         and $Vend::Cfg->{Cookies}
 731                 )
 732         {
 733                 my @domains;
 734                 @domains = ('');
 735                 my @paths;
 736                 @paths = ('/');
 737
 738                 if ($Vend::Cfg->{CookieDomain}) {
 739                         @domains = split /\s+/, $Vend::Cfg->{CookieDomain};
 740                 }
 741                 elsif($Global::Mall) {
 742                         my $ref = $Global::Catalog{$Vend::Cat};
 743                         @paths = ($ref->{script});
 744                         push (@paths, @{$ref->{alias}}) if defined $ref->{alias};
 745                         if ($Global::FullUrl) {
 746                                 # remove domain from script
 747                                 my %pathhash;
 748                                 for (@paths) {
 749                                         s:^[^/]+/:/: or $_ = '/';
 750                                         $pathhash{$_} = 1;
 751                                 }
 752                                 @paths = keys(%pathhash);
 753                         }
 754                 }
 755
 756                 my ($d, $p);
 757                 foreach $d (@domains) {
 758                         foreach $p (@paths) {
 759                                 print $fh create_cookie($d, $p);
 760                         }
 761                 }
 762                 $::Instance->{CookiesSet} = delete $::Instance->{Cookies};
 763         }
 764
 765         if (defined $Vend::StatusLine) {
 766                 print $fh canon_status($Vend::StatusLine);
 767         }
 768         elsif(! $Vend::ResponseMade) {
 769                 if ($response_charset) {
 770                         print $fh canon_status("Content-Type: text/html; charset=$response_charset");
 771                 }
 772                 else {
 773                         print $fh canon_status("Content-Type: text/html");
 774                 }
 775 # TRACK
 776                 print $fh canon_status("X-Track: " . $Vend::Track->header())
 777                         if $Vend::Track and $Vend::Cfg->{UserTrack};
 778 # END TRACK
 779         }
 780
 781         print $fh canon_status($_) for get_cache_headers();
 782
 783         print $fh "\r\n";
 784         print $fh $$body;
 785         print $rfh $$body if $rfh;
 786 #show_times("end response send") if $Global::ShowTimes;
 787         $Vend::ResponseMade = 1;
 788 }
 789
 790 sub _read {
 791     my ($in, $fh) = @_;
 792         $fh = \*MESSAGE if ! $fh;
 793     my ($r,$rin);
 794
 795     vec($rin,fileno($fh),1) = 1;
 796
 797     do {
 798         if (($r = select($rin, undef, undef, $Global::SocketReadTimeout || 1)) > 0) {
 799             # read up to an arbitrary 1 MiB at a time for efficiency
 800             # (though the operating system may provide far less than that at a time anyway)
 801             $r = sysread($fh, $$in, 1_048_576, length($$in));
 802         }
 803     } while ((!defined($r) || $r == -1) && ($!{eintr} || $!{eagain}));
 804
 805     die "read: $!" unless defined $r;
 806     die "read: closed" unless $r > 0;
 807 }
 808
 809 sub _find {
 810     my ($in, $char) = @_;
 811     my ($x);
 812
 813     _read($in) while (($x = index($$in, $char)) == -1);
 814     my $before = substr($$in, 0, $x);
 815     substr($$in, 0, $x + 1) = '';
 816     $before;
 817 }
 818
 819 sub _string {
 820     my ($in) = @_;
 821     my $len = _find($in, " ");
 822     _read($in) while (length($$in) < $len + 1);
 823     my $str = substr($$in, 0, $len);
 824     substr($$in, 0, $len + 1) = '';
 825     $str;
 826 }
 827
 828 my $HTTP_enabled;
 829 my $Remote_addr;
 830 my %CGImap;
 831
 832 BEGIN {
 833         eval {
 834                 require URI::URL;
 835                 require MIME::Base64;
 836                 $HTTP_enabled = 1;
 837                 %CGImap = ( qw/
 838                                 content-length       CONTENT_LENGTH
 839                                 content-type         CONTENT_TYPE
 840                 authorization-type   AUTH_TYPE
 841                 authorization        AUTHORIZATION
 842                                 cookie               HTTP_COOKIE
 843                 client-hostname      REMOTE_HOST
 844                 client-ip-address    REMOTE_ADDR
 845                 client-ident         REMOTE_IDENT
 846                 content-length       CONTENT_LENGTH
 847                 content-type         CONTENT_TYPE
 848                 cookie               HTTP_COOKIE
 849                 from                 HTTP_FROM
 850                 host                 HTTP_HOST
 851                 https-on             HTTPS
 852                 method               REQUEST_METHOD
 853                 path-info            PATH_INFO
 854                 path-translated      PATH_TRANSLATED
 855                 pragma               HTTP_PRAGMA
 856                 query                QUERY_STRING
 857                 reconfigure          RECONFIGURE_MINIVEND
 858                 referer              HTTP_REFERER
 859                 script               SCRIPT_NAME
 860                 server-host          SERVER_NAME
 861                 server-port          SERVER_PORT
 862                 user-agent           HTTP_USER_AGENT
 863                 content-encoding     HTTP_CONTENT_ENCODING
 864                 content-language     HTTP_CONTENT_LANGUAGE
 865                 content-transfer-encoding HTTP_CONTENT_TRANSFER_ENCODING
 866
 867                                         /
 868                 );
 869         };
 870
 871 }
 872
 873 sub http_log_msg {
 874         my($status, $env, $request) = @_;
 875         my(@params);
 876
 877         # IP, Session, REMOTE_USER (if any) and time
 878     push @params, ($$env{REMOTE_HOST} || $$env{REMOTE_ADDR});
 879         push @params, ($$env{SERVER_PORT} || '-');
 880         push @params, ($$env{REMOTE_USER} || '-');
 881         push @params, logtime();
 882
 883         # Catalog name
 884         push @params, qq{"$request"};
 885
 886         push @params, $status;
 887
 888         push @params, '-';
 889         return join " ", @params;
 890 }
 891
 892 sub http_soap {
 893         my($fh, $env, $entity) = @_;
 894
 895         my $in = '';
 896         die "Need URI::URL for this functionality.\n"
 897                 unless defined $HTTP_enabled;
 898
 899         my ($real_header, $header, $request, $block);
 900         my $waiting = 0;
 901         my $status_line = _find(\$in, "\n");
 902 #::logDebug("status_line: $status_line");
 903         ($$env{REQUEST_METHOD},$request) = split /\s+/, $status_line;
 904         for(;;) {
 905         $block = _find(\$in, "\n");
 906 #::logDebug("read: $block");
 907                 $block =~ s/\s+$//;
 908                 if($block eq '') {
 909                         last;
 910                 }
 911                 if ( $block =~ s/^([^:]+):\s*//) {
 912                         $real_header = $1;
 913                         $header = lc $1;
 914
 915                         if(defined $CGImap{$header}) {
 916 #::logDebug("setting env{$CGImap{$header}} to: $block");
 917                                 $$env{$CGImap{$header}} = $block;
 918                         }
 919                         $$env{$real_header} = $block;
 920                         next;
 921                 }
 922                 else {
 923                         die "HTTP protocol error on '$block':\n$in";
 924                 }
 925                 last;
 926         }
 927
 928         if ($$env{CONTENT_LENGTH}) {
 929                 _read(\$in) while length($in) < $$env{CONTENT_LENGTH};
 930 #::logDebug("read entity: $in");
 931         }
 932         $in =~ s/\s+$//;
 933         $$entity = $in;
 934
 935 #::logDebug("exiting loop");
 936         my $url = new URI::URL $request;
 937
 938         (undef, $Remote_addr) =
 939                                 sockaddr_in(getpeername($fh));
 940         if ($Global::HostnameLookups) {
 941                 $$env{REMOTE_HOST} = gethostbyaddr($Remote_addr, AF_INET);
 942         }
 943         $Remote_addr = inet_ntoa($Remote_addr);
 944
 945         $$env{REMOTE_ADDR} = $Remote_addr;
 946
 947         my (@path) = $url->path_components();
 948         my $doc;
 949         my $status = 200;
 950
 951         shift(@path);
 952         my $catname = '/'.shift(@path);
 953         $$env{SESSION_ID} = shift(@path);
 954
 955 #::logDebug("catname is $catname");
 956
 957         if($Global::Selector{$catname} and $Global::AllowGlobal->{$catname}) {
 958                 if ($$env{AUTHORIZATION}) {
 959                         $$env{REMOTE_USER} =
 960                                         Vend::Util::check_authorization( delete $$env{AUTHORIZATION} );
 961                 }
 962                 return undef if ! $$env{REMOTE_USER};
 963         }
 964
 965         my $ref;
 966         if($ref = $Global::Selector{$catname} || $Global::SelectorAlias{$catname}) {
 967 #::logDebug("found catalog $catname");
 968                 $$env{SCRIPT_NAME} = $catname;
 969         } else {
 970                 $status = 404;
 971         }
 972
 973         logData("$Global::VendRoot/etc/access_log",
 974                         http_log_msg(
 975                                                 "SOAP$status",
 976                                                 $env,
 977                                                 ($$env{REQUEST_METHOD} .  " " .  $request),
 978                                                 )
 979                 );
 980
 981         populate($env);
 982         map_misc_cgi();
 983         return $ref;
 984 }
 985
 986 sub read_cgi_data {
 987     my ($argv, $env, $entity) = @_;
 988     my ($in, $block, $n, $i, $e, $key, $value);
 989     $in = '';
 990
 991     for (;;) {
 992         $block = _find(\$in, "\n");
 993                 if (($n) = ($block =~ m/^env (\d+)$/)) {
 994             foreach $i (0 .. $n - 1) {
 995                 $e = _string(\$in);
 996                 if (($key, $value) = ($e =~ m/^([^=]+)=(.*)$/s)) {
 997                     $$env{$key} = $value;
 998                 }
 999             }
1000         }
1001                 elsif ($block =~ m/^end$/) {
1002             last;
1003         }
1004                 elsif ($block =~ m/^entity$/) {
1005             $$entity = _string(\$in);
1006                 }
1007                 elsif (($n) = ($block =~ m/^arg (\d+)$/)) {
1008             $#$argv = $n - 1;
1009             foreach $i (0 .. $n - 1) {
1010                 $$argv[$i] = _string(\$in);
1011             }
1012         }
1013                 else {
1014                         die "Unrecognized block: $block\n";
1015         }
1016     }
1017         return 1;
1018 }
1019
1020
1021 sub connection {
1022     my $show_in_ps = shift;
1023
1024     my (%env, $entity);
1025
1026     set_process_name('connection');
1027
1028     ### This resets all $Vend::variable settings so we start
1029     ### completely initialized. It only affects the Vend package,
1030     ### not any Vend::XXX packages.
1031     reset_vars();
1032
1033     if($Global::ShowTimes) {
1034         @Vend::Times = times();
1035         ::logDebug ("begin connection. Summary time set to zero");
1036     }
1037     read_cgi_data(\@Global::argv, \%env, \$entity)
1038         or return 0;
1039     show_times('end cgi read') if $Global::ShowTimes;
1040
1041     # NOTE to self: this may not be necessary, but not sure of the scoping of MESSAGE
1042     binmode(MESSAGE, ':raw');
1043
1044     my $http = new Vend::Server \*MESSAGE, \%env, \$entity;
1045
1046     # Can log all CGI inputs
1047     log_http_data($http) if $Global::Logging;
1048
1049     set_process_name('dispatch');
1050
1051     show_times("begin dispatch") if $Global::ShowTimes;
1052     ::dispatch($http) if $http;
1053     show_times("end connection") if $Global::ShowTimes;
1054     close $http->{rfh} if $http->{rfh};
1055     undef $Vend::Cfg;
1056
1057     my $display = 'done';
1058     $display .= "($show_in_ps)" if $show_in_ps;
1059
1060     set_process_name($display);
1061
1062     Sys::Syslog::closelog(), undef $Vend::SysLogReady
1063         if $Vend::SysLogReady;
1064
1065     return;
1066 }
1067
1068 ## Signals
1069
1070 my $Signal_Terminate;
1071 my $Signal_Restart;
1072 my %orig_signal;
1073 my @trapped_signals = qw(INT TERM);
1074
1075
1076 my $ipc;
1077 my $tick;
1078
1079 my %fh_map;
1080 my %vec_map;
1081
1082 my %s_vec_map;
1083 my %s_fh_map;
1084
1085 my %ipc_socket;
1086 my %unix_socket;
1087
1088 use vars qw(
1089                         $Num_servers
1090                         $Page_servers
1091                         %Page_pids
1092                         %Starting_pids
1093                         $Starting_pids
1094                         @Termed_pids
1095                         $SOAP_servers
1096                         %SOAP_pids
1097                         $Job_servers
1098                         %Lifetime
1099                         $vector
1100                         $p_vector
1101                         $s_vector
1102                         $ipc_vector
1103                         );
1104 BEGIN {
1105         $s_vector = '';
1106 }
1107 $Starting_pids = 0;
1108 $Num_servers = 0;
1109 $SOAP_servers = 0;
1110 $Job_servers = 0;
1111 %Lifetime = ();
1112
1113 # might also trap: QUIT
1114
1115 my ($Routine_USR1, $Routine_USR2, $Routine_HUP, $Routine_TERM, $Routine_INT);
1116 my ($Sig_inc, $Sig_dec, $Counter);
1117
1118 sub sig_int_or_term {
1119         $Signal_Terminate = 1;
1120
1121         my (%seen, $all_gone);
1122
1123         my @pids =
1124                 grep { !$seen{$_}++ }
1125                         (keys %Page_pids, keys %Starting_pids);
1126
1127         for (1..3) {
1128                 $all_gone = ! kill TERM => @pids
1129                         and last;
1130                 select (undef, undef, undef, 0.5);
1131         }
1132
1133         kill KILL => @pids
1134                 unless $all_gone;
1135
1136         return;
1137 }
1138
1139 unless ($Global::Windows) {
1140         push @trapped_signals, qw(HUP USR1 USR2);
1141         $Routine_USR1 = sub { $SIG{USR1} = $Routine_USR1; $Num_servers++};
1142         $Routine_USR2 = sub { $SIG{USR2} = $Routine_USR2; $Num_servers--};
1143         $Routine_HUP  = sub { $SIG{HUP} = $Routine_HUP; $Signal_Restart = 1};
1144 }
1145
1146 $Routine_TERM = sub { $SIG{TERM} = $Routine_TERM; $Signal_Terminate = 1 };
1147 $Routine_INT  = sub { $SIG{INT} = $Routine_INT; $Signal_Terminate = 1 };
1148
1149 sub reset_vars {
1150         package Vend;
1151         reset 'A-Z';
1152         reset 'a-z';
1153         package CGI;
1154         reset 'A-Z';
1155         reset 'a-z';
1156         undef %Vend::Table::DBI::DBI_connect_cache;
1157         undef %Vend::Table::DBI::DBI_connect_bad;
1158         undef %Vend::Table::DBI::DBI_connect_count;
1159         srand();
1160 #::logDebug("Reset vars");
1161 }
1162
1163 sub reset_per_fork {
1164         undef %Vend::Table::DBI::DBI_connect_cache;
1165         undef %Vend::Table::DBI::DBI_connect_bad;
1166         undef %Vend::Table::DBI::DBI_connect_count;
1167 }
1168
1169 sub clean_up_after_fork {
1170         for(values %Vend::Table::DBI::DBI_connect_cache) {
1171                 next if ! ref $_;
1172                 $_->disconnect();
1173         }
1174         %Vend::Table::DBI::DBI_connect_cache = ();
1175         %Vend::Table::DBI::DBI_connect_bad = ();
1176 }
1177
1178 sub setup_signals {
1179         @orig_signal{@trapped_signals} =
1180                 map(defined $_ ? $_ : 'DEFAULT', @SIG{@trapped_signals});
1181         $Signal_Terminate = '';
1182         $SIG{PIPE} = 'IGNORE';
1183         $SIG{CHLD} = 'IGNORE'
1184                 if $Global::PreFork && $Global::PreForkSingleFork;
1185
1186         if ($Global::Windows) {
1187                 $SIG{INT}  = \&sig_int_or_term;
1188                 $SIG{TERM} = \&sig_int_or_term;
1189         }
1190         else  {
1191                 $SIG{INT}  = \&sig_int_or_term;
1192                 $SIG{TERM} = \&sig_int_or_term;
1193                 $SIG{HUP}  = sub { $Signal_Restart = 1; };
1194                 $SIG{USR1} = sub { $Num_servers++; };
1195                 $SIG{USR2} = sub { $Num_servers--; };
1196         }
1197
1198         if(! $Global::MaxServers) {
1199         $Sig_inc = sub { 1 };
1200         $Sig_dec = sub { 1 };
1201         }
1202     else {
1203         $Sig_inc = sub { kill "USR1", $Vend::MasterProcess || 0; };
1204         $Sig_dec = sub { kill "USR2", $Vend::MasterProcess || 0; };
1205     }
1206 }
1207
1208 sub restore_signals {
1209     @SIG{@trapped_signals} = @orig_signal{@trapped_signals};
1210 }
1211
1212 my $Last_housekeeping = 0;
1213
1214 # Reconfigure any catalogs that have requested it, and
1215 # check to make sure we haven't too many running servers
1216 sub housekeeping {
1217         my ($interval) = @_;
1218         my $now = time;
1219
1220 #::logDebug("called housekeeping");
1221         return if defined $interval and ($now - $Last_housekeeping < $interval);
1222
1223         my $do;
1224         my $do_before;
1225         my $do_after;
1226         my $cronjobs;
1227
1228         if($Global::HouseKeepingCron) {
1229                 ($do, $do_before, $do_after, $cronjobs) = Vend::Cron::housekeeping($now);
1230         }
1231         else {
1232                 $do = {
1233                         restart => 1,
1234                         reconfig => 1,
1235                         jobs => 1,
1236                 };
1237         }
1238
1239 #::logDebug("actually doing housekeeping interval=$interval now=$now last=$Last_housekeeping");
1240         rand();
1241         $Last_housekeeping = $now;
1242
1243         my ($c, $num,$reconfig, $restart, $jobs, @files, @pidcheck_pids);
1244
1245                 if($Global::PreFork) {
1246                         my @starting_pids = keys %Starting_pids;
1247                         my $starting_count = starting_pids('count');
1248                         my %bad_pids;
1249                         my @active_pids = keys %Page_pids;
1250                         my $active_count = scalar @active_pids;
1251                         my $check_time = time();
1252                         my $start_max_time = 30;
1253
1254                         for my $pid (@starting_pids) {
1255                                 my $time_taken = $check_time - $Starting_pids{$pid};
1256                                 if ($time_taken > $start_max_time) {
1257                                         ::logDebug("pid $pid took $time_taken seconds to start ($start_max_time allowed); scheduling for death");
1258                                         $bad_pids{$pid} = undef;
1259                                         delete $Starting_pids{$pid};
1260                                         --$starting_count;
1261                                 }
1262                         }
1263
1264                         while ($active_count > ($Global::StartServers + 1) ) {
1265 #::logDebug("too many pids ($active_count)");
1266                                 my $bad = shift @active_pids;
1267 #::logDebug("scheduling %s for death", $bad);
1268                                 $bad_pids{$bad} = undef;
1269                                 --$active_count;
1270                         }
1271
1272                         foreach my $pid (@active_pids) {
1273                                 kill(0, $pid) and next;
1274 #::logDebug("Non-existent server at PID %s", $pid);
1275                                 delete $Page_pids{$pid};
1276                                 --$active_count;
1277                         }
1278
1279                         if ($Global::PIDcheck) {
1280                                 for my $pid (keys %Page_pids) {
1281                                         my $pid_stats = $Page_pids{$pid};
1282                                         my $last_use = $check_time - $pid_stats->[0];
1283                                         next unless $last_use > $Global::PIDcheck;
1284 #::logDebug('pid %s last used %d seconds ago', $pid, $last_use);
1285                                         if ($pid_stats->[1]) {
1286                                                 $bad_pids{$pid} = undef;
1287                                                 delete $Page_pids{$pid};
1288 #::logDebug('scheduling %s for death', $pid);
1289                                                 --$active_count;
1290                                         }
1291                                         else {
1292                                                 $pid_stats->[0] = time;
1293                                         }
1294                                 }
1295                         }
1296
1297                         if ($active_count + $starting_count < $Global::StartServers) {
1298                                 my $server_deficit =
1299                                         $Global::StartServers
1300                                         - $active_count
1301                                         - $starting_count;
1302                                 ::logGlobal("Spawning %d page server%s to reach %s StartServers", $server_deficit, $server_deficit == 1 ? '' : 's', $Global::StartServers);
1303                                 start_page(undef, $Global::PreFork, $server_deficit);
1304                         }
1305
1306                         for my $pid (@Termed_pids) {
1307                                 kill (KILL => $pid)
1308                                         and ::logDebug("Sent $pid a KILL");
1309                         }
1310                         ::logGlobal("page server pid %s won't die!", $_)
1311                                         for grep { kill (0, $_) } @Termed_pids;
1312                         @Termed_pids = ();
1313
1314                         if (%bad_pids) {
1315 #::logDebug("Killing excess, old, or unresponsive servers");
1316                                 delete @Page_pids{ keys %bad_pids };
1317
1318                                 for my $pid
1319                                         ( grep
1320                                                 { kill (0, $_) or delete $bad_pids{$_} }
1321                                                 keys %bad_pids
1322                                         )
1323                                 {
1324                                         kill (TERM => $pid);
1325                                         ::logDebug("Sent $pid a TERM");
1326                                         push (@Termed_pids, $pid);
1327                                 }
1328                         }
1329                 }
1330
1331                 opendir(Vend::Server::CHECKRUN, $Global::RunDir)
1332                         or die "opendir $Global::RunDir: $!\n";
1333                 @files = readdir Vend::Server::CHECKRUN;
1334                 closedir(Vend::Server::CHECKRUN)
1335                         or die "closedir $Global::RunDir: $!\n";
1336                 ($reconfig) = grep $_ eq 'reconfig', @files
1337                         if $do->{reconfig};
1338                 ($restart) = grep $_ eq 'restart', @files
1339                         if $Signal_Restart || $Global::Windows;
1340                 ($jobs) = grep $_ eq 'jobsqueue', @files
1341                         if $do->{jobs};
1342
1343                 if($do_before) {
1344                         for(@$do_before) {
1345 #::logDebug("run before macro $_");
1346                                 eval {
1347                                         Vend::Dispatch::run_macro($_);
1348                                 };
1349                                 if($@) {
1350                                         ::logGlobal("cron before macro '%s' failed: %s", $_, $@);
1351                                 }
1352                         }
1353                 }
1354
1355                 if($Global::PIDcheck) {
1356                         $Num_servers = 0;
1357                         @pidcheck_pids = grep /^pid\.\d+$/, @files;
1358                 }
1359
1360                 my $respawn;
1361
1362                 if (defined $restart) {
1363                         $Signal_Restart = 0;
1364                         open(Vend::Server::RESTART, "+<$Global::RunDir/restart")
1365                                 or die "open $Global::RunDir/restart: $!\n";
1366                         lockfile(\*Vend::Server::RESTART, 1, 1)
1367                                 or die "lock $Global::RunDir/restart: $!\n";
1368                         while(<Vend::Server::RESTART>) {
1369                                 chomp;
1370 #::logDebug("restart file reads line '$_'");
1371                                 my ($directive,$value) = split /\s+/, $_, 2;
1372                                 if($value =~ /<<(.*)/) {
1373                                         my $mark = $1;
1374                                         $value = Vend::Config::read_here(\*Vend::Server::RESTART, $mark);
1375                                         unless (defined $value) {
1376                                                 ::logGlobal({ level => 'notice'}, <<EOF, $mark);
1377 Global reconfig ERROR
1378 Can't find string terminator "%s" anywhere before EOF.
1379 EOF
1380                                                 last;
1381                                         }
1382                                         chomp $value;
1383 #::logDebug("restart file reads value '$value'");
1384                                 }
1385                                 eval {
1386                                         if($directive =~ /^\s*(sub)?catalog$/i) {
1387                                                 ::add_catalog("$directive $value");
1388                                         }
1389                                         elsif(
1390                                                         $directive =~ /^remove$/i               and
1391                                                         $value =~ /catalog\s+(\S+)/i
1392                                                 )
1393                                         {
1394                                                 ::remove_catalog($1);
1395                                         }
1396                                         elsif( $directive =~ /^usertag$/i) {
1397                                                 Vend::Config::code_from_file($directive, $value, 'nohup');
1398                                         }
1399                                         elsif( $directive =~ /^codedef$/i) {
1400                                                 ($directive, $value) = split /\s+/, $value, 2;
1401                                                 Vend::Config::code_from_file($directive, $value, 'nohup');
1402                                         }
1403                                         else {
1404                                                 ::change_global_directive("$directive $value");
1405                                         }
1406                                 };
1407                                 if($@) {
1408                                         ::logGlobal({ level => 'notice' }, $@);
1409                                         last;
1410                                 }
1411                         }
1412                         unlockfile(\*Vend::Server::RESTART)
1413                                 or die "unlock $Global::RunDir/restart: $!\n";
1414                         close(Vend::Server::RESTART)
1415                                 or die "close $Global::RunDir/restart: $!\n";
1416                         unlink "$Global::RunDir/restart"
1417                                 or die "unlink $Global::RunDir/restart: $!\n";
1418                         $respawn = 1;
1419                 }
1420                 if (defined $reconfig) {
1421                         open(Vend::Server::RECONFIG, "+<$Global::RunDir/reconfig")
1422                                 or die "open $Global::RunDir/reconfig: $!\n";
1423                         lockfile(\*Vend::Server::RECONFIG, 1, 1)
1424                                 or die "lock $Global::RunDir/reconfig: $!\n";
1425                         while(<Vend::Server::RECONFIG>) {
1426                                 chomp;
1427                                 my ($script_name,$table,$cfile) = split /\s+/, $_, 3;
1428                                 my $select = $Global::SelectorAlias{$script_name} || $script_name;
1429                 my $cat = $Global::Selector{$select};
1430                 unless (defined $cat) {
1431                     ::logGlobal({ level => 'notice' }, "Bad script name '%s' for reconfig." , $script_name );
1432                     next;
1433                 }
1434
1435                                 eval {
1436                                         $c = Vend::Config::config_named_catalog(
1437                                                                         $cat->{CatalogName},
1438                                     "from running server ($$)",
1439                                                                         $table,
1440                                                                         $cfile
1441                                                                 );
1442                                 };
1443
1444                                 if (defined $c) {
1445                                         $Global::Selector{$select} = $c;
1446                                         for(sort keys %Global::SelectorAlias) {
1447                                                 next unless $Global::SelectorAlias{$_} eq $select;
1448                                                 $Global::Selector{$_} = $c;
1449                                         }
1450                                         ::logGlobal({ level => 'notice' }, "Reconfig of %s successful.", $c->{CatalogName});
1451                                 }
1452                                 else {
1453                                         ::logGlobal({ level => 'warn' },
1454                                                  "Error reconfiguring catalog %s from running server (%s)\n%s",
1455                                                  $script_name,
1456                                                  $$,
1457                                                  $@,
1458                                                  );
1459                                 }
1460                         }
1461                         unlockfile(\*Vend::Server::RECONFIG)
1462                                 or die "unlock $Global::RunDir/reconfig: $!\n";
1463                         close(Vend::Server::RECONFIG)
1464                                 or die "close $Global::RunDir/reconfig: $!\n";
1465                         unlink "$Global::RunDir/reconfig"
1466                                 or die "unlink $Global::RunDir/reconfig: $!\n";
1467                         $respawn = 1;
1468
1469                 }
1470                 if (defined $jobs) {
1471                         my (@scheduled_jobs, @queued_jobs);
1472                         open(Vend::Server::JOBS, "+<$Global::RunDir/jobsqueue")
1473                                 or die "open $Global::RunDir/jobsqueue: $!\n";
1474                         lockfile(\*Vend::Server::JOBS, 1, 1)
1475                                 or die "lock $Global::RunDir/jobsqueue: $!\n";
1476                         while(<Vend::Server::JOBS>) {
1477                                 chomp;
1478                                 my ($directive,$value) = split /\s+/, $_, 2;
1479                                 my ($cat, $delay, $jobname, @params) = grep /\S/, split /[\s,\0]+/, $value;
1480                                 if ($delay && $delay < time()) {
1481                                         # job expired
1482 #::logDebug ("Jobs expired ($delay vs $now)\n");
1483                                 } elsif ($Job_servers++ >= $Global::Jobs->{MaxServers}) {
1484                                                 # no slot for job
1485                                                 $Job_servers--;
1486 #::logDebug ("Jobs queued, already %d jobs running/scheduled", $Job_servers);
1487                         push(@queued_jobs, "$directive $value");
1488                 } else {
1489 #::logDebug ("Scheduled job for running");
1490                                         my %p;
1491                                         for (@params) {
1492                                             my ($name, $value) = split /\=/, $_, 2;
1493                                                 $p{$name} = $value;
1494                                         }
1495                                         push (@scheduled_jobs, [$cat, $jobname, \%p]);
1496                                 }
1497                 if (@queued_jobs > 20) {
1498                                         ::logGlobal({ level => 'notice' }, "Excessive size of job queue, stopping");
1499                                         last;
1500                                 }
1501                         }
1502
1503                         truncate(Vend::Server::JOBS, 0)
1504                                 or die "truncate $Global::RunDir/jobsqueue: $!\n";
1505             seek(Vend::Server::JOBS, 0, 0)
1506                 or die "seek $Global::RunDir/jobsqueue: $!\n";
1507
1508             if (@queued_jobs) {
1509 #::logDebug("Size of queue $$: %s", scalar(@queued_jobs));
1510                                 print Vend::Server::JOBS join("\n", @queued_jobs, '');
1511                 unlockfile(\*Vend::Server::JOBS)
1512                                         or die "unlock $Global::RunDir/jobsqueue: $!\n";
1513                                 close(Vend::Server::JOBS)
1514                                         or die "close $Global::RunDir/jobsqueue: $!\n";
1515                         } else {
1516                                 unlockfile(\*Vend::Server::JOBS)
1517                                         or die "unlock $Global::RunDir/jobsqueue: $!\n";
1518                                 close(Vend::Server::JOBS)
1519                                         or die "close $Global::RunDir/jobsqueue: $!\n";
1520                                 unlink "$Global::RunDir/jobsqueue"
1521                                         or die "unlink $Global::RunDir/jobsqueue: $!\n";
1522                         }
1523
1524                         # now we run the scheduled jobs
1525                         for my $jobref (@scheduled_jobs) {
1526                                 eval {
1527                                         run_jobs (@$jobref);
1528                                 };
1529
1530                                 if($@) {
1531                                         ::logGlobal({ level => 'notice' }, $@);
1532                                 }
1533                         }
1534                 }
1535
1536                 if($cronjobs) {
1537                         for(@$cronjobs) {
1538                                 s/^=//;
1539                                 my (@job) = split /[\s,\0]+/, $_;
1540                                 eval {
1541                                         run_jobs (@job);
1542                                 };
1543
1544                                 if($@) {
1545                                         ::logGlobal({ level => 'notice' }, $@);
1546                                 }
1547                         }
1548                 }
1549
1550                 if($do_after) {
1551                         for(@$do_after) {
1552 #::logDebug("would run after macro $_");
1553                                 eval {
1554                                         Vend::Dispatch::run_macro($_);
1555                                 };
1556                                 if($@) {
1557                                         ::logGlobal("cron after macro '%s' failed: %s", $_, $@);
1558                                 }
1559                         }
1560                 }
1561
1562                 if($respawn) {
1563                         if($Global::PreFork) {
1564                                 # We need to respawn all the servers to pick up the new config
1565                                 my @pids = keys %Page_pids;
1566                                 for(@pids) {
1567                                         ::logGlobal(
1568                                                 { level => 'info' },
1569                                                 "respawning page server pid %s to pick up config change",
1570                                                 $_,
1571                                         );
1572                                         (kill 'TERM', $_ and delete $Page_pids{$_})
1573                                                 or ::logGlobal(
1574                                                                 "page server pid %s won't terminate: %s",
1575                                                                 $_,
1576                                                                 $!,
1577                                                         );
1578                                 }
1579                                 start_page(undef, $Global::PreFork, scalar @pids);
1580                         }
1581                         if($Global::SOAP) {
1582                                 # We need to respawn all the SOAP servers to pick up the new config
1583                                 my @pids = keys %SOAP_pids;
1584                                 for(@pids) {
1585                                         ::logGlobal(
1586                                                 { level => 'info' },
1587                                                 "respawning SOAP server pid %s to pick up config change",
1588                                                 $_,
1589                                         );
1590                                         (kill 'TERM', $_ and delete $SOAP_pids{$_})
1591                                                 or ::logGlobal(
1592                                                                 "SOAP server pid %s won't terminate: %s",
1593                                                                 $_,
1594                                                                 $!,
1595                                                         );
1596                                         start_soap(undef,1);
1597                                 }
1598                         }
1599                 }
1600
1601         for (@pidcheck_pids) {
1602             $Num_servers++;
1603             my $fn = "$Global::RunDir/$_";
1604             ($Num_servers--, next) if ! -f $fn;
1605             my $runtime = $now - (stat(_))[9];
1606             s/^pid\.//;
1607             my ($lifetime, $isjob);
1608             if (exists $Lifetime{$_}) {
1609                                 $lifetime = $Lifetime{$_};
1610                                 $isjob = 1;
1611                         } else {
1612                                 $lifetime = $Global::PIDcheck;
1613                         }
1614             next if $runtime < $lifetime;
1615                         my $catname;
1616                         if ($isjob) {
1617                                 # determine catalog name from pid file
1618                                 if (open (JOBPID, $fn)) {
1619                                         $catname = <JOBPID>;
1620                                         chomp($catname);
1621                                         close (JOBPID);
1622                                         delete $Lifetime{$_};
1623                                         $Job_servers--;
1624                                 }
1625                         }
1626
1627             if(kill 9, $_) {
1628                 unlink $fn and $Num_servers--;
1629                                 if ($catname) {
1630                                         ::logGlobal({ level => 'error' }, "hammered job PID %s for catalog $catname running %s seconds", $_, $runtime);
1631                                         flag_job($_, $catname, 'furl');
1632                                 } else {
1633                                         ::logGlobal({ level => 'error' }, "hammered PID %s running %s seconds", $_, $runtime);
1634                                 }
1635             }
1636             elsif (! kill 0, $_) {
1637                                 unlink $fn and $Num_servers--;
1638                 ::logGlobal({ level => 'error' },
1639                                         "Spurious PID file for process %s supposedly running %s seconds",
1640                                                 $_,
1641                                                 $runtime,
1642                                 );
1643                         }
1644             else {
1645                                 unlink $fn and $Num_servers--;
1646                 ::logGlobal({ level => 'crit' },
1647                                         "PID %s running %s seconds would not die!",
1648                                                 $_,
1649                                                 $runtime,
1650                                 );
1651             }
1652         }
1653
1654
1655 }
1656
1657 sub server_start_message {
1658         my ($fmt, $reverse) = @_;
1659         $fmt = 'START server (%s) (%s)' unless $fmt;
1660         my @types;
1661         push (@types, 'INET') if $Global::Inet_Mode;
1662         push (@types, 'UNIX') if $Global::Unix_Mode;
1663         push (@types, 'SOAP') if $Global::SOAP;
1664         push (@types, 'mod_perl') if $Global::mod_perl;
1665         my $server_type = join(" and ", @types);
1666         my $pid = ( $Global::PreFork || $Global::Variable->{MV_BAD_LOCK} )
1667                           ? $$
1668                           : read_pidfile();
1669         my @args = $reverse ? ($server_type, $pid) : ($pid, $server_type);
1670         return ::errmsg ($fmt , @args );
1671 }
1672
1673 sub map_unix_socket {
1674         my ($vec, $vec_map, $fh_map, @files) = @_;
1675
1676         my @made;
1677
1678         foreach my $sockfn (@files) {
1679                 my $fh = gensym();
1680
1681 #::logDebug("starting to parse file socket $sockfn, fh created: $fh");
1682
1683                 eval {
1684                         socket($fh, AF_UNIX, SOCK_STREAM, 0) || die "socket: $!";
1685
1686                         setsockopt($fh, SOL_SOCKET, SO_REUSEADDR, pack("l", 1));
1687
1688                         bind($fh, pack("S", AF_UNIX) . $sockfn . chr(0))
1689                                 or die "Could not bind (open as a socket) '$sockfn':\n$!\n";
1690                         listen($fh,$SOMAXCONN) or die "listen: $!";
1691                 };
1692
1693                 if($@) {
1694                         ::logGlobal({ level => 'error' },
1695                                         "Could not bind to UNIX socket file %s: %s",
1696                                         $sockfn,
1697                                         $!,
1698                                   );
1699                         next;
1700                 }
1701
1702 #::logDebug("made socket $sockfn");
1703                 my $rin = '';
1704                 vec($rin, fileno($fh), 1) = 1;
1705                 $$vec |= $rin;
1706                 $vec_map->{$sockfn} = fileno($fh);
1707                 $fh_map->{$sockfn} = $fh;
1708                 push @made, $sockfn;
1709         }
1710         return @made;
1711 }
1712
1713 sub map_inet_socket {
1714         my ($mode, $vec, $vec_map, $fh_map, @ports) = @_;
1715
1716         my $proto = getprotobyname('tcp');
1717         my @made;
1718
1719         for(@ports) {
1720                 my $fh = gensym();
1721                 my $bind_addr;
1722                 my $bind_port;
1723                 my $bind_ip;
1724 #::logDebug("starting to parse port $_, fh created: $fh");
1725                 if (/^([-\w.]+):(\d+)$/) {
1726                         $bind_ip  = $1;
1727                         $bind_port = $2;
1728                         $bind_addr = inet_aton($bind_ip);
1729                 }
1730                 elsif (/^\d+$/) {
1731                         $bind_ip  = '0.0.0.0';
1732                         $bind_addr = INADDR_ANY;
1733                         $bind_port = $_;
1734                 }
1735                 else {
1736                         ::logGlobal({ level => 'error' },
1737                                         "Unrecognized port type '%s'",
1738                                         $bind_port,
1739                                         $!,
1740                                   );
1741                 }
1742 #::logDebug("Trying to run server on ip=$bind_ip port=$bind_port");
1743                 if(! $bind_addr) {
1744                         ::logGlobal({ level => 'error' },
1745                                         "Could not bind to IP address %s on port %s: %s",
1746                                         $bind_ip,
1747                                         $bind_port,
1748                                         $!,
1749                                   );
1750                         return undef;
1751                 }
1752                 eval {
1753                         socket($fh, PF_INET, SOCK_STREAM, $proto)
1754                                         || die "socket: $!";
1755                         setsockopt($fh, SOL_SOCKET, SO_REUSEADDR, pack("l", 1))
1756                                         || die "setsockopt: $!";
1757                         bind($fh, sockaddr_in($bind_port, $bind_addr))
1758                                         || die "bind: $!";
1759                         listen($fh,$SOMAXCONN)
1760                                         || die "listen: $!";
1761                 };
1762
1763                 if ($@) {
1764                   ::logGlobal({ level => 'error' },
1765                                         "$mode mode server failed to start on IP address %s, port %s: %s",
1766                                         $bind_ip,
1767                                         $bind_port,
1768                                         $@,
1769                                   );
1770                   next;
1771                 }
1772
1773                 my $rin = '';
1774                 vec($rin, fileno($fh), 1) = 1;
1775                 $$vec |= $rin;
1776                 my $port_ptr = "$bind_ip:$bind_port";
1777                 $vec_map->{$port_ptr} = fileno($fh);
1778                 $fh_map->{$port_ptr} = $fh;
1779                 push @made, $port_ptr;
1780 #::logDebug( "Made port $bind_ip:$bind_port\n");
1781         }
1782         return @made;
1783 }
1784
1785 sub create_host_pattern {
1786                 my $host = shift;
1787                 my @hosts = grep /\S/, split /[,\s\|]+/, $host;
1788                 for (@hosts) {
1789                         s/\./\\./g;
1790                         s/\*/[-\\w.]+/g;
1791                 }
1792                 return join "|", @hosts;
1793 }
1794
1795 sub unlink_sockets {
1796         my @to_unlink;
1797         for (@_) {
1798                 if(ref($_)) {
1799                         push @to_unlink, @$_;
1800                 }
1801                 else {
1802                         push @to_unlink, $_;
1803                 }
1804         }
1805
1806         for(@to_unlink) {
1807                 unlink $_ if -S $_;
1808                 if(-S $_) {
1809                         unlink $_
1810                                 or
1811                                 ::logGlobal(
1812                                         {level => 'error'},
1813                                         "Socket file %s cannot be unlinked: %s",
1814                                         $_,
1815                                         $!,
1816                                 );
1817                 }
1818                 elsif(-e _) {
1819                         ::logGlobal(
1820                                 {level => 'error'},
1821                                 "Socket file %s exists and is not a socket, possible error",
1822                                 $_,
1823                         );
1824                 }
1825         }
1826 }
1827
1828 sub start_page {
1829
1830         my ($do_message, $no_fork, $number) = @_;
1831 #::logDebug("entering start_page");
1832
1833         my $current_servers =
1834                 starting_pids('count')
1835                 + scalar (keys %Page_pids);
1836
1837         my $server_deficit = $Global::StartServers - $current_servers;
1838
1839         # Bail immediately if we already have a slate of
1840         # StartServers servers either pending or serving
1841         return 1 if $server_deficit < 1;
1842
1843         # Shave number down to server_deficit if it's greater
1844         $number = $server_deficit if $server_deficit < $number;
1845
1846         if ($number > 150) {
1847                   die ::errmsg(
1848                    "Ridiculously large number of StartServers: %s",
1849                    $number,
1850                    );
1851         }
1852         my $dbl_fork_pid;
1853         my $in_single_fork =
1854                 $no_fork && $Global::PreForkSingleFork;
1855
1856         if (
1857                         $in_single_fork
1858                         or ! ($dbl_fork_pid = fork)
1859                 )
1860         {
1861
1862                 for (1 .. $number) {
1863                         my $pid;
1864                         if(! defined ($pid = fork) ) {
1865                                 my $msg = ::errmsg("Can't fork: %s", $!);
1866                                 ::logGlobal({ level => 'crit' },  $msg );
1867                                 die ("$msg\n");
1868                         }
1869                         elsif (! $pid) {
1870                                 $Global::Foreground = 1 if $no_fork;
1871
1872                                 local $SIG{CHLD} = 'DEFAULT'
1873                                         if $in_single_fork;
1874
1875                                 local $SIG{INT} = $Routine_INT;
1876                                 local $SIG{TERM} = $Routine_TERM;
1877
1878                                 if ($do_message and ! $Vend::Quiet) {
1879                                         ::logGlobal(
1880                                                 { level => 'info'},
1881                                                 server_start_message(
1882                                                         "Interchange page server started (process id %s)",
1883                                                 ),
1884                                         );
1885                                 }
1886
1887                                 send_ipc("register page $$");
1888
1889                                 my $next;
1890                                 srand();
1891                                 $::Instance = {};
1892
1893                                 reset_per_fork();
1894                                 eval {
1895                                         $next = server_page($no_fork);
1896                                 };
1897                                 if ($@) {
1898                                         my $msg = ::errmsg("Server spawn error: %s", $@);
1899                                         ::logGlobal({ level => 'error' }, $msg);
1900                                         ::logError($msg)
1901                                                 if defined $Vend::Cfg->{ErrorFile};
1902                                 }
1903
1904                                 clean_up_after_fork();
1905                                 send_ipc("respawn page $$") if $next;
1906
1907                                 undef $::Instance;
1908                                 exit(0);
1909                         }
1910                         starting_pids('add',$pid)
1911                                 if $in_single_fork;
1912                 }
1913                 $in_single_fork or exit(0);
1914         }
1915
1916         if ($dbl_fork_pid) {
1917                 starting_pids('add',undef,$number);
1918                 wait;
1919         }
1920
1921         return 1;
1922 }
1923
1924 sub start_soap {
1925
1926         my $do_message = shift;
1927         my $number = shift;
1928 #::logDebug("starting soap");
1929
1930         $number = $Global::SOAP_StartServers if ! $number;
1931         if ($number > 150) {
1932                   die ::errmsg(
1933                    "Ridiculously large number of SOAP_StartServers: %s",
1934                    $number,
1935                    );
1936         }
1937         for (1 .. $number) {
1938                 my $pid;
1939                 if(! defined ($pid = fork) ) {
1940                         my $msg = ::errmsg("Can't fork: %s", $!);
1941                         ::logGlobal({ level => 'crit' },  $msg );
1942                         die ("$msg\n");
1943                 }
1944                 elsif (! $pid) {
1945                         unless( $pid = fork ) {
1946                                 setup_debug_log();
1947
1948                                 $Global::Foreground = 1;
1949
1950                                 if($do_message) {
1951                                         ::logGlobal(
1952                                                 { level => 'info'},
1953                                                 server_start_message(
1954                                                         "Interchange SOAP server started (process id %s)",
1955                                                  ),
1956                                          ) unless $Vend::Quiet;
1957                                 }
1958
1959                                 send_ipc("register soap $$");
1960
1961                                 reset_per_fork();
1962                                 my $next;
1963                                 $::Instance = {};
1964                                 eval {
1965                                         $next = server_soap(@_);
1966                                 };
1967                                 if ($@) {
1968                                         my $msg = $@;
1969                                         ::logGlobal({ level => 'error' }, "Runtime error: %s" , $msg);
1970                                         logError("Runtime error: %s", $msg)
1971                                                 if defined $Vend::Cfg->{ErrorFile};
1972                                 }
1973
1974                                 clean_up_after_fork();
1975                                 send_ipc("respawn soap $$")             if $next;
1976
1977                                 undef $::Instance;
1978                                 exit(0);
1979                         }
1980                         exit(0);
1981                 }
1982                 wait;
1983         }
1984         return 1;
1985 }
1986
1987 sub starting_pids {
1988         my ($action,$pid,$n) = @_;
1989
1990         $n ||= 1;
1991         my $in_single_fork =
1992                 $Global::PreFork && $Global::PreForkSingleFork;
1993
1994         if ( $action eq 'count' ) {
1995                 return $in_single_fork
1996                         ? scalar keys %Starting_pids
1997                         : $Starting_pids
1998                 ;
1999         }
2000         elsif ( $action eq 'add' ) {
2001                 $in_single_fork
2002                         ? ($Starting_pids{$pid} = time)
2003                         : ($Starting_pids += $n)
2004                 ;
2005         }
2006         elsif ( $action eq 'del' ) {
2007                 $in_single_fork
2008                         ? delete ($Starting_pids{$pid})
2009                         : ($Starting_pids -= $n)
2010                 ;
2011         }
2012         return;
2013 }
2014
2015 sub server_page {
2016
2017         my ($no_fork) = @_;
2018
2019         my $c = 0;
2020         my $cycle;
2021         my $rin;
2022         my $rout;
2023         my $pid;
2024         my $spawn;
2025         my $start_time = $Global::ChildLife ? time() : 0;
2026         my $end_of_life;
2027         my $handled = 0;
2028
2029         $Global::Foreground ||= $no_fork;
2030
2031 #::logDebug("Start time is $start_time");
2032     for (;;) {
2033
2034           my $n;
2035           my ($ok, $p, $v);
2036           my $i = 0;
2037           $c++;
2038           eval {
2039                 $rin = $p_vector;
2040
2041                 undef $spawn;
2042                 do {
2043                         $n = select($rout = $rin, undef, undef, $tick);
2044                 } while $n == -1 && $!{EINTR} && ! $Signal_Terminate;
2045
2046 #my $pretty_vector = unpack('b*', $rin);
2047 #::logDebug("pid=$$ cycle=$c handled=$handled tick=$tick vector=$pretty_vector n=$n num_servers=$Num_servers");
2048         if ($n == -1) {
2049                         last if $Signal_Terminate;
2050                         my $msg = $!;
2051                         $msg = ::errmsg("error '%s' from select, n=$n." , $msg );
2052                         die "$msg";
2053         }
2054                 elsif($n == 0) {
2055                         undef $spawn;
2056                         if($start_time) {
2057                                 my $current_time = time();
2058                                 next unless $current_time - $start_time > $Global::ChildLife;
2059                                 $end_of_life = 1;
2060                                 last;
2061                         }
2062                         next;
2063                 }
2064         else {
2065
2066             my ($ok, $p, $v);
2067                         while (($p, $v) = each %vec_map) {
2068 #::logDebug("PAGE trying p=$p v=$v vec=" . vec($rout,$v,1) . " pid=$$ c=$c i=" . $i++ );
2069                         next unless vec($rout, $v, 1);
2070 #::logDebug("PAGE accepting p=$p v=$v pid=$$ c=$c i=" . $i++);
2071                                 $Global::TcpPort = $p;
2072                                 $ok = accept(MESSAGE, $fh_map{$p});
2073                                 last;
2074                         }
2075
2076 #::logDebug("PAGE port $Global::TcpPort handled=$handled n=$n v=$v error=$! p=$p unix=$unix_socket{$p} ipc=$ipc_socket{$p} pid=$$ c=$c i=" . $i++);
2077
2078                         unless (defined $ok) {
2079 #::logDebug("PAGE redo accept on error=$! n=$n v=$v p=$p unix=$unix_socket{$p} pid=$$ c=$c i=" . $i++);
2080                                 redo;
2081                                 #die ("accept: $! ok=$ok pid=$$ n=$n c=$c i=" . $i++);
2082                         }
2083
2084                         CHECKHOST: {
2085                                 last CHECKHOST if $unix_socket{$p};
2086                                 my $connector;
2087                                 (undef, $ok) = sockaddr_in($ok);
2088                                 $connector = inet_ntoa($ok);
2089                                 last CHECKHOST if $connector =~ /$Global::TcpHost/;
2090                                 my $dns_name;
2091                                 (undef, $dns_name) = gethostbyaddr($ok, AF_INET);
2092                                 $dns_name = "UNRESOLVED_NAME" if ! $dns_name;
2093                                 last CHECKHOST if $dns_name =~ /$Global::TcpHost/;
2094                         }
2095                         $spawn = 1;
2096                 }
2097           };
2098
2099           if($@) {
2100                 my $msg = $@;
2101                 $msg =~ s/\s+$//;
2102 #::logDebug("Died in select, retrying: $msg");
2103             ::logGlobal({ level => 'error' },  "Died in select, retrying: %s", $msg);
2104           }
2105
2106 #::logDebug ("Past connect, spawn=$spawn");
2107
2108           eval {
2109                 SPAWN: {
2110                         last SPAWN unless defined $spawn;
2111 #::logDebug ("Spawning connection, " .  ($no_fork ? 'no fork, ' : 'forked, ') .  scalar localtime());
2112                         if($no_fork) {
2113                                 ### Careful, returns after MaxRequests or terminate signal
2114                                 $::Instance = {};
2115 #::logDebug("begin non-forked ::connection()");
2116                                 send_ipc(sprintf ('lastused %s %s 1',$$,time))
2117                                         if $Global::PIDcheck;
2118                                 connection(++$handled);
2119                                 send_ipc(sprintf ('lastused %s %s 0',$$,time))
2120                                         if $Global::PIDcheck;
2121 #::logDebug("end non-forked ::connection()");
2122                                 undef $::Instance;
2123                         }
2124                         elsif(! defined ($pid = fork) ) {
2125                                 my $msg = ::errmsg("Can't fork: %s", $!);
2126                                 ::logGlobal({ level => 'crit' },  $msg );
2127                                 die ("$msg\n");
2128                         }
2129                         elsif (! $pid) {
2130                                 #fork again
2131                                 unless ($pid = fork) {
2132 #::logDebug("forked connection");
2133                                         $::Instance = {};
2134                                         eval {
2135                                                 touch_pid() if $Global::PIDcheck;
2136                                                 &$Sig_inc;
2137                                                 connection();
2138                                         };
2139                                         if ($@) {
2140                                                 my $msg = $@;
2141                                                 ::logGlobal({ level => 'error' }, "Runtime error: %s" , $msg);
2142                                                 logError("Runtime error: %s", $msg)
2143                                                         if defined $Vend::Cfg->{ErrorFile};
2144                                         }
2145
2146                                         undef $::Instance;
2147                                         select(undef,undef,undef,0.050) until &$ppidsub == 1;
2148                                         &$Sig_dec and unlink_pid();
2149                                         exit(0);
2150                                 }
2151                                 exit(0);
2152                         }
2153                         close MESSAGE;
2154                         last SPAWN if $no_fork;
2155                         wait;
2156                 }
2157           };
2158
2159                 # clean up dies during spawn
2160                 if ($@) {
2161                         my $msg = $@;
2162                         ::logGlobal({ level => 'error' }, "Died in server spawn: %s", $msg );
2163
2164                         Vend::Session::close_session();
2165                         $Vend::Cfg = { } if ! $Vend::Cfg;
2166
2167                         my $content;
2168                         if($content = ::get_locale_message(500, '', $msg)) {
2169                                 print MESSAGE canon_status("Content-type: text/html");
2170                                 print MESSAGE $content;
2171                         }
2172
2173                         close MESSAGE;
2174
2175                 }
2176
2177                 return if $Signal_Terminate;
2178
2179                 next unless $no_fork;
2180
2181                 return 1   if $end_of_life;
2182
2183                 return 1   if  $Global::MaxRequestsPerChild
2184                                    and $handled >= $Global::MaxRequestsPerChild;
2185
2186
2187     }
2188 }
2189
2190 sub server_soap {
2191 #::logDebug("Entering soap server program");
2192         my $rin;
2193         my $rout;
2194
2195         my $c = 0;
2196         my $handled = 0;
2197 #my $pretty_vector = unpack('b*', $s_vector);
2198 #::logDebug("SOAP server $$ begun, vector=$pretty_vector servers=$SOAP_servers");
2199     for (;;) {
2200
2201           my $n;
2202           $c++;
2203           my ($ok, $p, $v);
2204           eval {
2205                 $rin = $s_vector;
2206
2207                 do {
2208                         $n = select($rout = $rin, undef, undef, $tick);
2209                 } while $n == -1 && $!{EINTR} && ! $Signal_Terminate;
2210
2211         if ($n == -1) {
2212                         last if $!{EINTR} and $Signal_Terminate;
2213                         my $msg = $!;
2214                         $msg = ::errmsg("error '%s' from select, n=%s.", $msg, $n );
2215                         die "$msg";
2216         }
2217                 elsif($n == 0) {
2218                         #soap_housekeeping();
2219                         next;
2220                 }
2221         else {
2222                         while (($p, $v) = each %s_vec_map) {
2223                         next unless vec($rout, $v, 1);
2224                                 $Global::TcpPort = $p;
2225                                 $ok = accept(MESSAGE, $s_fh_map{$p});
2226                                 last;
2227                         }
2228
2229           };
2230
2231           last if $Signal_Terminate;
2232
2233           if($@) {
2234                 my $msg = $@;
2235                 $msg =~ s/\s+$//;
2236 #::logDebug("SOAP died in select, retrying: $msg");
2237             ::logGlobal({ level => 'error' },  "SOAP died in select, retrying: %s", $msg);
2238           }
2239
2240           unless (defined $ok) {
2241 #::logDebug("redo accept on error=$! n=$n p=$p unix=$unix_socket{$p} pid=$$ c=$c");
2242                   redo;
2243           }
2244
2245
2246           eval {
2247                         my $connector;
2248                         my $dns_name;
2249
2250                         CHECKHOST: {
2251                                 last CHECKHOST if $unix_socket{$p};
2252                                 (undef, $ok) = sockaddr_in($ok);
2253                                 $connector = inet_ntoa($ok);
2254                                 last CHECKHOST if $connector =~ /$Global::TcpHost/;
2255                                 (undef, $dns_name) = gethostbyaddr($ok, AF_INET);
2256                                 $dns_name = $connector if ! $dns_name;
2257                                 last CHECKHOST if $dns_name =~ /$Global::TcpHost/;
2258                         }
2259
2260                         $handled++;
2261                         my %env;
2262                         my $entity;
2263
2264                         reset_vars();
2265
2266                         if ($Vend::Cfg = http_soap(\*MESSAGE, \%env, \$entity)) {
2267                                 $Vend::Cat = $Vend::Cfg->{CatalogName};
2268                         }
2269
2270                         my $result;
2271                         my $error;
2272                         if(! $Vend::Cfg) {
2273 #::logDebug("we have no catalog");
2274                                 $result = Vend::SOAP::Transport::Server
2275                                         ->new()
2276                                         ->make_fault('Client.NotFound','Service not found');
2277                         }
2278                         elsif(! $Vend::Cfg->{SOAP}) {
2279 #::logDebug("we have no SOAP enable");
2280                                 $result = Vend::SOAP::Transport::Server
2281                                         ->new()
2282                                         ->make_fault('Client.NotAvailable','Service not available');
2283                         }
2284                         else {
2285 #::logDebug("we have our SOAP enable, entity is $entity");
2286
2287                                 $::Variable = $Vend::Cfg->{Variable};
2288                                 $::Pragma = $Vend::Cfg->{Pragma};
2289
2290                                 ($Vend::SessionID, $CGI::cookiehost) = split /:/, $env{SESSION_ID};
2291 #::logDebug("Received ID=$Vend::SessionID, host='$CGI::cookiehost'");
2292                                 $Vend::NoInterpolate = 1
2293                                         unless $Vend::Cfg->{SOAP_Enable}->{interpolate};
2294                                 $result = Vend::SOAP::Transport::Server
2295                                         ->new( in => $entity )
2296                                         ->dispatch_to('', 'Vend::SOAP')
2297                                         ->handle;
2298                         }
2299
2300                         unless ($Vend::StatusLine =~ m{^HTTP/}) {
2301                                 my $status = $Vend::StatusLine =~ /(?:^|\n)Status:\s+(.*)/i
2302                                         ? "$1" : "200 OK";
2303                                 $Vend::StatusLine = "HTTP/1.0 $status\r\n" . $Vend::StatusLine;
2304                         }
2305                         $Vend::StatusLine .= "\r\nContent-Type: text/xml\r\n"
2306                                 unless $Vend::StatusLine =~ /^Content-Type:/im;
2307
2308                         print MESSAGE canon_status($Vend::StatusLine);
2309                         print MESSAGE "\r\n";
2310                         print MESSAGE $result;
2311                         undef $Vend::StatusLine;
2312                         $Vend::ResponseMade = 1;
2313                         close MESSAGE;
2314 #::logDebug("SOAP port=$p n=$n unix=$unix_socket{$p} pid=$$ c=$c time=" . join '|', times);
2315                 }
2316           };
2317
2318           if($@) {
2319                 my $msg = $@;
2320                 $msg =~ s/\s+$//;
2321 #::logDebug("SOAP died in processing: $msg");
2322             ::logGlobal({ level => 'error' },  "SOAP died in processing: %s", $msg);
2323                 close MESSAGE;
2324           }
2325
2326           return if $Signal_Terminate;
2327           return 1 if $handled > ($Global::SOAP_MaxRequests || 10);
2328           ::put_session() if $Vend::HaveSession;
2329           undef $Vend::Session;
2330           undef $Vend::HaveSession;
2331     }
2332
2333 }
2334
2335 sub process_ipc {
2336         my $fh = shift;
2337 #::logDebug("pid $$: processing ipc response $fh");
2338         my $thing = <$fh>;
2339 #::logDebug("pid $$: thing is $thing");
2340         if($thing =~ /^\d+$/) {
2341                 close $fh;
2342                 $Num_servers--;
2343         }
2344         elsif ($thing =~ /^lastused (\d+) (\d+) ([01])/) {
2345 #::logDebug("Page pid $1 last used at $2");
2346                 @{ $Page_pids{$1} } = ($2, $3);
2347         }
2348         elsif ($thing =~ /^register page (\d+)/) {
2349                 $Page_pids{$1} = [ time, 0 ];
2350                 starting_pids('del',$1);
2351 #::logDebug("registered Page pid $1");
2352                 $Page_servers++;
2353         }
2354         elsif ($thing =~ /^respawn page (\d+)/) {
2355                 delete $Page_pids{$1};
2356 #::logDebug("deleted Page pid $1");
2357                 $Page_servers--;
2358                 start_page(undef,$Global::PreFork,1);
2359         }
2360         elsif ($thing =~ /^register soap (\d+)/) {
2361                 $SOAP_pids{$1} = 1;
2362 #::logDebug("registered SOAP pid $1");
2363                 $SOAP_servers++;
2364         }
2365         elsif ($thing =~ /^respawn soap (\d+)/) {
2366                 delete $SOAP_pids{$1};
2367 #::logDebug("deleted SOAP pid $1");
2368                 $SOAP_servers--;
2369                 start_soap(undef, 1);
2370         }
2371         elsif ($thing =~ /^running job (\d+)/) {
2372 #::logDebug("registered job pid $1");
2373                 $Lifetime{$1} = $Global::Jobs->{MaxLifetime} || 30;
2374         }
2375         elsif ($thing =~ /^finishing job (\d+)/) {
2376 #::logDebug("finished job pid $1");
2377                 $Job_servers--;
2378                 delete $Lifetime{$1};
2379         }
2380         elsif($thing =~ /^\d+$/) {
2381                 close $fh;
2382                 $Num_servers++;
2383         }
2384         return;
2385 }
2386
2387 sub send_ipc {
2388         my $msg = shift;
2389         socket(SOCK, PF_UNIX, SOCK_STREAM, 0)   or die "socket: $!\n";
2390
2391         my $ok;
2392
2393         do {
2394            $ok = connect(SOCK, sockaddr_un($Global::IPCsocket));
2395         } while ( ! defined $ok and ! $!{EINTR});
2396
2397         print SOCK $msg;
2398 #::logDebug("pid $$: sent ipc $msg");
2399         close SOCK;
2400 }
2401
2402 sub setup_debug_log {
2403         if ($Global::DebugFile) {
2404                 open(Vend::DEBUG, ">>$Global::DebugFile");
2405                 select Vend::DEBUG;
2406                 $| = 1;
2407                 print "Start DEBUG at " . localtime() . "\n" unless $Global::SysLog;
2408         }
2409         elsif (!$Global::DEBUG) {
2410                 # May as well turn warnings off, not going anywhere
2411                 $^W = 0;
2412                 open (Vend::DEBUG, ">/dev/null") unless $Global::Windows;
2413         }
2414
2415         close(STDIN);
2416         close(STDOUT);
2417         close(STDERR);
2418
2419         open(STDOUT, ">&Vend::DEBUG");
2420         select(STDOUT);
2421         $| = 1;
2422
2423         open(STDERR, ">&Vend::DEBUG");
2424         select(STDERR);
2425         $| = 1;
2426 }
2427
2428 # The servers for both are now combined
2429 # Can have both INET and UNIX on same system
2430 sub server_both {
2431     my ($socket_filename) = @_;
2432     my ($n, $rin, $rout, $pid);
2433
2434         ::logGlobal({ level => 'info' }, server_start_message());
2435
2436         $Vend::MasterProcess = $$;
2437
2438         $tick        = $Global::HouseKeeping || 60;
2439
2440     setup_signals();
2441
2442 #::logDebug("Starting server socket file='$socket_filename'\n");
2443
2444         my $spawn;
2445
2446         for (qw/mode.inet mode.unix mode.soap/) {
2447                 unlink "$Global::RunDir/$_";
2448         }
2449
2450         # We always unlink our file-based sockets
2451         unlink_sockets($Global::SocketFile);
2452         if($Global::IPCsocket) {
2453 #::logDebug("Creating IPC socket $Global::IPCsocket");
2454                 unlink_sockets($Global::IPCsocket);
2455                 ## This is a scalar, not an array like Global::SocketFile
2456                 ($ipc) = map_unix_socket(\$vector, \%vec_map, \%fh_map, $Global::IPCsocket );
2457                 $ipc_socket{$ipc} = $ipc;
2458                 $unix_socket{$ipc} = $ipc;
2459                 $ipc_vector = $vector;
2460         }
2461
2462         # Make UNIX-domain sockets if applicable. The sockets are mapped into the
2463         # vector map and file handle map, socket permissions are set, etc.  The
2464         # socket labels are marked with %unix_socket so that INET-specific
2465         # processing like determining IP address are not done.
2466         if($Global::Unix_Mode) {
2467                 my @made =
2468                         map_unix_socket(\$vector, \%vec_map, \%fh_map, @$Global::SocketFile);
2469                 if (scalar @made) {
2470                         @unix_socket{@made} = @made;
2471                         open(UNIX_MODE_INDICATOR, ">$Global::RunDir/mode.unix")
2472                                 or die "create $Global::RunDir/mode.unix: $!";
2473                         print UNIX_MODE_INDICATOR join " ", @made;
2474                         close(UNIX_MODE_INDICATOR);
2475                         # So that other apps can read if appropriate
2476                         chmod $Global::SocketPerms, "$Global::RunDir/mode.unix";
2477                 }
2478                 else { # The error condition
2479                         my $msg;
2480                         if ($Global::Inet_Mode) {
2481                                 $msg = errmsg("Failed to make any UNIX sockets, continuing in INET MODE ONLY" );
2482                                 ::logGlobal({ level => 'warn' }, $msg);
2483                                 print "$msg\n";
2484                                 undef $Global::Unix_Mode;
2485                         }
2486                         else {
2487                                 $msg = errmsg( "No sockets -- INTERCHANGE SERVER TERMINATING\a" );
2488                                 ::logGlobal( {level => 'alert'}, $msg );
2489                                 print "$msg\n";
2490                                 exit 1;
2491                         }
2492                 }
2493
2494                 for(@made) {
2495                         chmod $Global::SocketPerms, $_;
2496                         if($Global::SocketPerms & 033) {
2497                                 ::logGlobal( {
2498                                         level => 'warn' },
2499                                         "ALERT: %s socket permissions are insecure; are you sure you want permissions %o?",
2500                                         $_,
2501                                         $Global::SocketPerms,
2502                                 );
2503                         }
2504                 }
2505         }
2506
2507         # Make SOAP-IPC sockets if applicable. The sockets are mapped into a
2508         # separate vector map and file handle map. The require of the SOAP
2509         # module is done here so that memory footprint will not be greater
2510         # if SOAP is not used.
2511
2512         if($Global::SOAP) {
2513                 eval {
2514                         require Vend::SOAP;
2515                 };
2516                 if($@) {
2517                         ::logGlobal( {
2518                                 level => 'info' },
2519                                 $@,
2520                         );
2521                         ::logGlobal( {
2522                                 level => 'warn' },
2523                                 "SOAP enabled, but Vend::SOAP failed to load."
2524                         );
2525                         print "SOAP enabled, but Vend::SOAP failed to load.\n";
2526                         $Global::SOAP = 0;
2527                 } else {
2528                         my @made;
2529                         my @unix_soap = grep m{/}, @{$Global::SOAP_Socket};
2530                         my @inet_soap = grep $_ !~ m{/}, @{$Global::SOAP_Socket};
2531                         if(@unix_soap) {
2532                                 unlink_sockets(@unix_soap);
2533                                 push @made,
2534                                         map_unix_socket(\$s_vector, \%s_vec_map, \%s_fh_map, @unix_soap);
2535                                 chmod $Global::SOAP_Perms, @made;
2536                                 @unix_socket{@made} = @made;
2537                         }
2538                         if(@inet_soap) {
2539                                 push @made,
2540                                         map_inet_socket('SOAP', \$s_vector, \%s_vec_map, \%s_fh_map, @inet_soap);
2541                         }
2542                 }
2543         }
2544
2545         # Make INET-domain sockets if applicable. The sockets are added into
2546         # $vector for select(,,,) monitoring, and mapped into the vector map and
2547         # file handle map.
2548         if($Global::Inet_Mode) {
2549                 $Global::TcpHost = create_host_pattern($Global::TcpHost);
2550                 ::logGlobal(
2551                                 { level => 'info' },
2552                                 "Accepting connections from %s",
2553                                 $Global::TcpHost,
2554                                 );
2555                 my @made =
2556                         map_inet_socket('TCP', \$vector, \%vec_map, \%fh_map, keys %{$Global::TcpMap});
2557                 if (! scalar @made) {
2558                         my $msg;
2559                         if ($Global::Unix_Mode) {
2560                                 $msg = errmsg("Continuing in UNIX MODE ONLY" );
2561                                 ::logGlobal({ level => 'warn' }, $msg);
2562                                 print "$msg\n";
2563                                 undef $Global::Inet_Mode;
2564                         }
2565                         else {
2566                                 $msg = errmsg( "No sockets -- INTERCHANGE SERVER TERMINATING\a" );
2567                                 ::logGlobal( {level => 'alert'}, $msg );
2568                                 print "$msg\n";
2569                                 exit 1;
2570                         }
2571                 }
2572                 else {
2573                         open(INET_MODE_INDICATOR, ">$Global::RunDir/mode.inet")
2574                                 or die "create $Global::RunDir/mode.inet: $!";
2575                         print INET_MODE_INDICATOR join " ", @made;
2576                         close(INET_MODE_INDICATOR);
2577                         # So that other apps can read if appropriate
2578                         chmod $Global::SocketPerms, "$Global::RunDir/mode.inet";
2579                 }
2580         }
2581
2582         ::logGlobal({ level => 'info' }, server_start_message() );
2583
2584         print server_start_message(
2585                 "Interchange server started in %s mode(s) (process id %s)\n",
2586                 1,
2587         ) unless $Vend::Quiet;
2588
2589         my $no_fork;
2590         if($Global::Windows or $Global::DEBUG ) {
2591                 $no_fork = 1;
2592                 $Global::Foreground = 1;
2593                 ::logGlobal({ level => 'info' }, "Running in foreground, OS=$^O, debug=$Global::DEBUG\n");
2594         }
2595         else {
2596                 setup_debug_log();
2597 #::logDebug("s_vector=" . unpack('b*', $s_vector));
2598                 if($s_vector) {
2599                         start_soap(1);
2600                 }
2601         }
2602
2603         my $master_ipc = 0;
2604         if($Global::PreFork && $Global::StartServers) {
2605                 $master_ipc = 1;
2606                 $p_vector = $vector ^ $ipc_vector;
2607                 start_page(1, $Global::PreFork, $Global::StartServers);
2608         }
2609
2610         my $c = 0;
2611         my $only_ipc = $master_ipc;
2612         my $checked_soap;
2613         my $cycle;
2614
2615         no warnings; ## We will last out of loop
2616
2617     for (;;) {
2618
2619           my $i = 0;
2620           $c++;
2621           eval {
2622         if($only_ipc) {
2623                         $rin = $ipc_vector;
2624                         $cycle = 0.100;
2625                 }
2626                 else {
2627                         $rin = $vector;
2628                         $cycle = $tick;
2629                 }
2630                 undef $spawn;
2631                 undef $checked_soap;
2632                 do {
2633                         $n = select($rout = $rin, undef, undef, $cycle);
2634                 } while $n == -1 && $!{EINTR} && ! $Signal_Terminate;
2635
2636                 undef $Vend::Cfg;
2637
2638 #my $pretty_vector = unpack('b*', $rin);
2639 #::logDebug("cycle=$c tick=$cycle vector=$pretty_vector n=$n num_servers=$Num_servers");
2640         if ($n == -1) {
2641                         last if $Signal_Terminate;
2642                         my $msg = $!;
2643                         $msg = ::errmsg("error '%s' from select, n=%s." , $msg, $n);
2644                         die "$msg";
2645         }
2646                 elsif($n == 0) {
2647                         # Do nothing, timed out
2648                 }
2649         else {
2650
2651             my ($ok, $p, $v);
2652                         while (($p, $v) = each %vec_map) {
2653 #::logDebug("trying p=$p v=$v vec=" . vec($rout,$v,1) . " pid=$$ c=$c i=" . $i++ );
2654                         next unless vec($rout, $v, 1);
2655 #::logDebug("accepting p=$p v=$v pid=$$ c=$c i=" . $i++);
2656                                 $Global::TcpPort = $p;
2657                                 $ok = accept(MESSAGE, $fh_map{$p});
2658                                 last;
2659                         }
2660
2661 #::logDebug("port $Global::TcpPort n=$n v=$v error=$! p=$p unix=$unix_socket{$p} ipc=$ipc_socket{$p} pid=$$ c=$c i=" . $i++);
2662
2663                         unless (defined $ok) {
2664 #::logDebug("redo accept on error=$! n=$n v=$v p=$p unix=$unix_socket{$p} pid=$$ c=$c i=" . $i++);
2665                                 redo;
2666                                 #die ("accept: $! ok=$ok pid=$$ n=$n c=$c i=" . $i++);
2667                         }
2668
2669                         if ($ipc_socket{$p}) {
2670                                 process_ipc(\*MESSAGE);
2671                                 $only_ipc = 1;
2672                         }
2673
2674                         CHECKHOST: {
2675                                 last CHECKHOST if $unix_socket{$p};
2676                                 my $connector;
2677                                 (undef, $ok) = sockaddr_in($ok);
2678                                 $connector = inet_ntoa($ok);
2679                                 last CHECKHOST if $connector =~ /$Global::TcpHost/;
2680                                 my $dns_name;
2681                                 (undef, $dns_name) = gethostbyaddr($ok, AF_INET);
2682                                 $dns_name = "UNRESOLVED_NAME" if ! $dns_name;
2683                                 last CHECKHOST if $dns_name =~ /$Global::TcpHost/;
2684                         }
2685                         $spawn = 1 unless $only_ipc;
2686                 }
2687           };
2688
2689           if($@) {
2690                 my $msg = $@;
2691                 $msg =~ s/\s+$//;
2692 #::logDebug("Died in select, retrying: $msg");
2693             ::logGlobal({ level => 'error' },  "Died in select, retrying: %s", $msg);
2694           }
2695
2696           eval {
2697                 SPAWN: {
2698                         last SPAWN unless defined $spawn;
2699 #::logDebug("Spawning connection, " .  ($no_fork ? 'no fork, ' : 'forked, ') .  scalar localtime() . "\n");
2700                         if(defined $no_fork) {
2701                                 $::Instance = {};
2702                                 connection();
2703                                 undef $::Instance;
2704                         }
2705                         elsif(! defined ($pid = fork) ) {
2706                                 my $msg = ::errmsg("Can't fork: %s", $!);
2707                                 ::logGlobal({ level => 'crit' },  $msg );
2708                                 die ("$msg\n");
2709                         }
2710                         elsif (! $pid) {
2711                                 #fork again
2712                                 unless ($pid = fork) {
2713
2714                                         reset_per_fork();
2715                                         $::Instance = {};
2716                                         eval {
2717                                                 touch_pid() if $Global::PIDcheck;
2718                                                 &$Sig_inc;
2719                                                 connection();
2720                                         };
2721                                         if ($@) {
2722                                                 my $msg = $@;
2723                                                 ::logGlobal({ level => 'error' }, "Runtime error: %s" , $msg);
2724                                                 logError("Runtime error: %s", $msg)
2725                                                         if defined $Vend::Cfg->{ErrorFile};
2726                                         }
2727                                         clean_up_after_fork();
2728
2729                                         undef $::Instance;
2730                                         select(undef,undef,undef,0.050) until &$ppidsub == 1;
2731                                         if ($Global::IPCsocket) {
2732                                                 &$Sig_dec and unlink_pid();
2733                                         }
2734                                         elsif ($Global::PIDcheck) {
2735                                                 unlink_pid() and &$Sig_dec;
2736                                         }
2737                                         else {
2738                                                 &$Sig_dec;
2739                                         }
2740                                         exit(0);
2741                                 }
2742                                 exit(0);
2743                         }
2744                         close MESSAGE;
2745                         last SPAWN if $no_fork;
2746                         wait;
2747                 }
2748           };
2749
2750                 # clean up dies during spawn
2751                 if ($@) {
2752                         my $msg = $@;
2753                         ::logGlobal({ level => 'error' }, "Died in server spawn: %s", $msg );
2754
2755                         Vend::Session::close_session();
2756                         $Vend::Cfg = { } if ! $Vend::Cfg;
2757
2758                         my $content;
2759                         if($content = ::get_locale_message(500, '', $msg)) {
2760                                 print MESSAGE canon_status("Content-type: text/html");
2761                                 print MESSAGE $content;
2762                         }
2763
2764                         close MESSAGE;
2765                 }
2766
2767                 last if $Signal_Terminate;
2768                 $only_ipc = $master_ipc;
2769
2770           eval {
2771                     housekeeping($tick);
2772                     if ($Global::MaxServers and $Num_servers > $Global::MaxServers) {
2773                            $only_ipc = $ipc;
2774                         }
2775                         if( $rin = $s_vector and select($rin, undef, undef, 0) >= 1 ) {
2776                                 start_soap(undef,1)
2777                                         unless $SOAP_servers > $Global::SOAP_MaxServers;
2778                         }
2779           };
2780           ::logGlobal({ level => 'crit' }, "Died in housekeeping, retry: %s", $@ ) if $@;
2781     }
2782
2783     restore_signals();
2784
2785         if ($Signal_Terminate) {
2786         ::logGlobal({ level => 'info' }, "STOP server (%s) on signal TERM", $$ );
2787 #::logDebug("SOAP pids: " . ::uneval(\%SOAP_pids));
2788                 my @pids = keys %SOAP_pids;
2789                 if(@pids) {
2790                         ::logGlobal(
2791                                 { level => 'info' },
2792                                 "STOP SOAP servers (%s) on signal TERM",
2793                                 join ",", keys %SOAP_pids,
2794                         );
2795                         kill 'TERM', @pids;
2796                 }
2797                 @pids = keys %Page_pids;
2798                 if(@pids) {
2799                         ::logGlobal(
2800                                 { level => 'info' },
2801                                 "STOP page servers (%s) on signal TERM",
2802                                 join ",", keys %Page_pids,
2803                         );
2804                         kill 'TERM', @pids;
2805                 }
2806                 for(keys %Global::Catalog) {
2807                         ::remove_catalog($_);
2808                 }
2809         }
2810
2811     return '';
2812 }
2813
2814 sub touch_pid {
2815         my $temppid = gensym();
2816
2817         open($temppid, ">>$Global::RunDir/pid.$$")
2818                 or die "create PID file $$: $!\n";
2819         lockfile($temppid, 1, 0)
2820                 or die "PID $$ conflict: can't lock\n";
2821
2822         if (@_) {
2823                 $temppid->autoflush(1);
2824                 print $temppid $_[0], "\n";
2825         }
2826 }
2827
2828 sub jobs_job {
2829         my ($cat, @jobs) = @_;
2830         my $parms;
2831
2832         if (ref($jobs[$#jobs]) eq 'HASH') {
2833                 $parms = pop(@jobs);
2834         }
2835
2836         for my $job (@jobs) {
2837                 Vend::Dispatch::run_in_catalog($cat, $job, '', $parms);
2838         }
2839 }
2840
2841 sub flag_job {
2842         my ($pid, $cat, $action, $token) = @_;
2843
2844         if ($action eq 'raise') {
2845                 if ($token =~ /^(\d+)$/) {
2846                         my $file = "flag.$cat.$1";
2847                         my $cwd = getcwd();
2848
2849                         unless (open(FLAG, ">>$Global::RunDir/$file")) {
2850                                 die "unable to create flag file $Global::RunDir/$file: $!\n";
2851                         }
2852
2853                         unless (lockfile(\*FLAG, 1, 0)) {
2854                                 die "unable to lock file $Global::RunDir/$file: $!\n";
2855                         }
2856
2857                         unless (chdir($Global::RunDir)) {
2858                                 die "unable to enter directory $Global::RunDir: $!\n";
2859                         }
2860
2861                         unless (symlink($file, "flag.$pid")) {
2862                                 chdir($cwd);
2863                                 die "unable to create symlink for $file: $!\n";
2864                         }
2865
2866                         chdir($cwd);
2867                 } else {
2868                         return undef;
2869                 }
2870         } elsif ($action eq 'check') {
2871                 return if $token !~ /^(\d+)$/;
2872
2873                 if (-f "$Global::RunDir/flag.$cat.$1") {
2874                         return 1;
2875                 } else {
2876                         return 0;
2877                 }
2878         } elsif ($action eq 'furl') {
2879                 my $flagfile = readlink("$Global::RunDir/flag.$pid");
2880
2881                 if (defined ($flagfile)) {
2882                         if ($flagfile =~ /^flag\.$cat\.(\d+)$/) {
2883                                 unless (unlink("$Global::RunDir/$flagfile")) {
2884                                         die "failed to remove flag file: $Global::RunDir/$flagfile: $!\n";
2885                                 }
2886                         } else {
2887                                 die "invalid flag file $flagfile\n";
2888                         }
2889
2890                         unless (unlink("$Global::RunDir/flag.$pid")) {
2891                                 die "failed to remove link to flag file: $Global::RunDir/flag.$pid: $!\n";
2892                         }
2893                 } else {
2894                         logGlobal({level => 'notice'}, "Readlink failed: $!\n");
2895                 }
2896         }
2897 }
2898
2899 sub run_jobs {
2900         my ($cat, @jobs) = @_;
2901
2902 #::logGlobal("Vend::Server::run_jobs: run jobs cat=$cat job=@jobs");
2903         my $pid;
2904         if($Global::Foreground) {
2905                 $::Instance = {};
2906                 eval {
2907                         jobs_job($cat, @jobs);
2908                 };
2909                 if($@) {
2910                         my $msg = $@;
2911                         ::logGlobal({ level => 'error' }, "Runtime error: %s" , $msg);
2912                         logError("Runtime jobs error: %s", $msg)
2913                                 if defined $Vend::Cfg->{ErrorFile};
2914                 }
2915                 clean_up_after_fork();
2916                 undef $::Instance;
2917         }
2918         elsif(! defined ($pid = fork) ) {
2919                 my $msg = ::errmsg("Can't fork: %s", $!);
2920                 ::logGlobal({ level => 'crit' },  $msg );
2921                 die ("$msg\n");
2922         }
2923         elsif (! $pid) {
2924                 #fork again
2925                 unless ($pid = fork) {
2926
2927                         send_ipc("running job $$");
2928                         reset_per_fork();
2929                         $::Instance = {};
2930                         eval {
2931                                 touch_pid($cat) if $Global::PIDcheck;
2932                                 &$Sig_inc;
2933                                 jobs_job($cat, @jobs);
2934                         };
2935                         if ($@) {
2936                                 my $msg = $@;
2937                                 ::logGlobal({ level => 'error' }, "Runtime error: %s" , $msg);
2938                                 logError("Runtime jobs error: %s", $msg)
2939                                         if defined $Vend::Cfg->{ErrorFile};
2940                         }
2941                         clean_up_after_fork();
2942                         send_ipc("finishing job $$");
2943
2944                         undef $::Instance;
2945                         select(undef,undef,undef,0.050) until &$ppidsub == 1;
2946                         if ($Global::PIDcheck) {
2947                                 unlink_pid() and &$Sig_dec;
2948                         }
2949                         else {
2950                                 &$Sig_dec;
2951                         }
2952                         exit(0);
2953                 }
2954                 exit(0);
2955         }
2956         wait unless $Global::Foreground;
2957 }
2958
2959 sub unlink_pid {
2960         close(TEMPPID);
2961         unlink("$Global::RunDir/pid.$$");
2962         1;
2963 }
2964
2965 sub grab_pid {
2966         my $fh = shift
2967                 or return;
2968     my $ok = lockfile($fh, 1, 0);
2969     if (not $ok) {
2970         chomp(my $pid = <$fh>);
2971         return $pid;
2972     }
2973     {
2974         no strict 'subs';
2975         truncate($fh, 0) or die "Couldn't truncate pid file: $!\n";
2976     }
2977     print $fh ($Global::mod_perl ? &$ppidsub : $$), "\n";
2978     return 0;
2979 }
2980
2981 sub open_pid {
2982         my $fn = shift || $Global::PIDfile;
2983         my $fh = gensym();
2984     open($fh, "+>>$fn")
2985         or die ::errmsg("Couldn't open '%s': %s\n", $fn, $!);
2986     seek($fh, 0, 0);
2987     my $o = select($fh);
2988     $| = 1;
2989         select($o);
2990         return $fh;
2991 }
2992
2993 sub read_pidfile {
2994         my $fn = shift || $Global::PIDfile;
2995         my $fh = gensym();
2996         open $fh, "<$fn" or return;
2997         chomp (my $pid = <$fh>);
2998         close $fh;
2999         return $pid;
3000 }
3001
3002 sub run_server {
3003     my $next;
3004 #::logDebug("trying to run server");
3005
3006         @$Global::SocketFile = "$Global::VendRoot/etc/socket"
3007                 unless @$Global::SocketFile and $Global::SocketFile->[0];
3008
3009         if($Global::Variable->{MV_GETPPID_BROKEN}) {
3010 #::logDebug("setting getppid broken");
3011                 my $num = $Global::Variable->{MV_GETPPID_BROKEN} > 1
3012                                 ? $Global::Variable->{MV_GETPPID_BROKEN}
3013                                 : 64;
3014                 $ppidsub = sub {
3015                         return syscall($num);
3016                 };
3017         }
3018     my $pidh = open_pid($Global::PIDfile);
3019 #::logDebug("Opened pid file");
3020
3021         if($Global::AcceptRedirect) {
3022                 push @Map, @RedirMap
3023                         unless grep $_ eq 'REDIRECT_URL', @Map;
3024         }
3025
3026         if ($Global::mod_perl) {
3027                 undef $Global::Unix_Mode;
3028                 undef $Global::Inet_Mode;
3029                 undef $Global::StartServers;
3030                 undef $Global::PreFork;
3031                 undef $Global::SOAP;
3032                 undef $Global::IPCsocket;
3033         }
3034         elsif ( $Global::Windows ) {
3035                 $Global::Inet_Mode = 1;
3036         }
3037         elsif (! $Global::Inet_Mode and ! $Global::Unix_Mode) {
3038                 $Global::Inet_Mode = $Global::Unix_Mode = 1;
3039         }
3040
3041         if($Global::mod_perl || $Global::PreFork || $Global::DEBUG || $Global::Windows) {
3042                 eval {
3043                         require Tie::ShadowHash;
3044                 };
3045                 if($@) {
3046                         my $reason;
3047                         if($Global::mod_perl)   { $reason = 'under mod_perl' }
3048                         elsif($Global::PreFork) { $reason = 'in PreFork mode' }
3049                         elsif($Global::DEBUG)   { $reason = 'in DEBUG mode' }
3050                         elsif($Global::Windows) { $reason = 'under Windows' }
3051                         die ::errmsg("Running $reason requires Tie::ShadowHash module.") . "\n";
3052                 }
3053         }
3054
3055         if ($Global::mod_perl) {
3056                 my $running = grab_pid($pidh);
3057                 if ($running) {
3058                         print errmsg(
3059                                 "The Interchange server is already running (process id %s)\n",
3060                                 $running,
3061                         );
3062                         undef $Global::mod_perl;
3063                         return;
3064                 }
3065                 # throw away pidfile -- Apache hasn't forked yet, so pid is wrong
3066                 unlockfile($pidh);
3067                 unlink $Global::PIDfile;
3068                 print server_start_message("Interchange server started (%s)\n", 1);
3069                 ::logGlobal(
3070                         { level => 'info' },
3071                         Vend::Server::server_start_message('START server (%s)', 1),
3072                 );
3073                 setup_debug_log();
3074                 # all done; now wait for Apache to call Vend::ModPerl::handler
3075                 return;
3076         }
3077
3078         if ($Global::Windows || $Global::DEBUG) {
3079         my $running = grab_pid($pidh);
3080         if ($running) {
3081                         print errmsg(
3082                                 "The Interchange server is already running (process id %s)\n",
3083                                 $running,
3084                                 );
3085                         exit 1;
3086         }
3087
3088         print server_start_message("Interchange server started (%s) (%s)\n");
3089                 $next = server_both();
3090     }
3091     else {
3092
3093         fcntl($pidh, F_SETFD, 0)
3094             or die ::errmsg(
3095                                         "Can't fcntl close-on-exec flag for '%s': %s\n",
3096                                         $Global::PIDfile, $!,
3097                                         );
3098         my ($pid1, $pid2);
3099         if ($pid1 = fork) {
3100             # parent
3101             wait;
3102                         sleep 2;
3103             exit 0;
3104         }
3105         elsif (not defined $pid1) {
3106             # fork error
3107             print "Can't fork: $!\n";
3108             exit 1;
3109         }
3110         else {
3111             # child 1
3112             if ($pid2 = fork) {
3113                 # still child 1
3114                 exit 0;
3115             }
3116             elsif (not defined $pid2) {
3117                 print "child 1 can't fork: $!\n";
3118                 exit 1;
3119             }
3120             else {
3121                 # child 2
3122 #::logDebug("getting ready to sleep ...");
3123                 sleep 1 until &$ppidsub == 1;
3124 #::logDebug("slept ...");
3125
3126                 my $running = grab_pid($pidh);
3127                 if ($running) {
3128                     print errmsg(
3129                                                 "The Interchange server is already running (process id %s)\n",
3130                                                 $running,
3131                                                 );
3132                     exit 1;
3133                 }
3134
3135                 setsid();
3136
3137                 fcntl($pidh, F_SETFD, 1)
3138                     or die "Can't fcntl close-on-exec flag for '$Global::PIDfile': $!\n";
3139
3140                                 $next = server_both();
3141
3142                                 unlockfile($pidh);
3143                                 opendir(RUNDIR, $Global::RunDir)
3144                                         or die "Couldn't open directory $Global::RunDir: $!\n";
3145                                 unlink $Global::PIDfile;
3146                 exit 0;
3147             }
3148         }
3149     }
3150 }
3151
3152 # Set the process name ($0) according to MV_DOLLAR_ZERO and a status indicator.
3153 sub set_process_name {
3154     my $status = shift;
3155     my $base = $Global::Variable->{MV_DOLLAR_ZERO};
3156
3157     # Setting MV_DOLLAR_ZERO to 1 should do the same thing as not setting it for
3158     # backwards compatibility.
3159     $base = 'interchange' if !$base or $base eq '1';
3160
3161     if (defined $status) {
3162         $0 = "$base: $status";
3163     }
3164     else {
3165         $0 = $base;
3166     }
3167
3168     return;
3169 }
3170
3171 # Disconnect child process from any dangling attachments to parent process.
3172 # Named after similar mod_perl routine.
3173 sub cleanup_for_exec {
3174     # Release any open sockets
3175     %fh_map = %vec_map = %s_vec_map = %s_fh_map = %ipc_socket = %unix_socket
3176         = ();
3177
3178     # Close filehandles except for STDERR, used for debug log
3179     close MESSAGE;
3180     close SOCK;
3181     open STDIN, '<', '/dev/null';
3182     open STDOUT, '>>', '/dev/null';
3183
3184     return;
3185 }
3186
3187 sub sever_database {
3188     # Keep connection closings on the client from closing the
3189     # database server, too.
3190     child_process_dbi_prep();
3191
3192     # Clear any cached DBI handles
3193     reset_per_fork();
3194
3195     # Prep new database connections for severed server
3196     Vend::Data::open_database(1);
3197     while (my ($db, $db_ref) = each %Vend::Database) {
3198         delete $Vend::Interpolate::Db{$db};
3199         $db_ref->close_table;
3200         undef $db_ref->[$Vend::Table::DBI::DBI];
3201     }
3202
3203     return;
3204 }
3205
3206 sub child_process_dbi_prep {
3207     # Because all clients with a common database connection will share
3208     # the same db server, we want the child process not to destroy the
3209     # database server when it disconnects.
3210     eval {
3211         my %d = DBI->installed_drivers;
3212         for my $h (values %d) {
3213             $_->{InactiveDestroy} = 1
3214                 for grep { defined } @{ $h->{ChildHandles} };
3215         }
3216     };
3217
3218     ::logGlobal(
3219         'WARNING - error setting all DBI handles to InactiveDestroy: %s',
3220         $@
3221     )
3222         if ($@);
3223
3224     return;
3225 }
3226
3227
3228 1;
3229 __END__
3230