dist/src/mod_perl2/Interchange/Link.pm

   1 #!/usr/bin/perl
   2
   3 # Interchange::Link -- mod_perl 1.99/2.0 module for linking to Interchange
   4 #
   5 # Copyright (C) 2002-2009 Interchange Development Group
   6 # Copyright (C) 1996-2002 Red Hat, Inc.
   7 #
   8 # This program is free software; you can redistribute it and/or
   9 # modify it under the terms of the GNU General Public License as
  10 # published by the Free Software Foundation; either version 2 of the
  11 # License, or (at your option) any later version.
  12 #
  13 # This program is distributed in the hope that it will be useful,
  14 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16 # General Public License for more details.
  17 #
  18 # You should have received a copy of the GNU General Public License
  19 # along with this program; if not, write to the Free Software
  20 # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  21
  22 package Interchange::Link;
  23
  24
  25 use strict;
  26 use ModPerl::Registry;
  27 use ModPerl::Code;
  28 use Apache2::Const -compile => qw(DECLINED OK NOT_FOUND FORBIDDEN REDIRECT HTTP_MOVED_PERMANENTLY);
  29 use Apache2::ServerRec ();
  30 require Apache2::Connection;
  31 require Apache2::RequestRec;
  32 require Apache2::RequestIO;
  33 require Apache2::RequestUtil;
  34 use Socket;
  35
  36 $ENV{PATH} = "/bin:/usr/bin";
  37 $ENV{IFS} = " ";
  38
  39 ## This is what is returned when the environment returns undef
  40 my $global_status;
  41
  42 =head1 NAME
  43
  44 Interchange::Link -- mod_perl 1.99/2.0 module for linking to Interchange
  45
  46 =head1 VERSION
  47
  48 2009-08-22
  49
  50 =head1 SYNOPSIS
  51
  52   <Location /foundation>
  53     SetHandler perl-script
  54      PerlResponseHandler  Interchange::Link
  55      PerlOptions +GlobalRequest
  56      PerlSetVar InterchangeServer /var/run/interchange/socket
  57      PerlSetVar OrdinaryFileList "/foundation/images/ /foundation/dl/"
  58   </Location>
  59
  60 =head1 DESCRIPTION
  61
  62 Interchange::Link is designed to replace the vlink and tlink programs
  63 that come with Interchange. The Interchange link protocol has been
  64 implemented via an Apache mod_perl modules which saves us the (small) overhead
  65 of the execution of a CGI program.
  66
  67 In addition, it will deliver downloadable files in a streaming fashion
  68 without keeping Interchange open, which cuts overhead dramatically for
  69 large downloadable files. See L<FileDeliveryBase>.
  70
  71 Note that this module is not compatible with Apache 1.
  72
  73 =head1 PREREQUISITES
  74
  75 You must have mod_perl 1.99 or higher installed on your Apache. On a
  76 Red Hat-style Linux system, it is as simple as:
  77
  78     rpm -i mod_perl-1.99.XX-X.rpm
  79     service httpd restart
  80
  81 Installation of mod_perl will vary from system to system. Consult the
  82 mod_perl documentation. Sometimes it is as easy as
  83
  84     perl -MCPAN -e 'install ModPerl::Registry'
  85
  86 but often it is not.
  87
  88 Usually you can download the package from http://perl.apache.org/ and
  89 follow those instructions.
  90
  91 =head1 INSTALLATION
  92
  93 You must specify that Apache use mod_perl, and you must tell it where
  94 to find the Perl modules you want to use.
  95
  96 On a Red Hat Linux system you might copy this file to /usr/lib/httpd/perl/
  97 via this procedure:
  98
  99     mkdir -p /usr/lib/httpd/perl/Interchange
 100     cp Link.pm /usr/lib/httpd/perl/Interchange
 101
 102 If you have mod_perl2 1.999_21 or earlier, you should instead do:
 103
 104     mkdir -p /usr/lib/httpd/perl/Interchange
 105     cp Link.pm.mod_perl-1.999_21_and_before /usr/lib/httpd/perl/Interchange
 106
 107 Then you provide a startup script that tells mod_perl where its
 108 libraries are:
 109
 110     cd /usr/lib/httpd/perl
 111     echo "use lib qw(/usr/lib/httpd/perl);1;" > startup.pl
 112
 113 Then you can put in your /etc/httpd/conf/httpd.conf:
 114
 115     PerlModule Apache2
 116     PerlRequire /usr/lib/httpd/perl/startup.pl
 117
 118 Finally, you specify a location like:
 119
 120   <Location /foundation>
 121     SetHandler perl-script
 122      PerlResponseHandler  Interchange::Link
 123      PerlOptions +GlobalRequest
 124          # Make sure you set SocketPerms to 0666 (or 0660 with appropriate
 125          # setgid group ownership of the directory)
 126      PerlSetVar InterchangeServer /var/run/interchange/socket
 127      PerlSetVar OrdinaryFileList "/foundation/images/ /foundation/dl/"
 128   </Location>
 129
 130 Note: The Apache <Location> path should not contain a dot (.) or any
 131 other characters except A-Z, a-z, 0-9 or a hyphen (-), so:
 132
 133     <Location /shop.name> is invalid, whereas:
 134     <Location /shop-name> is valid.
 135
 136 The specifics of the configuration are discussed in the next section.
 137
 138 =head1 CONFIGURATION
 139
 140 The module understands directives set via the mod_perl C<PerlSetVar>
 141 directive.
 142
 143 =over 4
 144
 145 =item InterchangeServer
 146
 147 This specifies the way to contact the
 148 primary and possibly additionial Interchange servers. The InterchangeServer
 149 directive takes either a pathname to the Interchange UNIX socket or a
 150 host:port specification if you want to use INET mode.
 151
 152 Normally this takes the form of:
 153
 154      PerlSetVar InterchangeServer /var/run/interchange/socket
 155
 156 Note that your file permissions for the socket file need to allow the
 157 Apache User uid to read and write it. This usually means "SocketPerms
 158 0666" or in interchange.cfg.  You can also do "SocketPerms 0660" if you
 159 set the group of the containing directory to the Apache Group value,
 160 and change the directory permissions to enable the setgid bit. (That is
 161 accomplished with "chmod g+s <directory>".)
 162
 163 If you want to specify more than one so that a backup server can provide
 164 request support in case of failure:
 165
 166     PerlSetVar InterchangeServer  "/var/run/interchange/socket 10.1.1.1:7786"
 167
 168 The optional InterchangeServerBackup directive takes the same arguments,
 169 but should obviously point to a different Interchange server than the
 170 primary.  The InterchangeServerBackup directive is only of any use if
 171 you have multiple Interchange servers configured in a clustered environment.
 172
 173 If you want to randomly select from a series of clustered servers, do:
 174
 175     PerlSetVar InterchangeServer "10.1.1.1:7786 10.1.1.2:7786 10.1.1.3:7786"
 176     PerlSetVar RandomServer 1
 177
 178 Note: The Apache <Location> path should not contain a dot (.) or any
 179 other characters except A-Z, a-z, 0-9 or a hyphen (-), so:
 180
 181     <Location /shop.name> is invalid, whereas:
 182     <Location /shop-name> is valid.
 183
 184 Example of a UNIX mode local connection:
 185
 186     <Location /shop>
 187     SetHandler perl-script
 188     PerlResponseHandler Interchange::Link
 189     PerlSetVar InterchangeServer /opt/interchange/etc/socket
 190     </Location>
 191
 192 Example of INET mode local connection:
 193
 194     <Location /shop>
 195     SetHandler perl-script
 196     PerlResponseHandler Interchange::Link
 197     PerlSetVar InterchangeServer localhost:7786
 198     </Location>
 199
 200 UNIX mode local primary connection and INET mode remote backup connection:
 201
 202     <Location /shop>
 203     SetHandler perl-script
 204     PerlResponseHandler Interchange::Link
 205     PerlSetVar InterchangeServer /opt/interchange/etc/socket
 206     PerlSetVar InterchangeServerBackup another.server.com:7786
 207     </Location>
 208
 209 The default if not set is C<127.0.0.1:7786>.
 210
 211 =item ConnectTries and ConnectRetryDelay
 212
 213 The ConnectTries parameter specifies the number of connection attempts to
 214 make before giving up.  ConnectRetryDelay specifies the delay, in seconds,
 215 between each retry attempt.
 216
 217 The ConnectTries default is 10 and the ConnectRetryDelay default is 2 seconds.
 218 Here is an example:
 219
 220     <Location /shop>
 221     SetHandler perl-script
 222     PerlResponseHandler Interchange::Link
 223     PerlSetVar ConnectTries 10
 224     PerlSetVar ConnectRetryDelay 1
 225     </Location>
 226
 227 =item DropRequestList
 228
 229 The DropRequestList allows a list of space-separated URI components
 230 to be specified.  If one of the list entries is found anywhere in the
 231 requested URI, the request will be dropped with a 404 (not found) error,
 232 without the request being passed to Interchange.  This parameter is useful
 233 for blocking known Microsoft IIS attacks like "Code Red", so that we don't
 234 waste any more time processing the (bogus) requests than we have to.
 235
 236     <Location /shop>
 237     SetHandler perl-script
 238     PerlResponseHandler Interchange::Link
 239     PerlSetVar DropRequestList "/default.ida /x.ida /cmd.exe /root.exe"
 240     </Location>
 241
 242 =item OrdinaryFileList
 243
 244 The OrdinaryFileList allows a list of space-separated URI path
 245 components to be specified.  If one of the list entries is found at the
 246 start of any request then that request will not be passed to Interchange.
 247 Instead, the file will be directly served by Apache.  For example:
 248
 249     <Location />
 250     SetHandler perl-script
 251     PerlResponseHandler Interchange::Link
 252     PerlSetVar OrdinaryFileList "/foundation/ /interchange-5/ /robots.txt"
 253     </Location>
 254
 255 This will result in the following:
 256
 257     www.example.com/index.html          (handled by Interchange)
 258     www.example.com/ord/basket.html     (handled by Interchange)
 259     www.example.com/foundation/images/somefile.gif (served by Apache)
 260     www.example.com/robots.txt          (served by Apache)
 261
 262 You should add a trailing slash to directory names to prevent, for instance,
 263 "/images/foo.gif" from being confused with the likes of "/images.html".
 264 If OrdinaryFileList was set to "/images" then both of those requests would
 265 be handled by Apache.  If OrdinaryFileList was set to "/images/" then
 266 "/images/foo.gif" would be handled by Apache and "/images.html" would be
 267 handled by Interchange.
 268
 269 If you're using "<Location />" then you will need a dummy "index.html" file
 270 in your VirtualHost's DocumentRoot directory to avoid permission problems
 271 assocated with the Apache directory index creation code.
 272
 273 =item InterchangeScript
 274
 275 The InterchangeScript parameter allows the SCRIPT_NAME to be different from
 276 the <Location>.  For example:
 277
 278     <Location /shop>
 279         ...
 280     </Location>
 281
 282 The above will set the SCRIPT_NAME to "/shop".
 283
 284     <Location /shop>
 285         ...
 286     PerlSetVar InterchangeScript /foo
 287     </Location>
 288
 289 The above will set the SCRIPT_NAME to "/foo", instead of "/shop"  before
 290 passing the request to Interchange.
 291
 292 The appropriate SCRIPT_NAME must be configured into the "Catalog"
 293 directive in your interchange.cfg file.
 294
 295 =item FileDeliveryBase
 296
 297 Interchange::Link can deliver files without needing to keep Interchange
 298 open. To do this, you set the HTTP Status: header to C<httpd_deliver>.
 299 In Interchange 5.0 or higher you can do this by putting in a page:
 300
 301     [deliver
 302         status=httpd_deliver
 303         location=directory/file.ext
 304         type=application/octet-stream
 305        ]
 306
 307 The C<FileDeliveryBase> setting determines where the file will be
 308 relative to. While you can set it to C</>, that is not recommended
 309 as files like C</etc/passwd> could be delivered.
 310
 311 The default is the document root of the Apache server. To protect
 312 files from being served directly by Apache, you can either put them
 313 under a directory at the Interchange location, or you can use normal
 314 Apache exclusions.
 315
 316 =item NoBlankLines
 317
 318 Set C<NoBlankLines> to 1 to remove blank lines from the outputted source
 319 code.
 320
 321 =back
 322
 323 =head1 BUGS
 324
 325 Send bug reports and suggestions to the Interchange users list,
 326 <interchange-users@icdevgroup.org>.
 327
 328 =head1 COPYRIGHT AND LICENSE
 329
 330  Copyright (C) 2002-2009 Interchange Development Group
 331  Copyright (C) 1996-2002 Red Hat, Inc.
 332
 333 This program is free software.  You can redistribute it and/or modify
 334 it under the terms of the GNU General Public License as published by
 335 the Free Software Foundation.  You may refer to either version 2 of the
 336 License or (at your option) any later version.
 337
 338 This program is distributed in the hope that it will be useful, but
 339 WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
 340 or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
 341 for more details.
 342
 343 =cut
 344
 345 my %config;
 346
 347 sub setup_location {
 348     my $r = shift;
 349     my $s = $r->server;
 350     my $location = $r->location;
 351
 352     return $config{$location} if $config{$location} && !($s->is_virtual());
 353
 354 #warn "Getting location $location\n";
 355
 356     my $c = $config{$location} = {};
 357
 358     $c->{InterchangeScript} = $r->dir_config('InterchangeScript') || $location;
 359
 360     my @OrdinaryFileList;
 361     ORDINARY: {
 362         my $ordstring = $r->dir_config('OrdinaryFileList')
 363             or last ORDINARY;
 364         @OrdinaryFileList = grep /\S/, split /\s+/, $ordstring;
 365         for (@OrdinaryFileList) {
 366             $_ = qr(^$_);
 367         }
 368     }
 369
 370     my @DropRequestList;
 371     DROPREQ: {
 372         my $dropstring = $r->dir_config('DropRequestList')
 373             or last DROPREQ;
 374         @DropRequestList = grep /\S/, split /\s+/, $dropstring;
 375         for (@DropRequestList) {
 376             $_ = qr(^$_$);
 377         }
 378     }
 379
 380     SERVPOOL: {
 381         my $serverpool = $r->dir_config('ServerPool');
 382         if(! $serverpool) {
 383             $serverpool = $r->dir_config('InterchangeServer');
 384             if($serverpool and $r->dir_config('InterchangeServerBackup')) {
 385                 $serverpool .= " " . $r->dir_config('InterchangeServerBackup');
 386             }
 387         }
 388
 389         $serverpool ||= '127.0.0.1:7786';
 390         $serverpool =~ s/^\s+//;
 391         $serverpool =~ s/\s+$//;
 392
 393         my @servpool = split /\s+/, $serverpool;
 394         $c->{ServerPool} = \@servpool;
 395     }
 396
 397     my $base = $r->dir_config('FileDeliveryBase') || $r->document_root;
 398         $base =~ s:/*$:/: unless $base eq '/';
 399
 400         $c->{FileDeliveryBase} = $base;
 401
 402     $c->{RandomServer} = $r->dir_config('RandomServer');
 403
 404     $c->{ConnectTries} = $r->dir_config('ConnectTries') || 10;
 405     $c->{ConnectRetryDelay} = $r->dir_config('ConnectRetryDelay') || 2;
 406
 407     $c->{DropRequestList} = \@DropRequestList if @DropRequestList;
 408     $c->{OrdinaryFileList} = \@OrdinaryFileList if @OrdinaryFileList;
 409
 410     return $c;
 411 }
 412
 413 my $arg;
 414 my $env;
 415 my $ent;
 416
 417
 418 sub server_not_running {
 419
 420     my $r = shift;
 421     my $msg;
 422
 423     warn "ALERT: Interchange server not running for $ENV{SCRIPT_NAME}\n";
 424
 425     $r->content_type ("text/html");
 426     $r->print (<<EOF);
 427 <html><head><title>Service unavailable</title></head>
 428 <body>
 429 <p>
 430 We are temporarily out of service or may be experiencing high system demand.
 431 Please try again soon.
 432 </p>
 433 </body>
 434 </html>
 435 EOF
 436 # use for debugging:
 437 #$arg
 438 #$env
 439 #$ent
 440
 441 }
 442
 443 # Read the entity from stdin if present.
 444
 445 sub send_arguments {
 446
 447     my $count = @ARGV;
 448     my $val = "arg $count\n";
 449     for(@ARGV) {
 450         $val .= length($_);
 451         $val .= " $_\n";
 452     }
 453     return $val;
 454 }
 455
 456 sub send_environment {
 457     my $r = shift;
 458     my $c = $r->connection;
 459
 460 #warn("Connection=$c");
 461
 462     my ($str);
 463     my $val = '';
 464     my $count = 0;
 465
 466     my $uri = $r->uri;
 467 #warn "uri=$uri\n";
 468
 469     my $location = $r->location;
 470     my $cfg = setup_location($r);
 471
 472     if(my $ord = $cfg->{OrdinaryFileList}) {
 473         for(@$ord) {
 474 #warn "checking for OrdinaryFile $_\n";
 475             next unless $uri =~ $_;
 476             $global_status = Apache2::Const::DECLINED;
 477             return undef;
 478         }
 479     }
 480
 481     if(my $drop = $cfg->{DropRequestList}) {
 482         for(@$drop) {
 483 #warn "checking for DropRequest $_\n";
 484             next unless $uri =~ $_;
 485             $r->headers_out->{Status} = '404 Not found';
 486             $r->content_type('text/html');
 487 #warn "dropping request for $uri\n";
 488             $global_status = Apache2::Const::NOT_FOUND;
 489             return undef;
 490         }
 491     }
 492
 493     my $method = $r->method;
 494 #warn "method=$method\n";
 495
 496     $uri =~ s{^$location}{} unless $location eq '/';
 497
 498     my $query = $r->args;
 499
 500     my $script = $cfg->{InterchangeScript};
 501
 502     my %header_map = qw/
 503         AUTHORIZATION_TYPE   AUTH_TYPE
 504         AUTHORIZATION        AUTHORIZATION
 505         COOKIE               HTTP_COOKIE
 506         CLIENT_HOSTNAME      REMOTE_HOST
 507         CLIENT_IP_ADDRESS    REMOTE_ADDR
 508         CLIENT_IDENT         REMOTE_IDENT
 509         CONTENT_LENGTH       CONTENT_LENGTH
 510         CONTENT_TYPE         CONTENT_TYPE
 511         COOKIE               HTTP_COOKIE
 512         FROM                 HTTP_FROM
 513         HOST                 HTTP_HOST
 514         HTTPS_ON             HTTPS
 515         METHOD               REQUEST_METHOD
 516         PATH_INFO            PATH_INFO
 517         PATH_TRANSLATED      PATH_TRANSLATED
 518         PRAGMA               HTTP_PRAGMA
 519         QUERY                QUERY_STRING
 520         RECONFIGURE          RECONFIGURE_MINIVEND
 521         REFERER              HTTP_REFERER
 522         SCRIPT               SCRIPT_NAME
 523         SERVER_HOST          SERVER_NAME
 524         SERVER_PORT          SERVER_PORT
 525         USER_AGENT           HTTP_USER_AGENT
 526         CONTENT_ENCODING     HTTP_CONTENT_ENCODING
 527         CONTENT_LANGUAGE     HTTP_CONTENT_LANGUAGE
 528         CONTENT_TRANSFER_ENCODING HTTP_CONTENT_TRANSFER_ENCODING
 529     /;
 530
 531     my %header;
 532     for(keys %{$r->headers_in}) {
 533         my $val = $r->headers_in->{$_};
 534         my $k = uc $_;
 535         $k =~ s/-/_/g;
 536         $k = $header_map{$k} || "HTTP_$k";
 537         $header{$k} = $val;
 538 #warn "header $_/$k=$val\n";
 539     }
 540
 541     my @pairs = (
 542         SCRIPT_NAME    => $script,
 543         REQUEST_METHOD => $r->method,
 544         PATH_INFO       => $uri,
 545         MOD_PERL        => 1,
 546         QUERY_STRING    => $query,
 547         REMOTE_ADDR     => $c->remote_ip,
 548         %header,
 549         %ENV,
 550     );
 551
 552     my %seen;
 553
 554     while (@pairs) {
 555         my $n = shift @pairs;
 556         my $v = shift @pairs;
 557         next if $seen{$n}++;
 558
 559         $count++;
 560         $str = "$n=$v";
 561         $val .= length($str);
 562         $val .= " $str\n";
 563     }
 564     $val = "env $count\n$val";
 565     return $val;
 566 }
 567
 568 sub check_entity {
 569     my $r = shift;
 570     my $len = $r->headers_in->{'Content-Length'};
 571     return '' unless $len > 0;
 572     return "entity\n$len ";
 573 }
 574
 575 sub shuffle {
 576     my $array = shift;
 577     my $i;
 578     for ($i = @$array; --$i; ) {
 579         my $j = int rand ($i+1);
 580         next if $i == $j;
 581         @$array[$i,$j] = @$array[$j,$i];
 582     }
 583 }
 584
 585 sub handler {
 586     my $r = shift;
 587 #warn "current location=" . $r->location . "\n";
 588
 589     my $uri = $r->uri;
 590 #warn "Entering handler.\n";
 591     $arg = send_arguments($r);
 592 #warn "Got arguments.\n";
 593     $env = send_environment($r)
 594         or return $global_status;
 595 #warn "Got environment.\n";
 596     $ent = check_entity($r);
 597 #warn "Got entity.\n";
 598
 599     my $cfg = setup_location($r);
 600
 601     $SIG{PIPE} = 'IGNORE';
 602     $SIG{ALRM} = sub { server_not_running($r); exit 1; };
 603
 604     my ($remote, $port, $iaddr, $paddr, $proto, $line);
 605
 606     my $ok;
 607
 608     local(*SOCK);
 609
 610     my $socklist = $cfg->{ServerPool};
 611
 612     if($cfg->{RandomServer}) {
 613         $socklist = [ @$socklist ];
 614         shuffle($socklist);
 615     }
 616
 617     my $tries = 0;
 618     while ($tries++ < $cfg->{ConnectTries}) {
 619         for my $sockname (@$socklist) {
 620 #warn "InterchangeServer=$sockname\n";
 621             if($sockname =~ m{/}) {
 622                 socket(SOCK, PF_UNIX, SOCK_STREAM, 0)   or die "socket: $!\n";
 623                 $paddr = sockaddr_un($sockname);
 624 #warn "vlink $sockname RandomServer=$cfg->{RandomServer}\n";
 625             }
 626             else {
 627                 ($remote, $port) = split /:/, $sockname, 2;
 628 #warn "tlink remote=$remote port=$port RandomServer=$cfg->{RandomServer}\n";
 629                 $port ||= 7786;
 630
 631                 if ($port =~ /\D/) { $port = getservbyname($port, 'tcp'); }
 632
 633                 $iaddr = inet_aton($remote);
 634                 $paddr = sockaddr_in($port,$iaddr);
 635
 636                 $proto = getprotobyname('tcp');
 637
 638                 socket(SOCK, PF_INET, SOCK_STREAM, $proto)  or die "socket: $!\n";
 639             }
 640
 641
 642         #warn "Ready to connect.\n";
 643             do {
 644                $ok = connect(SOCK, $paddr);
 645             } while ( ! defined $ok and $! =~ /interrupt/i);
 646
 647             my $def = defined $ok;
 648             warn "ok=$ok defined=$def sockname=$sockname: $!\n" if ! $ok;
 649             next unless $ok;
 650             last;
 651     #warn "Connected.\n";
 652         }
 653         last if $ok;
 654         sleep($cfg->{ConnectRetryDelay});
 655     }
 656
 657     $ok   or do {
 658                     server_not_running($r);
 659                     return Apache2::Const::OK;
 660             };
 661
 662     my $former = select SOCK;
 663     $| = 1;
 664     select $former;
 665
 666     alarm 0;
 667
 668     print SOCK $arg;
 669     print SOCK $env;
 670     if($ent) {
 671 #warn "there is an entity=$ent";
 672         print SOCK $ent;
 673         while(<>) {
 674             print SOCK $_;
 675         }
 676         print SOCK "\n";
 677     }
 678
 679     print SOCK "end\n";
 680
 681     my @out;
 682     my @header;
 683 #warn "reading from SOCK\n";
 684     while( <SOCK> ) {
 685 #warn "GOT header read from SOCK: $_\n";
 686         last unless /\S/;
 687         push @header, $_;
 688     }
 689
 690     my $set_status;
 691     my $set_content;
 692     my $deliver_object;
 693
 694     for(@header) {
 695         next unless /^[-\w]+:/;
 696         s/\s+$//;
 697         my ($k, $v) = split /:\s*/, $_, 2;
 698         my $lc = lc $k;
 699         if($lc eq 'content-type') {
 700             $set_content = $v;
 701             next;
 702         }
 703         elsif($lc eq 'status') {
 704             $set_status = $v;
 705         }
 706                 elsif($lc eq 'mod-perl-deliver') {
 707                         $deliver_object = $v;
 708                 }
 709 #warn "Setting header=$k to '$v'\n";
 710         $r->headers_out->{$k} = $v;
 711     }
 712
 713     $set_content ||= 'text/html';
 714
 715     if($set_status) {
 716         if($set_status =~ /^30[21]/) {
 717 #warn "Doing redirect\n";
 718             $r->content_type($set_content);
 719             close (SOCK)                                or die "close: $!\n";
 720             return Apache2::Const::HTTP_MOVED_PERMANENTLY if $set_status == 301;
 721             return Apache2::Const::REDIRECT;
 722         }
 723         elsif($set_status =~ /^404/) {
 724 #warn "404 not found status\n";
 725             close (SOCK)                                or die "close: $!\n";
 726             return Apache2::Const::NOT_FOUND;
 727         }
 728                 elsif($set_status eq 'httpd_deliver') {
 729                         $deliver_object = $set_status;
 730                 }
 731     }
 732
 733         if($deliver_object) {
 734                 my $fn = $r->headers_out->{Location}
 735                         or die "No location for delivery.\n";
 736
 737                 $fn =~ s:^/*:$cfg->{FileDeliveryBase}:;
 738
 739                 close SOCK                                or die "close: $!\n";
 740                 unless (open IN, "< $fn") {
 741                         warn "cannot open mod_perl_deliver $fn: $!\n";
 742                         $r->content_type('text/html');
 743                         if(! -e $fn) {
 744                                 $r->headers_out->{Status} = '404 Not found';
 745                                 return Apache2::Const::NOT_FOUND;
 746                         }
 747                         else {
 748                                 $r->headers_out->{Status} = '403 Permission denied';
 749                                 return Apache2::Const::FORBIDDEN;
 750                         }
 751                 }
 752
 753                 $r->headers_out->{Status} = '200 OK';
 754                 $r->headers_out->{'Content-Length'} = -s $fn;
 755                 $r->content_type($set_content);
 756
 757                 while(<IN>) {
 758                         print
 759                                 or die "recipient write for $deliver_object failed: $!\n";
 760                 }
 761                 close IN
 762                         or die "cannot close $deliver_object: $!\n";
 763         }
 764         else {
 765
 766                 $r->content_type($set_content);
 767                 my $no_blank_lines = $r->dir_config('NoBlankLines');
 768                 while (<SOCK>) {
 769                         push @out, $_ unless $no_blank_lines and ! /\S/;
 770                 }
 771                 close (SOCK)                                or die "close: $!\n";
 772                 print @out;
 773         }
 774
 775 #warn "Returning OK\n";
 776     return Apache2::Const::OK;
 777 }
 778
 779 1;