Created
September 14, 2012 07:26
-
-
Save racke/3720502 to your computer and use it in GitHub Desktop.
Dancer::Plugin::InterchangeLink
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
package Dancer::Plugin::InterchangeLink; | |
use 5.006; | |
use strict; | |
use warnings; | |
use Socket; | |
use HTTP::Response; | |
use Dancer ':syntax'; | |
use Dancer::Plugin; | |
=head1 NAME | |
Dancer::Plugin::InterchangeLink | |
=head1 VERSION | |
Version 0.0001 | |
=cut | |
our $VERSION = '0.0001'; | |
my %lt_object; | |
=head1 SYNOPSIS | |
=head1 DESCRIPTION | |
=head1 CONFIGURATION | |
plugins: | |
InterchangeLink: | |
socket: /home/minivend/ic/interchange.sock | |
host: www.linuxia.de | |
=head1 FUNCTIONS | |
=head2 interchange_link | |
=cut | |
register interchange_link => sub { | |
my ($self, @args) = plugin_args(@_); | |
my $answer = ''; | |
my $conf = plugin_setting; | |
my $socket = $conf->{socket} || '/var/run/interchange/interchange.sock'; | |
socket(SOCK, PF_UNIX, SOCK_STREAM, 0) or die "socket: $!\n"; | |
my $ok; | |
do { | |
$ok = connect(SOCK, sockaddr_un($socket)); | |
} while ( ! defined $ok and $! =~ /interrupt|such file or dir/i); | |
unless ($ok) { | |
die "Failed to connect to socket $socket: $!."; | |
} | |
# prepare environment | |
my $env = _prepare_environment(request->env, $conf); | |
_get_entity($env); | |
select SOCK; | |
$| = 1; | |
select STDOUT; | |
print SOCK _send_arguments(); | |
print SOCK _send_environment($env); | |
print SOCK _send_entity($env); | |
print SOCK "end\n"; | |
while(<SOCK>) { | |
$answer .= $_; | |
} | |
close (SOCK) or die "close: $!\n"; | |
# parse HTTP response from Interchange | |
my $http_msg = HTTP::Response->parse( $answer ); | |
# status($http_msg->code); | |
return $http_msg->content; | |
}; | |
register_plugin; | |
my $Entity = ''; | |
# Read the entity from stdin if present. | |
sub _prepare_environment { | |
my ($env_ref, $conf) = @_; | |
my %env = %$env_ref; | |
if ($conf->{host}) { | |
$env{SERVER_NAME} = $conf->{host}; | |
$env{SERVER_PORT} = 80; | |
$env{HTTP_HOST} = "$conf->{host}"; | |
} | |
return \%env; | |
} | |
sub _get_entity { | |
my $env = shift; | |
return '' unless defined $env->{CONTENT_LENGTH}; | |
my $len = $env->{CONTENT_LENGTH} || 0; | |
return '' unless $len; | |
my $check; | |
# Can't hurt, helps Windows people | |
binmode(STDIN); | |
$check = read(STDIN, $Entity, $len); | |
die_page("Entity wrong length") | |
unless $check == $len; | |
$Entity; | |
} | |
sub _send_arguments { | |
my $count = @ARGV; | |
my $val = "arg $count\n"; | |
for(@ARGV) { | |
$val .= length($_); | |
$val .= " $_\n"; | |
} | |
return $val; | |
} | |
# passes environment to Interchange | |
sub _send_environment { | |
my $env = shift; | |
my (@tmp) = keys %$env; | |
my $count = @tmp; | |
my ($str); | |
my $val = "env $count\n"; | |
for(@tmp) { | |
$str = "$_=$env->{$_}"; | |
$val .= length($str); | |
$val .= " $str\n"; | |
} | |
debug("ENV: ", $env); | |
return $val; | |
} | |
sub _send_entity { | |
my $env = shift; | |
return '' unless defined $env->{CONTENT_LENGTH}; | |
my $len = $env->{CONTENT_LENGTH} || 0; | |
return '' unless $len > 0; | |
my $val = "entity\n"; | |
$val .= "$len $Entity\n"; | |
return $val; | |
} | |
=head1 AUTHOR | |
Stefan Hornburg (Racke), C<< <racke at linuxia.de> >> | |
=head1 BUGS | |
=head1 SUPPORT | |
You can find documentation for this module with the perldoc command. | |
perldoc Dancer::Plugin::InterchangeLink | |
You can also look for information at: | |
=over 4 | |
=item * RT: CPAN's request tracker (report bugs here) | |
L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Dancer-Plugin-InterchangeLink> | |
=item * AnnoCPAN: Annotated CPAN documentation | |
L<http://annocpan.org/dist/Dancer-Plugin-InterchangeLink> | |
=item * CPAN Ratings | |
L<http://cpanratings.perl.org/d/Dancer-Plugin-InterchangeLink> | |
=item * Search CPAN | |
L<http://search.cpan.org/dist/Dancer-Plugin-InterchangeLink/> | |
=back | |
=head1 ACKNOWLEDGEMENTS | |
None so far. | |
=head1 LICENSE AND COPYRIGHT | |
Copyright 2012 Stefan Hornburg (Racke). | |
This program is free software; you can redistribute it and/or modify it | |
under the terms of either: the GNU General Public License as published | |
by the Free Software Foundation; or the Artistic License. | |
See http://dev.perl.org/licenses/ for more information. | |
=cut | |
1; # End of Dancer::Plugin::InterchangeLink |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment