code/SystemTag/deliver.coretag

   1 # Copyright 2002-2007 Interchange Development Group and others
   2 #
   3 # This program is free software; you can redistribute it and/or modify
   4 # it under the terms of the GNU General Public License as published by
   5 # the Free Software Foundation; either version 2 of the License, or
   6 # (at your option) any later version.  See the LICENSE file for details.
   7 #
   8 # $Id: deliver.coretag,v 1.8 2007-03-30 23:40:49 pajamian Exp $
   9
  10 UserTag deliver Order     type
  11 UserTag deliver HasEndTag
  12 UserTag deliver addAttr
  13 UserTag deliver Version   $Revision: 1.8 $
  14 UserTag deliver Routine   <<EOR
  15 sub {
  16         my ($type, $opt, $body) = @_;
  17         my $out;
  18         use vars qw/$Tag/;
  19         $Tag ||= new Vend::Tags;
  20         if($opt->{file}) {
  21                 return undef unless -f $opt->{file};
  22
  23                 my ($tmp, %rfopt);
  24
  25                 # determine mime type devoid of explicit value
  26                 $type ||= Vend::Util::mime_type($opt->{file});
  27
  28                 # avoid encoding of binary files
  29                 if ($type !~ m{^text/}i) {
  30                         $rfopt{encoding} = 'raw';
  31                 }
  32
  33                 $tmp = readfile($opt->{file}, undef, undef, \%rfopt);
  34                 $out = \$tmp;
  35         }
  36         elsif(ref $body) {
  37                 $out = $body;
  38         }
  39         elsif(length $body) {
  40                 $out = \$body;
  41         }
  42
  43         ## This is a bounce, returns
  44         if($opt->{location}) {
  45                 $type = Vend::Util::header_data_scrub($type);
  46                 $opt->{status} = Vend::Util::header_data_scrub($opt->{status});
  47                 $opt->{location} = Vend::Util::header_data_scrub($opt->{location});
  48
  49                 $type and $Tag->tag( {
  50                                                 op => 'header',
  51                                                 name => 'Content-Type',
  52                                                 content => $type,
  53                                         } );
  54                 $Tag->tag( {    op => 'header',
  55                                                         name => 'Status',
  56                                                         content => $opt->{status} || '302 moved',
  57                                                 } );
  58                 $Tag->tag( {    op => 'header',
  59                                                         name => 'Location',
  60                                                         content => $opt->{location},
  61                                                 } );
  62                 if(! $body) {
  63                         $body = qq{Redirecting to <A href="%s">%s</a>.};
  64                         $body = errmsg($body, $opt->{location}, $opt->{location});
  65                 }
  66                 ::response($body);
  67                 $Vend::Sent = 1;
  68                 return 1;
  69         }
  70
  71         $type ||= 'application/octet-stream';
  72
  73         $Tag->tag( { op => 'header', name => 'Status', content => $opt->{status} } )
  74                 if $opt->{status};
  75         $Tag->tag( { op => 'header', name => 'Content-Type', content => $type } );
  76
  77         if($opt->{get_encrypted}) {
  78                 $opt->{get_encrypted} = 1 unless $opt->{get_encrypted} =~ /^\d+$/;
  79                 my $idx = $opt->{get_encrypted};
  80                 while ($idx--) {
  81                         $$out =~ s/.*?(---+BEGIN PGP MESSAGE--+)/$1/s;
  82                 }
  83                 $$out =~ s/(---+END PGP MESSAGE---+).*/$1\n/s;
  84         }
  85
  86         if($opt->{extra_headers}) {
  87                 my @lines = grep /\S/, split /[\r\n]+/, $opt->{extra_headers};
  88                 for(@lines) {
  89                         my ($header, $val) = split /:/, $_;
  90                         $Tag->tag( {    op => 'header',
  91                                                 name => $header,
  92                                                 content => $val,
  93                                         } );
  94                 }
  95         }
  96         $::Pragma->{download} = 1;
  97         ::response($out);
  98         $Vend::Sent = 1;
  99         return 1;
 100 }
 101 EOR