Headers already sent. at /www/CPAN/lib/site_perl/5.8.8/Mungo/Response.pm line 184.

[    1]    1: package Mungo::Response;
[    2]    2: 
[    3]    3: # Copyright (c) 2007 OmniTI Computer Consulting, Inc. All rights reserved.
[    4]    4: # For information on licensing see:
[    5]    5: #   https://labs.omniti.com/zetaback/trunk/LICENSE
[    6]    6: 
[    7]    7: =head1 NAME
[    8]    8: 
[    9]    9: Mungo::Response - Represent response side of HTTP request cycle
[   10]   10: 
[   11]   11: =head1 SYNOPSIS
[   12]   12: 
[   13]   13:   <!-- You get a Response object for free when you use Mungo -->
[   14]   14:   <% if ($Response) { ... } %>
[   15]   15: 
[   16]   16:   <!-- Read and Mungo-process other files -->
[   17]   17:   <%
[   18]   18:      # Prints to browser
[   19]   19:      $Response->Include('/some/file.html', $arg1);
[   20]   20: 
[   21]   21:      # Caputured
[   22]   22:      my $output = $Response->TrapInclude('/some/file.html');
[   23]   23: 
[   24]   24:      # Can also print to browser via Response
[   25]   25:      print $Response "Hello world!";
[   26]   26:   %>
[   27]   27: 
[   28]   28:   <!-- May also set headers -->
[   29]   29:   <%
[   30]   30:      $Response->AddHeader('header_name' => $value);
[   31]   31:   %>
[   32]   32: 
[   33]   33:   <!-- Halt processing and jump out of the handler -->
[   34]   34:   <%
[   35]   35:      # With a 302
[   36]   36:      $Response->Redirect('/new/url/');
[   37]   37: 
[   38]   38:      # Just end
[   39]   39:      $Response->End();
[   40]   40:   %>
[   41]   41: 
[   42]   42:   <!-- Cookie facility -->
[   43]   43:   <%
[   44]   44:      # Single valued cookies
[   45]   45:      $Response->Cookies($cookie_name, $cookie_value);
[   46]   46: 
[   47]   47:      # Multivalued cookies
[   48]   48:      $Response->Cookies($cookie_name, $key, $value);
[   49]   49: 
[   50]   50:      # Cookie options
[   51]   51:      $Response->Cookies($cookie_name, 'Domain', $value);
[   52]   52:      $Response->Cookies($cookie_name, 'Expires', $value);
[   53]   53:      $Response->Cookies($cookie_name, 'Path', $value);
[   54]   54:      $Response->Cookies($cookie_name, 'Secure', $value);
[   55]   55:   %>
[   56]   56: 
[   57]   57: =head1 DESCRIPTION
[   58]   58: 
[   59]   59: Represents the response side of the Mungo request cycle.
[   60]   60: 
[   61]   61: =cut
[   62]   62: 
[   63]   63: 
[   64]   64: use strict;
[   65]   65: use IO::Handle;
[   66]   66: use Mungo::Arbiter::Response;
[   67]   67: use Mungo::Response::Trap;
[   68]   68: use Mungo::Cookie;
[   69]   69: use Mungo::Utils;
[   70]   70: use HTML::Entities;
[   71]   71: our $AUTOLOAD;
[   72]   72: 
[   73]   73: my $one_true_buffer = '';
[   74]   74: 
[   75]   75: sub new {
[   76]   76:   my $class = shift;
[   77]   77:   my $parent = shift;
[   78]   78:   my $r = $parent->{'Apache::Request'};
[   79]   79:   my $singleton = $r->pnotes(__PACKAGE__);
[   80]   80:   return $singleton if ($singleton);
[   81]   81:   my %core_data = (
[   82]   82:     'Apache::Request' => $r,
[   83]   83:     'ContentType' => $r->dir_config('MungoContentType') || $r->content_type || 'text/html',
[   84]   84:     # We don't set buffer here, we set it after it has been tied.
[   85]   85:     # 'Buffer' => $r->dir_config('MungoBuffer') || 0,
[   86]   86:     'Buffer' => 0,
[   87]   87:     'CacheControl' => $r->dir_config('MungoCacheControl') || 'private',
[   88]   88:     'Charset' => $r->dir_config('MungoCharset') || undef,
[   89]   89:     'Status' => 200,
[   90]   90:     'Mungo' => $parent,
[   91]   91:     'CookieClass' => $r->dir_config('MungoCookieClass') || 'Mungo::Cookie',
[   92]   92:     'Cookies' => undef, # placeholder for visibility
[   93]   93:   );
[   94]   94:   my %data;
[   95]   95:   $singleton = bless \%data, $class;
[   96]   96:   tie %data, 'Mungo::Arbiter::Response', $singleton, \%core_data;
[   97]   97:   $singleton->{Buffer} = $r->dir_config('MungoBuffer') || 0;
[   98]   98:   $r->pnotes(__PACKAGE__, $singleton);
[   99]   99:   return $singleton;
[  100]  100: }
[  101]  101: 
[  102]  102: sub DESTROY {
[  103]  103:   my $self = shift;
[  104]  104:   $self->cleanse();
[  105]  105: }
[  106]  106: 
[  107]  107: sub cleanse {
[  108]  108:   my $self = shift;
[  109]  109:   my $_r = tied %$self;
[  110]  110:   if(ref $_r->{data}->{'IO_stack'} eq 'ARRAY') {
[  111]  111:     while (@{$_r->{data}->{'IO_stack'}}) {
[  112]  112:       my $fh = pop @{$_r->{data}->{'IO_stack'}};
[  113]  113:       close(select($fh));
[  114]  114:     }
[  115]  115:   }
[  116]  116:   delete $_r->{data}->{$_} for keys %$self;
[  117]  117:   untie %$self if tied %$self;
[  118]  118: }
[  119]  119: 
[  120]  120: sub send_http_header {
[  121]  121:   my $self = shift;
[  122]  122:   my $_r = tied %$self;
[  123]  123:   my $r = $_r->{data}->{'Apache::Request'};
[  124]  124:   return if($_r->{data}->{'__HEADERS_SENT__'});
[  125]  125:   $_r->{data}->{'__HEADERS_SENT__'} = 1;
[  126]  126:   if($_r->{data}->{CacheControl} eq 'no-cache') {
[  127]  127:     $r->no_cache(1);
[  128]  128:   }
[  129]  129:   else {
[  130]  130:     if($r->can('headers_out')) {
[  131]  131:       $r->err_headers_out->set('Cache-Control' => $_r->{data}->{CacheControl});
[  132]  132:     }
[  133]  133:     else {
[  134]  134:       $r->err_header_out('Cache-Control' => $_r->{data}->{CacheControl});
[  135]  135:     }
[  136]  136:   }
[  137]  137:   # Must use Internal as the tiehash is magic for cookies
[  138]  138:   $_r->{'__Internal__'}->{Cookies}->inject_headers($r);
[  139]  139:   $r->status($_r->{data}->{Status});
[  140]  140:   $r->can('send_http_header') ?
[  141]  141:     $r->send_http_header($_r->{data}->{ContentType}) :
[  142]  142:     $r->content_type($_r->{data}->{ContentType});;
[  143]  143: }
[  144]  144: 
[  145]  145: sub start {
[  146]  146:   my $self = shift;
[  147]  147:   my $_r = tied %$self;
[  148]  148:   return if(exists $_r->{data}->{'IO_stack'} &&
[  149]  149:             scalar(@{$_r->{data}->{'IO_stack'}}) > 0);
[  150]  150:   $_r->{data}->{'IO_stack'} = [];
[  151]  151:   tie *DIRECT, ref $self, $self;
[  152]  152:   push @{$_r->{data}->{'IO_stack'}}, select(DIRECT);
[  153]  153: }
[  154]  154: 
[  155]  155: sub finish {
[  156]  156:   my $self = shift;
[  157]  157:   my $_r = tied %$self;
[  158]  158:   # Unbuffer outselves, this will actually induce a flush (must go through tiehash)
[  159]  159:   $_r->{'__Internal__'}->{Buffer} = 0;
[  160]  160:   untie *DIRECT if tied *DIRECT;
[  161]  161:   return unless(exists $_r->{data}->{'IO_stack'});
[  162]  162:   my $fh = $_r->{data}->{'IO_stack'}->[0];
[  163]  163:   die __PACKAGE__." IO stack of wrong depth" if(scalar(@{$_r->{data}->{'IO_stack'}}) != 1);
[  164]  164: }
[  165]  165: 
[  166]  166: =head2 $Response->AddHeader('header_name' => 'header_value');
[  167]  167: 
[  168]  168: Adds an HTTP header to the response.
[  169]  169: 
[  170]  170: Dies if headers (or any other output) has already been sent.
[  171]  171: 
[  172]  172: =cut
[  173]  173: 
[  174]  174: sub AddHeader {
[  175]  175:   my $self = shift;
[  176]  176:   my $_r = tied %$self;
[  177]  177:   my $r = $_r->{data}->{'Apache::Request'};
[  178]  178:   die "Headers already sent." if($_r->{data}->{'__HEADERS_SENT__'});
[  179]  179:   $r->can('headers_out') ? $r->err_headers_out->set(@_) : $r->err_header_out(@_);
[  180]  180: }
[  181]  181: sub Cookies {
[  182]  182:   my $self = shift;
[  183]  183:   my $_r = tied %$self;
[* 184]  184:   die "Headers already sent." if($_r->{data}->{'__HEADERS_SENT__'});
[  185]  185:   # Must use Internal as the tiehash is magic for cookies
[  186]  186:   my $cookie = $_r->{'__Internal__'}->{'Cookies'};
[  187]  187:   $cookie->__set(@_);
[  188]  188: }
[  189]  189: 
[  190]  190: =head2 $Response->Redirect($url);
[  191]  191: 
[  192]  192: Issues a 302 redirect with the new location as $url.
[  193]  193: 
[  194]  194: Dies if headers (or any other output) has already been sent.
[  195]  195: 
[  196]  196: =cut
[  197]  197: 
[  198]  198: sub Redirect {
[  199]  199:   my $self = shift;
[  200]  200:   my $url = shift;
[  201]  201:   my $_r = tied %$self;
[  202]  202:   die "Cannot redirect, headers already sent\n" if($_r->{data}->{'__HEADERS_SENT__'});
[  203]  203:   $_r->{data}->{Status} = shift || 302;
[  204]  204:   my $r = $_r->{data}->{'Apache::Request'};
[  205]  205:   $r->can('headers_out') ? $r->err_headers_out->set('Location', $url) :
[  206]  206:                            $r->err_header_out('Location', $url);
[  207]  207:   $self->send_http_header();
[  208]  208:   $self->End();
[  209]  209: }
[  210]  210: 
[  211]  211: 
[  212]  212: =head2 $res->Include($filename, $arg1, $arg2, ...);
[  213]  213: 
[  214]  214: =head2 $res->Include(\$string, $arg1, $arg2, ...);
[  215]  215: 
[  216]  216: Reads the given filename or string and interprets it as Mungo ASP code.
[  217]  217: 
[  218]  218: Any passed arguments are available in the @_ array within the ASP code.
[  219]  219: 
[  220]  220: The results of evaluating the code is printed to STDOUT.
[  221]  221: 
[  222]  222: =cut
[  223]  223: 
[  224]  224: sub Include {
[  225]  225:   my $self = shift;
[  226]  226:   my $subject = shift;
[  227]  227:   my $_r = tied %$self;
[  228]  228:   my $rv;
[  229]  229:   eval {
[  230]  230:     local $SIG{__DIE__} = \&Mungo::MungoDie;
[  231]  231:     if(ref $subject) {
[  232]  232:       $rv = $_r->{data}->{Mungo}->include_mem($subject, @_);
[  233]  233:     }
[  234]  234:     else {
[  235]  235:       $rv = $_r->{data}->{Mungo}->include_file($subject, @_);
[  236]  236:     }
[  237]  237:   };
[  238]  238:   if($@) {
[  239]  239:     # If we have more than 1 item in the IO stack, we should just re-raise.
[  240]  240:     if (scalar(@{$_r->{data}->{'IO_stack'} || []}) > 1) {
[  241]  241:       local $SIG{__DIE__} = undef;
[  242]  242:       die $@;
[  243]  243:     }
[  244]  244:     my $hashref = $@;
[  245]  245:     eval {
[  246]  246:       if($_r->{data}->{OnError}) {
[  247]  247:         $_r->{data}->{OnError}->($self, $hashref, $subject);
[  248]  248:       }
[  249]  249:       else {
[  250]  250:         $self->defaultErrorHandler($hashref, $subject);
[  251]  251:       }
[  252]  252:     };
[  253]  253:     if($@) {
[  254]  254:       # Oh, dear lord this is bad.  We'd died trying to print out death.
[  255]  255:       print STDERR "Mungo::Response -> die in error renderer\n";
[  256]  256:       print STDERR $hashref;
[  257]  257:       print STDERR $@;
[  258]  258:     }
[  259]  259:     return undef;
[  260]  260:   }
[  261]  261:   return $rv;
[  262]  262: }
[  263]  263: 
[  264]  264: sub defaultErrorHandler {
[  265]  265:   use Data::Dumper;
[  266]  266:   my $self = shift;
[  267]  267:   my $href = shift; # Our Error
[  268]  268:   my $subject = shift;
[  269]  269:   my $_r = tied %$self;
[  270]  270:   print "Error in Include($subject):<br />\n";
[  271]  271:   my $pkg = $href->{callstack}->[0]->[0];
[  272]  272:   my $preamble = eval "\$${pkg}::Mungo_preamble;";
[  273]  273:   my $postamble = eval "\$${pkg}::Mungo_postamble;";
[  274]  274:   my $contents = eval "\$${pkg}::Mungo_contents;";
[  275]  275:   print "<pre class=\"error\">$href->{error}</pre><br />\n";
[  276]  276: 
[  277]  277:   unless($contents) {
[  278]  278:     my $filename = $href->{callstack}->[0]->[1];
[  279]  279:     if(open(FILE, "<$filename")) {
[  280]  280:       local $/ = undef;
[  281]  281:       $$contents = <FILE>;
[  282]  282:       close(FILE);
[  283]  283:     }
[  284]  284:   }
[  285]  285: 
[  286]  286:   if($contents) {
[  287]  287:     if($_r->{data}->{'Apache::Request'}->dir_config('Debug')) {
[  288]  288:       print Mungo::Utils::pretty_print_code($preamble, $contents, $postamble, $href->{callstack}->[0]->[2]);
[  289]  289:     }
[  290]  290:   } else {
[  291]  291:     print '<pre>'.Dumper($@).'</pre>';
[  292]  292:   }
[  293]  293: }
[  294]  294: 
[  295]  295: =head2 $output = $Response->TrapInclude($filename, @args);
[  296]  296: 
[  297]  297: Like Include(), but results are returned as a string, instead of being printed.
[  298]  298: 
[  299]  299: =cut
[  300]  300: 
[  301]  301: sub TrapInclude {
[  302]  302:   my $self = shift;
[  303]  303:   my $_r = tied %$self;
[  304]  304:   my $output;
[  305]  305:   my $handle = \do { local *HANDLE };
[  306]  306:   tie *{$handle}, 'Mungo::Response::Trap', \$output;
[  307]  307:   push @{$_r->{data}->{'IO_stack'}}, select(*{$handle});
[  308]  308:   eval {
[  309]  309:     $self->Include(@_);
[  310]  310:   };
[  311]  311:   untie *{$handle} if tied *{$handle};
[  312]  312:   select(pop @{$_r->{data}->{'IO_stack'}});
[  313]  313:   if($@) {
[  314]  314:     local $SIG{__DIE__} = undef;
[  315]  315:     die $@;
[  316]  316:   }
[  317]  317:   return $output;
[  318]  318: }
[  319]  319: 
[  320]  320: =head2 $Response->End()
[  321]  321: 
[  322]  322: Stops processing the current response, shuts down the 
[  323]  323: output handle, and jumps out of the response handler.  
[  324]  324: No further processing will occur.
[  325]  325: 
[  326]  326: =cut
[  327]  327: 
[  328]  328: sub End {
[  329]  329:   my $self = shift;
[  330]  330:   my $_r = tied %$self;
[  331]  331:   while(scalar(@{$_r->{data}->{'IO_stack'} || []}) > 1) {
[  332]  332:     my $oldfh = select(pop @{$_r->{data}->{'IO_stack'}});
[  333]  333:     if(my $obj = tied *{$oldfh}) {
[  334]  334:       untie *{$oldfh};
[  335]  335:       print $$obj;
[  336]  336:     }
[  337]  337:   }
[  338]  338:   $self->Flush();
[  339]  339:   eval { goto  MUNGO_HANDLER_FINISH; }; # Jump back to Mungo::handler()
[  340]  340: }
[  341]  341: 
[  342]  342: sub Flush {
[  343]  343:   my $self = shift;
[  344]  344:   my $_r = tied %$self;
[  345]  345:   # Flush doesn't apply unless we're immediately above STDOUT
[  346]  346:   return if(scalar(@{$_r->{data}->{'IO_stack'} || []}) > 1);
[  347]  347:   unless($_r->{data}->{'__OUTPUT_STARTED__'}) {
[  348]  348:     $self->send_http_header;
[  349]  349:     $_r->{data}->{'__OUTPUT_STARTED__'} = 1;
[  350]  350:   }
[  351]  351:   if (@{$_r->{data}->{'IO_stack'} || []}) {
[  352]  352:       $_r->{data}->{'IO_stack'}->[-1]->print($one_true_buffer);
[  353]  353:   } else {
[  354]  354:       print $one_true_buffer;
[  355]  355:   }
[  356]  356: 
[  357]  357:   $one_true_buffer = '';
[  358]  358: }
[  359]  359: 
[  360]  360: sub AUTOLOAD {
[  361]  361:   my $self = shift;
[  362]  362:   my $name = $AUTOLOAD;
[  363]  363:   $name =~ s/.*://;   # strip fully-qualified portion
[  364]  364:   die __PACKAGE__." does not implement $name";
[  365]  365: }
[  366]  366: 
[  367]  367: sub TIEHANDLE {
[  368]  368:   my $class = shift;
[  369]  369:   my $self = shift;
[  370]  370:   return $self;
[  371]  371: }
[  372]  372: sub PRINT {
[  373]  373:   my $self = shift;
[  374]  374:   my $output = shift;
[  375]  375:   my $_r = tied %$self;
[  376]  376:   if(scalar(@{$_r->{data}->{'IO_stack'} || []}) == 1) {
[  377]  377:     # Buffering a just-in-time headers only applies if we
[  378]  378:     # immediately above STDOUT
[  379]  379:     if($_r->{data}->{Buffer}) {
[  380]  380:       $one_true_buffer .= $output;
[  381]  381:       return;
[  382]  382:     }
[  383]  383:     unless($_r->{data}->{'__OUTPUT_STARTED__'}) {
[  384]  384:       $_r->{data}->{'__OUTPUT_STARTED__'} = 1;
[  385]  385:       $self->send_http_header;
[  386]  386:     }
[  387]  387:   }
[  388]  388:   if (@{$_r->{data}->{'IO_stack'} || []}) {
[  389]  389:       $_r->{data}->{'IO_stack'}->[-1]->print($output);
[  390]  390:   } else {
[  391]  391:       print $output;
[  392]  392:   }
[  393]  393: }
[  394]  394: sub PRINTF {
[  395]  395:   my $self = shift;
[  396]  396:   my $_r = tied %$self;
[  397]  397:   if(scalar(@{$_r->{data}->{'IO_stack'} || []}) == 1) {
[  398]  398:     # Buffering a just-in-time headers only applies if we
[  399]  399:     # immediately above STDOUT
[  400]  400:     if($_r->{data}->{Buffer}) {
[  401]  401:       $one_true_buffer .= sprintf(@_);
[  402]  402:       return;
[  403]  403:     }
[  404]  404:     unless($_r->{data}->{'__OUTPUT_STARTED__'}) {
[  405]  405:       $_r->{data}->{'__OUTPUT_STARTED__'} = 1;
[  406]  406:       $self->send_http_header;
[  407]  407:     }
[  408]  408:   }
[  409]  409:   if (@{$_r->{data}->{'IO_stack'} || []}) {
[  410]  410:       $_r->{data}->{'IO_stack'}->[-1]->printf(@_);
[  411]  411:   } else {
[  412]  412:       printf(@_);
[  413]  413:   }
[  414]  414: }
[  415]  415: sub CLOSE {
[  416]  416:   my $self = shift;
[  417]  417:   my $_r = tied %$self;
[  418]  418:   # Unbuffer outselves, this will actually induce a flush (must go through tiehash)
[  419]  419:   $_r->{data}->{Buffer} = 0;
[  420]  420: }
[  421]  421: sub UNTIE { }
[  422]  422: 
[  423]  423: =head1 AUTHOR
[  424]  424: 
[  425]  425: Theo Schlossnagle
[  426]  426: 
[  427]  427: Clinton Wolfe (docs)
[  428]  428: 
[  429]  429: =cut
[  430]  430: 
[  431]  431: 1;