SCGI-0.6/0000775000211500001440000000000010414214077011011 5ustar tomyusersSCGI-0.6/examples/0000775000211500001440000000000010414214077012627 5ustar tomyusersSCGI-0.6/examples/blocking.pl0000664000211500001440000000073110414214077014755 0ustar tomyusers#!/usr/bin/perl use strict; use warnings; use SCGI; use IO::Socket::INET; use Data::Dumper; my $socket = IO::Socket::INET->new( Listen => 5, ReuseAddr => SO_REUSEADDR, LocalPort => 9090 ) or die "cannot bind to port 9090: $!"; my $scgi = SCGI->new($socket, blocking => 1); while (my $request = $scgi->accept) { $request->read_env; $request->socket->print("Content-Type: text/plain\n\n"); $request->socket->print(Dumper $request->env); $request->close; } SCGI-0.6/examples/non_blocking.pl0000664000211500001440000000217010414214077015626 0ustar tomyusers#!/usr/bin/perl use strict; use warnings; use Event::Lib qw(show_method); use SCGI; use IO::Socket::INET; ## # This example currently leaks memory (at least on my debian system) # There were some SV's being lost by Event::Lib, but this has been fixed now, # and Devel::Leak indicates that the number of SV's is not increasing. However # the process size steadily increases :'( ## my $socket = IO::Socket::INET->new( Listen => 5, ReuseAddr => SO_REUSEADDR, LocalPort => 9090, Proto => 'tcp', Blocking => 0, ) or die "cannot bind to port 9090: $!"; my $scgi = SCGI->new($socket); sub accept { my $event = shift; my $request = $scgi->accept; event_new( $request->socket, EV_READ|EVLOOP_ONCE, \&handle, $request, )->add; } sub handle { my ($event, undef, $request) = @_; if ($request->read_env) { $request->set_blocking(1); $request->socket->print("Content-Type: text/plain\n\n"); $request->socket->print('hello'); $event->free; $request->close; } else { $event->add; } } my $event = event_new($scgi->socket, EV_READ|EV_PERSIST, \&accept); $event->add; $event->dispatch; SCGI-0.6/CHANGES0000664000211500001440000000106510414214077012006 0ustar tomyusers0.6 2006-04-03 - change documentation to use correct CGI style response (rather than HTTP). - change exception that is raised for repeated header to warning to take account of current apache module version, which repeats HTTPS header when present. 0.4 2005-10-12 - added Test::Pod and Test::Pod::Coverage tests. - blocking is now a named parameter to new (old calling style is deprecated and will produce a warning, will be removed in next version). Blocking is still false by default. - sysread is now used when blocking is not set. 0.2 - Initial release SCGI-0.6/t/0000775000211500001440000000000010414214077011254 5ustar tomyusersSCGI-0.6/t/non-blocking.t0000664000211500001440000000626710414214077014034 0ustar tomyusers#!/usr/bin/perl use strict; use warnings; use IO::Socket::UNIX; my @tests; BEGIN { @tests = ( { body => '', env => {}, response => '' }, { body => 'something interesting', env => {HELLO => 'hi', BONJOUR => 'salut'}, response => 'yay' }, { body => "even more!\n", env => {'֒' => '@_+$', '!"$' => ''}, response => 'yay' }, { body => "even more!\n", env => {1 => 2}, response => 'yay', break_up_length => 1 }, ); } use Test::More tests => 1 + @tests * 3; require_ok('SCGI'); my $ready; local $SIG{HUP} = sub { $ready = 1; }; for my $test_request (1, 0) { $ready = 0; my $child_ppid = fork; die "cannot fork: $!" unless defined $child_ppid; my $other_ppid = $child_ppid || getppid; if (($child_ppid ? 1 : 0) == ($test_request ? 1 : 0)) { my $socket = IO::Socket::INET->new( Listen => 5, ReuseAddr => SO_REUSEADDR, LocalAddr => 'localhost:9000', ) or die "cannot bind to port 9000: $!"; my $scgi = SCGI->new($socket); local $SIG{USR1} = sub { $socket->close; }; kill HUP => $other_ppid or die "cannot send signal to client process: $!"; my $test_number = 0; while (my $request = $scgi->accept) { my $test = $tests[$test_number]; my $start = time; while (! $request->read_env) { die 'took too long' if time - $start > 30; } read $request->connection, my $body, $request->env->{CONTENT_LENGTH}; cmp_ok($body, 'eq', $test->{body}, "test request $test_number body correct") if $test_request; my %env = %{$request->env}; delete $env{SCGI}; delete $env{CONTENT_LENGTH}; is_deeply(\%env, $test->{env}, 'recieved corrent environment for test ' . $test_number) if $test_request; $request->connection->print($test->{response}); $request->close; # don't wait for accept to return false as it creates warnings in IO::Handle last if ++$test_number == @tests; } if ($child_ppid) { wait; } else { exit; } } elsif (($child_ppid ? 1 : 0) != ($test_request ? 1 : 0)) { while (! $ready) { select(undef, undef, undef, 0.1); } for my $test_number (0..$#tests) { my $test = $tests[$test_number]; my $socket = IO::Socket::INET->new( PeerAddr => 'localhost:9000' ); my $content_length = length($test->{body}); my $env = "CONTENT_LENGTH\0$content_length\0"; $test->{env}->{SCGI} = 1; for my $key (keys %{$test->{env}}) { $env .= "$key\0$test->{env}->{$key}\0"; } if ($test->{break_up_length}) { my $length = length($env); while ($length =~ s/^(\d)//os) { print $socket $1; select(undef, undef, undef, 0.1);; } } else { print $socket length($env); } print $socket ':' . $env . ',' . $test->{body}; my $body = ''; while (<$socket>) { $body .= $_; } cmp_ok($body, 'eq', $test->{response}, 'returned body ok for test ' . $test_number) unless $test_request; $socket->close; } kill USR1 => $other_ppid or die "cannot send signal to server process: $!"; if ($child_ppid) { wait; } else { exit; } } } SCGI-0.6/t/blocking.t0000664000211500001440000000533010414214077013232 0ustar tomyusers#!/usr/bin/perl use strict; use warnings; use IO::Socket::UNIX; my @tests; BEGIN { @tests = ( { body => '', env => {}, response => '' }, { body => 'something more interesting', env => {HELLO => 'hi', BONJOUR => 'salut'}, response => 'yay' }, ); } use Test::More tests => 1 + @tests * 3; require_ok('SCGI'); my $ready; local $SIG{HUP} = sub { $ready = 1; }; for my $test_request (1, 0) { $ready = 0; my $child_ppid = fork; die "cannot fork: $!" unless defined $child_ppid; my $other_ppid = $child_ppid || getppid; if (($child_ppid ? 1 : 0) == ($test_request ? 1 : 0)) { my $socket = IO::Socket::INET->new( Listen => 5, ReuseAddr => SO_REUSEADDR, LocalAddr => 'localhost:9000', ) or die "cannot bind to port 9000: $!"; my $scgi = SCGI->new($socket, blocking => 1); local $SIG{USR1} = sub { $socket->close; }; kill HUP => $other_ppid or die "cannot send signal to client process: $!"; my $test_number = 0; while (my $request = $scgi->accept) { my $test = $tests[$test_number]; $request->read_env; read $request->connection, my $body, $request->env->{CONTENT_LENGTH}; cmp_ok($body, 'eq', $test->{body}, "test request $test_number body correct") if $test_request; my %env = %{$request->env}; delete $env{SCGI}; delete $env{CONTENT_LENGTH}; is_deeply(\%env, $test->{env}, 'recieved corrent environment for test ' . $test_number) if $test_request; $request->connection->print($test->{response}); $request->close; # don't wait for accept to return false as it creates warnings in IO::Handle last if ++$test_number == @tests; } if ($child_ppid) { wait; } else { exit; } } elsif (($child_ppid ? 1 : 0) != ($test_request ? 1 : 0)) { while (! $ready) { select(undef, undef, undef, 0.1); } for my $test_number (0..$#tests) { my $test = $tests[$test_number]; my $socket = IO::Socket::INET->new( PeerAddr => 'localhost:9000' ); my $content_length = length($test->{body}); my $env = "CONTENT_LENGTH\0$content_length\0"; $test->{env}->{SCGI} = 1; for my $key (keys %{$test->{env}}) { $env .= "$key\0$test->{env}->{$key}\0"; } print $socket length($env) . ':' . $env . ',' . $test->{body}; my $body = ''; while (<$socket>) { $body .= $_; } cmp_ok($body, 'eq', $test->{response}, 'returned body ok for test ' . $test_number) unless $test_request; $socket->close; } kill USR1 => $other_ppid or die "cannot send signal to server process: $!"; if ($child_ppid) { wait; } else { exit; } } } SCGI-0.6/t/pod-coverage.t0000664000211500001440000000032010414214077014007 0ustar tomyusers#!/usr/bin/perl use strict; use warnings; use Test::More; eval "use Test::Pod::Coverage 1.00"; plan skip_all => "Test::Pod::Coverage 1.00 required for testing POD coverage" if $@; all_pod_coverage_ok(); SCGI-0.6/t/pod.t0000664000211500001440000000030710414214077012223 0ustar tomyusers#!/usr/bin/perl use strict; use warnings; use Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(all_pod_files(qw(blib))); SCGI-0.6/META.yml0000664000211500001440000000047010414214077012263 0ustar tomyusers--- name: SCGI version: 0.6 author: - 'Thomas Yandell L' abstract: SCGI server library for perl license: perl requires: perl: 5.8.0 provides: SCGI: file: lib/SCGI.pm version: 0.6 SCGI::Request: file: lib/SCGI/Request.pm generated_by: Module::Build version 0.26 SCGI-0.6/lib/0000775000211500001440000000000010414214077011557 5ustar tomyusersSCGI-0.6/lib/SCGI/0000775000211500001440000000000010414214077012304 5ustar tomyusersSCGI-0.6/lib/SCGI/Request.pm0000664000211500001440000001251710414214077014300 0ustar tomyuserspackage SCGI::Request; use strict; use warnings; use SCGI; use POSIX ':errno_h'; our $VERSION = $SCGI::VERSION; =head1 NAME SCGI::Request =head1 DESCRIPTION This module implements the part of the SCGI protocol that reads the environment. All that remains after this is the content of the request. The protocol and this module guarentee that there will be a CONTENT_LENGTH for the body of the request in the environment. =head1 SYNOPISIS # $request got from SCGI $request->read_env; read $request->connection, my $body, $request->env->{CONTENT_LENGTH}; =head2 public methods =over =item read_env Read the environment in a blocking or non-blocking manner, per parameter to Cnew>. Returns true if it has finished. =cut sub read_env { my ($this) = @_; goto &_blocking_read_env if $this->blocking; die 'read_env called when env already read - use env method to access' if $this->{env_read}; $this->{env_length_buffer} ||= ''; $this->{env_buffer} ||= ''; unless ($this->{env_length_read}) { my $bytes_read = sysread $this->connection, my $buffer, 14; die "read error: $!" unless defined $bytes_read || $! == EAGAIN; return unless $bytes_read; if ($buffer =~ m{ ^ (\d+) : (.*) $ }osx) { $this->{env_length_buffer} .= $1; $this->{env_buffer} .= $2; $this->{env_length_read} = 1; } elsif ($this->{env_length_buffer} ne '' && $buffer =~ m{ ^ : (.*) $ }osx) { $this->{env_buffer} .= $1; $this->{env_length_read} = 1; } elsif ($buffer =~ m{ ^ \d+ $ }osx) { $this->{env_length_buffer} .= $buffer; return; } else { die "malformed env length"; } } my $left_to_read = $this->{env_length_buffer} - length($this->{env_buffer}); my $buffer = ''; my $read = sysread $this->connection, $buffer, $left_to_read + 1; die "read error: $!" unless defined $read || $! == EAGAIN; return unless $read; if ($read == $left_to_read + 1) { if ((my $comma = substr $buffer, $left_to_read) ne ',') { die "malformed netstring, expected terminating comma, found \"$comma\""; } $this->_decode_env($this->{env_buffer} . substr $buffer, 0, $left_to_read); return 1; } else { $this->{env_buffer} .= $buffer; return; } } =item env Gets the environment for this request after it has been read. This will return undef until C or C has been called and returned true. =cut sub env { my ($this) = @_; $this->{env}; } =item connection Returns the open connection to the client. =cut sub connection { my ($this) = @_; $this->{connection}; } =item close Closes the connection. =cut sub close { my ($this) = @_; $this->connection->close if $this->connection; $this->{closed} = 1; } =item blocking Returns true if the connection is blocking. =cut sub blocking { my ($this) = @_; $this->{blocking}; } =item set_blocking If boolean argument is true turns on blocking, otherwise turns it off. =cut sub set_blocking { my ($this, $blocking) = @_; return if $this->{blocking} && $blocking || ! $this->{blocking} && ! $blocking; if ($blocking) { $this->connection->blocking(1); } else { $this->connection->flush; $this->connection->blocking(0); } } =back =head2 private methods =over =item _new Creates a new SCGI::Request. This is used by SCGI in the C method, so if you are considering using this, use that instead. =cut sub _new { my ($class, $connection, $blocking) = @_; bless {connection => $connection, blocking => $blocking}, $class; } =item _decode_env Takes the encoded environment as a string and sets the env ready for access with C. =cut sub _decode_env { my ($this, $env_string) = @_; my %env; pos $env_string = 0; $env_string =~ m{ \G CONTENT_LENGTH \0 (\d+) \0 }msogcx or die "malformed CONTENT_LENGTH header"; $env{CONTENT_LENGTH} = $1; while ($env_string =~ m{ ([^\0]+) \0 ([^\0]+) \0 }msogcx) { warn "repeated $1 header in env" if $env{$1}; $env{$1} = $2; } die "malformed header" unless pos $env_string = length $env_string; die "missing SCGI header" unless $env{SCGI} && $env{SCGI} eq '1'; $this->_set_env(\%env); } =item _set_env Sets the environment for this request. =cut sub _set_env { my ($this, $env) = @_; $this->{env} = $env; } =item _blocking_read_env Reads and decodes the environment in one go. Returns true on success, raises an exception on failiure. =cut sub _blocking_read_env { my ($this) = @_; read $this->connection, my $env_length, 14 or die "cannot read env length from connection: $!"; my ($length, $rest) = $env_length =~ m{ ^ (\d+) : (.*) $ }osx or die 'malformed env length'; read $this->connection, my $env, $length + 1 - length($rest) or die "cannot read env from connection: $!"; if ((my $comma = substr $env, $length - length $rest) ne ',') { die "malformed netstring, expected terminating comma, found \"$comma\""; } $this->_decode_env($rest . substr $env, 0, $length); 1; } sub DESTROY { my ($this) = @_; $this->close unless $this->{closed}; } 1; __END__ =back =head1 AUTHOR Thomas Yandell L =head1 COPYRIGHT Copyright 2005, 2006 Viper Code Limited. All rights reserved. =head1 LICENSE This file is part of SCGI (perl SCGI library). This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut SCGI-0.6/lib/SCGI.pm0000664000211500001440000000560510414214077012650 0ustar tomyuserspackage SCGI; use strict; use warnings; our $VERSION = 0.6; use SCGI::Request; use Carp; =head1 NAME SCGI =head1 DESCRIPTION This module is for implementing an SCGI interface for an application server. =head1 SYNOPISIS use SCGI; use IO::Socket; my $socket = IO::Socket::INET->new(Listen => 5, ReuseAddr => 1, LocalPort => 8080) or die "cannot bind to port 8080: $!"; my $scgi = SCGI->new($socket, blocking => 1); while (my $request = $scgi->accept) { $request->read_env; read $request->connection, my $body, $request->env->{CONTENT_LENGTH}; # print $request->connection "Content-Type: text/plain\n\nHello!\n"; } =head2 public methods =over =item new Takes a socket followed by a set of options (key value pairs) and returns a new SCGI listener. Currently the only supported option is blocking, to indicate that the socket blocks and that the library should not treat it accordingly. By default blocking is false. (NOTE: blocking is now a named rather than positional parameter. Using as a positional parameter will produce a warning in this version and will throw an exception in the next version). =cut sub new { my ($class, $socket) = (shift, shift); croak "key without value passed to SCGI->new" if @_ % 2; my %options = @_; for my $option (keys %options) { croak "unknown option $option" unless grep $_ eq $option, qw(blocking); } bless {socket => $socket, blocking => $options{blocking} ? 1 : 0}, $class; } =item accept Accepts a connection from the socket and returns an C> for it. =cut sub accept { my ($this) = @_; my $connection = $this->socket->accept or return; $connection->blocking(0) unless $this->blocking; SCGI::Request->_new($connection, $this->blocking); } =item socket Returns the socket that was passed to the constructor. =cut sub socket { my ($this) = @_; $this->{socket}; } =item blocking Returns true if it was indicated that the socket should be blocking when the SCGI object was created. =cut sub blocking { my ($this) = @_; $this->{blocking}; } 1; __END__ =back =head1 KNOWN ISSUES The SCGI Apache2 module had a bug (for me at least), which resulted in segmentation faults. This appeared after version 1.2 (the version in Debian Sarge) and was fixed in 1.10. The SCGI Apache2 module has a bug where certain headers can be repeated. This is still present in version 1.10. A patch has been accepted and this issue should be resolved in the next release. This modulenow issues a warning on a repeated header, rather than throwing an exception as in the previous version. =head1 AUTHOR Thomas Yandell L =head1 COPYRIGHT Copyright 2005, 2006 Viper Code Limited. All rights reserved. =head1 LICENSE This file is part of SCGI (perl SCGI library). This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut SCGI-0.6/MANIFEST0000664000211500001440000000027310414214077012144 0ustar tomyusersMANIFEST README CHANGES META.yml lib/SCGI/Request.pm lib/SCGI.pm Build.PL Makefile.PL t/blocking.t t/non-blocking.t t/pod.t t/pod-coverage.t examples/blocking.pl examples/non_blocking.pl SCGI-0.6/README0000664000211500001440000000155510414214077011677 0ustar tomyusersSCGI - The Perl SCGI server library. INSTALATION Issue the following commands: perl Build.PL ./Build ./Build test ./Build install KNOWN ISSUES The SCGI Apache2 module had a bug (for me at least), which resulted in segmentation faults. This appeared after version 1.2 (the version in Debian Sarge) and was fixed in 1.10. The SCGI Apache2 module has a bug where certain headers can be repeated. This is still present in version 1.10. A patch has been accepted and this issue should be resolved in the next release. This modulenow issues a warning on a repeated header, rather than throwing an exception as in the previous version. COPYRIGHT Copyright 2005, 2006 Viper Code Limited. All rights reserved. LICENSE This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. CONTACT Thomas Yandell tom+scgi@vipercode.com SCGI-0.6/Build.PL0000664000211500001440000000041010414214077012300 0ustar tomyusers use Module::Build; my $build = Module::Build->new( module_name => 'SCGI', dist_abstract => 'SCGI server library for perl', create_makefile_pl => 'passthrough', license => 'perl', requires => { 'perl' => '5.8.0', }, ); $build->create_build_script; SCGI-0.6/Makefile.PL0000664000211500001440000000212510414214077012763 0ustar tomyusers# Note: this file was auto-generated by Module::Build::Compat version 0.03 unless (eval "use Module::Build::Compat 0.02; 1" ) { print "This module requires Module::Build to install itself.\n"; require ExtUtils::MakeMaker; my $yn = ExtUtils::MakeMaker::prompt (' Install Module::Build now from CPAN?', 'y'); unless ($yn =~ /^y/i) { die " *** Cannot install without Module::Build. Exiting ...\n"; } require Cwd; require File::Spec; require CPAN; # Save this 'cause CPAN will chdir all over the place. my $cwd = Cwd::cwd(); my $makefile = File::Spec->rel2abs($0); CPAN::Shell->install('Module::Build::Compat') or die " *** Cannot install without Module::Build. Exiting ...\n"; chdir $cwd or die "Cannot chdir() back to $cwd: $!"; } eval "use Module::Build::Compat 0.02; 1" or die $@; use lib '_build/lib'; Module::Build::Compat->run_build_pl(args => \@ARGV); require Module::Build; Module::Build::Compat->write_makefile(build_class => 'Module::Build');