$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;
}
# 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.
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<IO::Handle>.
-
=head2 $self->finalize_headers($c)
Writes headers to response if not already written
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<IO::Handle> 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
--- /dev/null
+#!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(</geocode>)],
+};
+
+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();
--- /dev/null
+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;
projects / catagits/Catalyst-Runtime.git / commitdiff