From: Brendan Byrd Date: Tue, 17 Apr 2012 21:14:31 +0000 (-0400) Subject: Add PerlIO methods to Catalyst::Response, so that it more properly X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FCatalyst-Runtime.git;a=commitdiff_plain;h=c9373e697672ade084d08684f95ae2fcd83bfd88 Add PerlIO methods to Catalyst::Response, so that it more properly acts like a IO::Handle object (to a certain degree) --- diff --git a/lib/Catalyst/Response.pm b/lib/Catalyst/Response.pm index cd81857..1d29db0 100644 --- a/lib/Catalyst/Response.pm +++ b/lib/Catalyst/Response.pm @@ -57,7 +57,7 @@ sub write { $buffer = q[] unless defined $buffer; my $len = length($buffer); - $self->_writer->write($buffer); + $self->_writer->write($buffer); # ignore PerlIO's LEN, [OFFSET] params return $len; } @@ -67,7 +67,7 @@ sub finalize_headers { # This is a less-than-pretty hack to avoid breaking the old # Catalyst::Engine::PSGI. 5.9 Catalyst::Engine sets a response_cb and - # expects us to pass headers to it here, whereas Catalyst::Enngine::PSGI + # expects us to pass headers to it here, whereas Catalyst::Engine::PSGI # just pulls the headers out of $ctx->response in its run method and never # sets response_cb. So take the lack of a response_cb as a sign that we # don't need to set the headers. @@ -241,11 +241,6 @@ $res->code is an alias for this, to match HTTP::Response->code. Writes $data to the output stream. -=head2 $res->print( @data ) - -Prints @data to the output stream, separated by $,. This lets you pass -the response object to functions that want to write to an L. - =head2 $self->finalize_headers($c) Writes headers to response if not already written @@ -259,22 +254,94 @@ request. Provided by Moose -=cut - -sub print { - my $self = shift; - my $data = shift; - - defined $self->write($data) or return; +=head1 IO::Handle METHODS + +Certain other methods are provided to ensure (reasonable) compatibility +to other functions expecting a L object: + + $res->open # ignores all params and calls $res->finalize_headers + $res->close + $res->opened # auto-opens + $res->fileno + $res->print( ARGS ) # uses $, & $\ + $res->printf( FMT, [ARGS] ) + $res->say( ARGS ) + $res->printflush( ARGS ) + + # these are checked for similar methods within the writer + $res->autoflush( [BOOL] ) # echos BOOL or 0 if method not found + $res->blocking( [BOOL] ) # echos BOOL or 1 if method not found + $res->binmode( [BOOL] ) # echos BOOL or 1 if method not found + $res->error # returns $! if method not found + $res->clearerr # clears $! and returns 0 if method not found + $res->sync # tries $res->flush if method not found + $res->flush # returns "0 but true" if method not found + +=for Pod::Coverage open(ed)?|close|fileno|print(f?|flush)|say - for (@_) { - defined $self->write($,) or return; - defined $self->write($_) or return; - } - defined $self->write($\) or return; +=cut +sub open { + # We are just going to blissfully ignore the params + my ($self) = shift; + + $self->finalize_headers; + return 1; +} +sub close { return shift->_has_writer && shift->_writer->close(); } +sub opened { return shift->open(); } # if it's asking, just open up the writer +sub fileno { return scalar shift->_writer; } # scalar reference comparison should be good enough +sub print { + my ($self, @data) = (shift, @_); + + # (var usage per Perl print docs) + @data = map { ($_, $,) } @data; # poor man's "array join" + splice(@data, -1, 1, $\) if (@data); # remove trailing sep + add $\ + + for (@data) { defined $self->write($_) or return; } + return 1; } +sub printf { + my ($self) = shift; + return $self->write( sprintf(@_) ); # per docs, printf doesn't use $/ +} +sub say { + my ($self) = shift; + local $\ = "\n"; + return $self->print(@_); +} +sub printflush { + my ($self) = shift; + my $af = $self->autoflush(1); + my $ret = $self->print(@_); + $self->autoflush($af); + return $ret; +} + +# I/O method checking +sub _attempt { + my ($self, $method, $default, @data) = @_; + no strict 'refs'; # no complainy at CODEREFs + + return $self->_has_writer && $self->_writer->can($method) ? + $self->_writer->$method(@data) : + ref $default eq 'CODE' ? + &$default($self) : # (kinda janky, but $self->$default isn't right either) + defined $data[0] ? $data[0] : $default # can't tell, but don't error on it, either (default action for booleans) + ; +} + +foreach my $pair ( + [autoflush => 0], + [blocking => 1], + [binmode => 1], + [error => sub { $! }], + [clearerr => sub { undef $! || 0 }], # 0 = don't error + [sync => sub { shift->flush() }], # fallback + [flush => sub { "0 but true" }], # don't error (but don't echo either, hence a CODEREF) +) # $method $self @([$method, $default]), @data + { __PACKAGE__->meta->add_method($pair->[0], sub { shift->_attempt(@$pair, @_); }); } =head1 AUTHORS diff --git a/t/aggregate/live_engine_response_perlio.t b/t/aggregate/live_engine_response_perlio.t new file mode 100644 index 0000000..f1bd244 --- /dev/null +++ b/t/aggregate/live_engine_response_perlio.t @@ -0,0 +1,40 @@ +#!perl + +use strict; +use warnings; + +use FindBin; +use lib "$FindBin::Bin/../lib"; + +use Test::More; +use Catalyst::Test 'TestApp'; + +my $types = { + #zip => ['Archive::Zip', 464, qr/^PK\x03\x04.*[\x80-\xFF]+.*x.txt/s], + ### Archive::Zip currently unreliable as a test platform until RT #54827 is fixed and popularized ### + ### https://rt.cpan.org/Ticket/Display.html?id=54827 ### + + csv => ['Text::CSV', 96, qr/"Banana \(single\)","\$ \.40"$/m], + xml => ['XML::Simple', 1657, qr()], +}; + +plan tests => scalar keys %$types; + +for my $action ( keys %$types ) { + my ($module, $length, $regexp) = @{$types->{$action}}; + + subtest uc($action)." Set" => sub { + undef $@; + eval "require $module"; # require hates string class names; must use eval string instead of block + print $@; + plan ($@ ? (skip_all => $module.' not installed') : (tests => 4) ); + + ok( my $response = request('http://localhost/engine/response/perlio/' . $action ), "Request" ); + ok( $response->is_success, "Response Successful 2xx" ); + is( length( $response->content ), $length, "Length OK" ); + like( $response->content, $regexp, "RegExp Check OK" ); + done_testing(); + }; +} + +done_testing(); diff --git a/t/lib/TestApp/Controller/Engine/Response/PerlIO.pm b/t/lib/TestApp/Controller/Engine/Response/PerlIO.pm new file mode 100644 index 0000000..901f7b3 --- /dev/null +++ b/t/lib/TestApp/Controller/Engine/Response/PerlIO.pm @@ -0,0 +1,121 @@ +package TestApp::Controller::Engine::Response::PerlIO; + +use strict; +use base 'Catalyst::Controller'; + +sub zip : Relative { + my ( $self, $c ) = @_; + + use Archive::Zip qw( :ERROR_CODES :CONSTANTS ); + + my $data1 = 'x' x (100 * 1024); + #my $data2 = join '', map { chr($_) } (0..65535); + my $data2 = join('', map { chr($_) } (0..255)) x 256; + + my $zip = new Archive::Zip; + $zip->addString(\$data1, 'x.txt', COMPRESSION_LEVEL_BEST_COMPRESSION); + #$zip->addString(\$data2, 'utf16.txt', COMPRESSION_LEVEL_BEST_COMPRESSION); ### Needs better support in Archive::Zip first... ### + $zip->addString(\$data1, 'ASCII.txt', COMPRESSION_LEVEL_BEST_COMPRESSION); + + unless ($zip->writeToFileHandle($c->response, 0) == AZ_OK) { + Catalyst::Exception->throw("ZIP Write Error!"); + } +} + +sub csv : Relative { + my ( $self, $c ) = @_; + + use Text::CSV; + + my $csv = Text::CSV->new({ eol => "\n" }); + my $csv_doc = [ + [qw/Cnt Item Price/], + [1, "Box of Ritz Crackers", '$2.55'], + [1, "Cheese Whiz", '$1.22'], + [5, "Banana (single)", '$ .40'], + ]; + + while (my $row = shift @$csv_doc) { + $csv->print($c->response, $row) || Catalyst::Exception->throw("CSV Write Error!"); + } +} + +sub xml : Relative { + my ( $self, $c ) = @_; + + use XML::Simple; + + my $xs = XML::Simple->new( + XMLDecl => 1, + KeepRoot => 1, + OutputFile => $c->response, + ); + $xs->xml_out({ + geocode => { + results => [ + { + address_components => [ + { + long_name => "1600", + short_name => "1600", + types => [ "street_number" ] + }, + { + long_name => "Amphitheatre Pkwy", + short_name => "Amphitheatre Pkwy", + types => [ "route" ] + }, + { + long_name => "Mountain View", + short_name => "Mountain View", + types => [ "locality", "political" ] + }, + { + long_name => "Santa Clara", + short_name => "Santa Clara", + types => [ "administrative_area_level_2", "political" ] + }, + { + long_name => "California", + short_name => "CA", + types => [ "administrative_area_level_1", "political" ] + }, + { + long_name => "United States", + short_name => "US", + types => [ "country", "political" ] + }, + { + long_name => "94043", + short_name => "94043", + types => [ "postal_code" ] + } + ], + formatted_address => "1600 Amphitheatre Pkwy, Mountain View, CA 94043, USA", + geometry => { + location => { + lat => 37.42109430, + lng => -122.08525150 + }, + location_type => "ROOFTOP", + viewport => { + northeast => { + lat => 37.42244328029150, + lng => -122.0839025197085 + }, + southwest => { + lat => 37.41974531970850, + lng => -122.0866004802915 + } + } + }, + types => [ "street_address" ] + } + ], + status => "OK", + source => 'http://maps.googleapis.com/maps/api/geocode/json?address=1600+Amphitheatre+Parkway,+Mountain+View,+CA&sensor=false' + }, + }) || Catalyst::Exception->throw("XML Write Error!"); +} + +1;