Perl library for Thrift
Summary: Submitted by Jake Luciani
Reviewed By: mcslee
git-svn-id: https://svn.apache.org/repos/asf/incubator/thrift/trunk@665112 13f79535-47bb-0310-9956-ffa450edef68
diff --git a/lib/perl/COPYING b/lib/perl/COPYING
new file mode 100644
index 0000000..039f21e
--- /dev/null
+++ b/lib/perl/COPYING
@@ -0,0 +1,24 @@
+Thrift Software License
+Copyright (c) 2006- Facebook, Inc.
+
+Permission is hereby granted, free of charge, to any person or organization
+obtaining a copy of the software and accompanying documentation covered by
+this license (the "Software") to use, reproduce, display, distribute,
+execute, and transmit the Software, and to prepare derivative works of the
+Software, and to permit third-parties to whom the Software is furnished to
+do so, all subject to the following:
+
+The copyright notices in the Software and this entire statement, including
+the above license grant, this restriction and the following disclaimer,
+must be included in all copies of the Software, in whole or in part, and
+all derivative works of the Software, unless such copies or derivative
+works are solely in the form of machine-executable object code generated by
+a source language processor.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE, TITLE AND NON-INFRINGEMENT. IN NO EVENT
+SHALL THE COPYRIGHT HOLDERS OR ANYONE DISTRIBUTING THE SOFTWARE BE LIABLE
+FOR ANY DAMAGES OR OTHER LIABILITY, WHETHER IN CONTRACT, TORT OR OTHERWISE,
+ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+DEALINGS IN THE SOFTWARE.
diff --git a/lib/perl/LICENSE b/lib/perl/LICENSE
new file mode 100644
index 0000000..039f21e
--- /dev/null
+++ b/lib/perl/LICENSE
@@ -0,0 +1,24 @@
+Thrift Software License
+Copyright (c) 2006- Facebook, Inc.
+
+Permission is hereby granted, free of charge, to any person or organization
+obtaining a copy of the software and accompanying documentation covered by
+this license (the "Software") to use, reproduce, display, distribute,
+execute, and transmit the Software, and to prepare derivative works of the
+Software, and to permit third-parties to whom the Software is furnished to
+do so, all subject to the following:
+
+The copyright notices in the Software and this entire statement, including
+the above license grant, this restriction and the following disclaimer,
+must be included in all copies of the Software, in whole or in part, and
+all derivative works of the Software, unless such copies or derivative
+works are solely in the form of machine-executable object code generated by
+a source language processor.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE, TITLE AND NON-INFRINGEMENT. IN NO EVENT
+SHALL THE COPYRIGHT HOLDERS OR ANYONE DISTRIBUTING THE SOFTWARE BE LIABLE
+FOR ANY DAMAGES OR OTHER LIABILITY, WHETHER IN CONTRACT, TORT OR OTHERWISE,
+ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+DEALINGS IN THE SOFTWARE.
diff --git a/lib/perl/Makefile.PL b/lib/perl/Makefile.PL
new file mode 100644
index 0000000..fa3ea88
--- /dev/null
+++ b/lib/perl/Makefile.PL
@@ -0,0 +1,9 @@
+use ExtUtils::MakeMaker;
+WriteMakefile( 'NAME' => 'Thrift',
+ 'VERSION_FROM' => 'lib/Thrift.pm',
+ 'PREREQ_PM' => {
+ 'Bit::Vector' => 0
+ },
+ ($] >= 5.005 ?
+ ( AUTHOR => 'T Jake Luciani <jakers@gmail.com>') : ()),
+ );
diff --git a/lib/perl/README b/lib/perl/README
new file mode 100644
index 0000000..d1eef70
--- /dev/null
+++ b/lib/perl/README
@@ -0,0 +1,38 @@
+Thrift Perl Software Library
+
+Author: T Jake Luciani (jakers@gmail.com)
+Last Modified: 2007-Apr-28
+
+Thrift is distributed under the Thrift open source software license.
+Please see the included LICENSE file.
+
+Using Thrift with Perl
+=====================
+
+Thrift requires Perl >= 5.6.0
+
+Exceptions are thrown with die so be sure to wrap eval{} statments
+around any code that contains exceptions.
+
+The 64bit Integers work only upto 2^42 on my machine :-?
+Math::BigInt is probably needed.
+
+The only other issue I have with this implementation is the lack of
+strict accessor methods, for example: to set a struct with variable
+foo you must assign it via hash key:
+
+my $x = new StructWithFoo();
+$x->{foo} = "bar";
+
+rather than:
+
+$x->foo("bar");
+
+Please see tutoral and test dirs for examples...
+
+Dependencies
+============
+
+Bit::Vector - comes with modern perl installations.
+
+
diff --git a/lib/perl/lib/Thrift.pm b/lib/perl/lib/Thrift.pm
new file mode 100644
index 0000000..bd0096f
--- /dev/null
+++ b/lib/perl/lib/Thrift.pm
@@ -0,0 +1,169 @@
+#
+# Copyright (c) 2006- Facebook
+# Distributed under the Thrift Software License
+#
+# See accompanying file LICENSE or visit the Thrift site at:
+# http://developers.facebook.com/thrift/
+#
+# package - thrift
+# author - T Jake Luciani <jakers@gmail.com>
+# author - Mark Slee <mcslee@facebook.com>
+#
+
+our $VERSION = '0.1';
+
+require 5.6.0;
+use strict;
+use warnings;
+
+#
+# Data types that can be sent via Thrift
+#
+package TType;
+use constant STOP => 0;
+use constant VOID => 1;
+use constant BOOL => 2;
+use constant BYTE => 3;
+use constant I08 => 3;
+use constant DOUBLE => 4;
+use constant I16 => 6;
+use constant I32 => 8;
+use constant I64 => 10;
+use constant STRING => 11;
+use constant UTF7 => 11;
+use constant STRUCT => 12;
+use constant MAP => 13;
+use constant SET => 14;
+use constant LIST => 15;
+use constant UTF8 => 16;
+use constant UTF16 => 17;
+1;
+
+#
+# Message types for RPC
+#
+package TMessageType;
+use constant CALL => 1;
+use constant REPLY => 2;
+use constant EXCEPTION => 3;
+1;
+
+package Thrift::TException;
+
+sub new {
+ my $classname = shift;
+ my $self = {message => shift, code => shift || 0};
+
+ return bless($self,$classname);
+}
+1;
+
+package TApplicationException;
+use base('Thrift::TException');
+
+use constant UNKNOWN => 0;
+use constant UNKNOWN_METHOD => 1;
+use constant INVALID_MESSAGE_TYPE => 2;
+use constant WRONG_METHOD_NAME => 3;
+use constant BAD_SEQUENCE_ID => 4;
+use constant MISSING_RESULT => 5;
+
+sub new {
+ my $classname = shift;
+
+ my $self = $classname->SUPER::new();
+
+ return bless($self,$classname);
+}
+
+sub read {
+ my $self = shift;
+ my $input = shift;
+
+ my $xfer = 0;
+ my $fname = undef;
+ my $ftype = 0;
+ my $fid = 0;
+
+ $xfer += $input->readStructBegin($fname);
+
+ while (1)
+ {
+ $xfer += $input->readFieldBegin($fname, $ftype, $fid);
+ if ($ftype == TType::STOP) {
+ last; next;
+ }
+
+ SWITCH: for($fid)
+ {
+ /1/ && do{
+
+ if ($ftype == TType::STRING) {
+ $xfer += $input->readString($self->{message});
+ } else {
+ $xfer += $input->skip($ftype);
+ }
+
+ last;
+ };
+
+ /2/ && do{
+ if ($ftype == TType::I32) {
+ $xfer += $input->readI32($self->{code});
+ } else {
+ $xfer += $input->skip($ftype);
+ }
+ last;
+ };
+
+ $xfer += $input->skip($ftype);
+ }
+
+ $xfer += $input->readFieldEnd();
+ }
+ $xfer += $input->readStructEnd();
+
+ return $xfer;
+}
+
+sub write {
+ my $self = shift;
+ my $output = shift;
+
+ my $xfer = 0;
+
+ $xfer += $output->writeStructBegin('TApplicationException');
+
+ if ($self->getMessage()) {
+ $xfer += $output->writeFieldBegin('message', TType::STRING, 1);
+ $xfer += $output->writeString($self->getMessage());
+ $xfer += $output->writeFieldEnd();
+ }
+
+ if ($self->getCode()) {
+ $xfer += $output->writeFieldBegin('type', TType::I32, 2);
+ $xfer += $output->writeI32($self->getCode());
+ $xfer += $output->writeFieldEnd();
+ }
+
+ $xfer += $output->writeFieldStop();
+ $xfer += $output->writeStructEnd();
+
+ return $xfer;
+}
+
+sub getMessage
+{
+ my $self = shift;
+
+ return $self->{message};
+}
+
+sub getCode
+{
+ my $self = shift;
+
+ return $self->{code};
+}
+
+1;
diff --git a/lib/perl/lib/Thrift/BinaryProtocol.pm b/lib/perl/lib/Thrift/BinaryProtocol.pm
new file mode 100644
index 0000000..c17fe91
--- /dev/null
+++ b/lib/perl/lib/Thrift/BinaryProtocol.pm
@@ -0,0 +1,451 @@
+#
+# Copyright (c) 2006- Facebook
+# Distributed under the Thrift Software License
+#
+# See accompanying file LICENSE or visit the Thrift site at:
+# http://developers.facebook.com/thrift/
+#
+# package - thrift.protocol.binary
+# author - T Jake Luciani <jakers@gmail.com>
+# author - Mark Slee <mcslee@facebook.com>
+#
+
+require 5.6.0;
+
+use strict;
+use warnings;
+
+use Thrift;
+use Thrift::Protocol;
+
+use Bit::Vector;
+
+#
+# Binary implementation of the Thrift protocol.
+#
+package Thrift::BinaryProtocol;
+use base('Thrift::Protocol');
+
+sub new
+{
+ my $classname = shift;
+ my $trans = shift;
+ my $self = $classname->SUPER::new($trans);
+
+ return bless($self,$classname);
+}
+
+sub writeMessageBegin
+{
+ my $self = shift;
+ my ($name, $type, $seqid) = @_;
+
+ return
+ $self->writeString($name) +
+ $self->writeByte($type) +
+ $self->writeI32($seqid);
+}
+
+sub writeMessageEnd
+{
+ my $self = shift;
+ return 0;
+}
+
+sub writeStructBegin{
+ my $self = shift;
+ my $name = shift;
+ return 0;
+}
+
+sub writeStructEnd
+{
+ my $self = shift;
+ return 0;
+}
+
+sub writeFieldBegin
+{
+ my $self = shift;
+ my ($fieldName, $fieldType, $fieldId) = @_;
+
+ return
+ $self->writeByte($fieldType) +
+ $self->writeI16($fieldId);
+}
+
+sub writeFieldEnd
+{
+ my $self = shift;
+ return 0;
+}
+
+sub writeFieldStop
+{
+ my $self = shift;
+ return $self->writeByte(TType::STOP);
+}
+
+sub writeMapBegin
+{
+ my $self = shift;
+ my ($keyType, $valType, $size) = @_;
+
+ return
+ $self->writeByte($keyType) +
+ $self->writeByte($valType) +
+ $self->writeI32($size);
+}
+
+sub writeMapEnd
+{
+ my $self = shift;
+ return 0;
+}
+
+sub writeListBegin
+{
+ my $self = shift;
+ my ($elemType, $size) = @_;
+
+ return
+ $self->writeByte($elemType) +
+ $self->writeI32($size);
+}
+
+sub writeListEnd
+{
+ my $self = shift;
+ return 0;
+}
+
+sub writeSetBegin
+{
+ my $self = shift;
+ my ($elemType, $size) = @_;
+
+ return
+ $self->writeByte($elemType) +
+ $self->writeI32($size);
+}
+
+sub writeSetEnd
+{
+ my $self = shift;
+ return 0;
+}
+
+sub writeBool
+{
+ my $self = shift;
+ my $value = shift;
+
+ my $data = pack('c', $value ? 1 : 0);
+ $self->{trans}->write($data, 1);
+ return 1;
+}
+
+sub writeByte
+{
+ my $self = shift;
+ my $value= shift;
+
+ my $data = pack('c', $value);
+ $self->{trans}->write($data, 1);
+ return 1;
+}
+
+sub writeI16
+{
+ my $self = shift;
+ my $value= shift;
+
+ my $data = pack('n', $value);
+ $self->{trans}->write($data, 2);
+ return 2;
+}
+
+sub writeI32
+{
+ my $self = shift;
+ my $value= shift;
+
+ my $data = pack('N', $value);
+ $self->{trans}->write($data, 4);
+ return 4;
+}
+
+sub writeI64
+{
+ my $self = shift;
+ my $value= shift;
+ my $data;
+
+ my $vec;
+ #stop annoying error
+ $vec = Bit::Vector->new_Dec(64, $value);
+ $data = pack 'NN', $vec->Chunk_Read(32, 32), $vec->Chunk_Read(32, 0);
+
+ $self->{trans}->write($data, 8);
+
+ return 8;
+}
+
+
+sub writeDouble
+{
+ my $self = shift;
+ my $value= shift;
+
+ my $data = pack('d', $value);
+ $self->{trans}->write(scalar reverse($data), 8);
+ return 8;
+}
+
+sub writeString{
+ my $self = shift;
+ my $value= shift;
+
+ my $len = length($value);
+
+ my $result = $self->writeI32($len);
+ if ($len) {
+ $self->{trans}->write($value,$len);
+ }
+ return $result + $len;
+ }
+
+
+#
+#All references
+#
+sub readMessageBegin
+{
+ my $self = shift;
+ my ($name, $type, $seqid) = @_;
+
+ return
+ $self->readString($name) +
+ $self->readByte($type) +
+ $self->readI32($seqid);
+}
+
+sub readMessageEnd
+{
+ my $self = shift;
+ return 0;
+}
+
+sub readStructBegin
+{
+ my $self = shift;
+ my $name = shift;
+
+ $$name = '';
+
+ return 0;
+}
+
+sub readStructEnd
+{
+ my $self = shift;
+ return 0;
+}
+
+sub readFieldBegin
+{
+ my $self = shift;
+ my ($name, $fieldType, $fieldId) = @_;
+
+ my $result = $self->readByte($fieldType);
+
+ if ($$fieldType == TType::STOP) {
+ $$fieldId = 0;
+ return $result;
+ }
+
+ $result += $self->readI16($fieldId);
+
+ return $result;
+}
+
+sub readFieldEnd() {
+ my $self = shift;
+ return 0;
+}
+
+sub readMapBegin
+{
+ my $self = shift;
+ my ($keyType, $valType, $size) = @_;
+
+ return
+ $self->readByte($keyType) +
+ $self->readByte($valType) +
+ $self->readI32($size);
+}
+
+sub readMapEnd()
+{
+ my $self = shift;
+ return 0;
+}
+
+sub readListBegin
+{
+ my $self = shift;
+ my ($elemType, $size) = @_;
+
+ return
+ $self->readByte($elemType) +
+ $self->readI32($size);
+}
+
+sub readListEnd
+{
+ my $self = shift;
+ return 0;
+}
+
+sub readSetBegin
+{
+ my $self = shift;
+ my ($elemType, $size) = @_;
+
+ return
+ $self->readByte($elemType) +
+ $self->readI32($size);
+}
+
+sub readSetEnd
+{
+ my $self = shift;
+ return 0;
+}
+
+sub readBool
+{
+ my $self = shift;
+ my $value = shift;
+
+ my $data = $self->{trans}->readAll(1);
+ my @arr = unpack('c', $data);
+ $$value = $arr[0] == 1;
+ return 1;
+}
+
+sub readByte
+{
+ my $self = shift;
+ my $value = shift;
+
+ my $data = $self->{trans}->readAll(1);
+ my @arr = unpack('c', $data);
+ $$value = $arr[0];
+ return 1;
+}
+
+sub readI16
+{
+ my $self = shift;
+ my $value = shift;
+
+ my $data = $self->{trans}->readAll(2);
+
+ my @arr = unpack('n', $data);
+
+ $$value = $arr[0];
+
+ if ($$value > 0x7fff) {
+ $$value = 0 - (($$value - 1) ^ 0xffff);
+ }
+
+ return 2;
+}
+
+sub readI32
+{
+ my $self = shift;
+ my $value= shift;
+
+ my $data = $self->{trans}->readAll(4);
+ my @arr = unpack('N', $data);
+
+ $$value = $arr[0];
+ if ($$value > 0x7fffffff) {
+ $$value = 0 - (($$value - 1) ^ 0xffffffff);
+ }
+ return 4;
+}
+
+sub readI64
+{
+ my $self = shift;
+ my $value = shift;
+
+ my $data = $self->{trans}->readAll(8);
+
+ my ($hi,$lo)=unpack('NN',$data);
+
+ my $vec = new Bit::Vector(64);
+
+ $vec->Chunk_Store(32,32,$hi);
+ $vec->Chunk_Store(32,0,$lo);
+
+ $$value = $vec->to_Dec();
+
+ return 8;
+}
+
+sub readDouble
+{
+ my $self = shift;
+ my $value = shift;
+
+ my $data = scalar reverse($self->{trans}->readAll(8));
+ my @arr = unpack('d', $data);
+
+ $$value = $arr[0];
+
+ return 8;
+}
+
+sub readString
+{
+ my $self = shift;
+ my $value = shift;
+
+ my $len;
+ my $result = $self->readI32(\$len);
+
+ if ($len) {
+ $$value = $self->{trans}->readAll($len);
+ } else {
+ $$value = '';
+ }
+
+ return $result + $len;
+}
+
+#
+# Binary Protocol Factory
+#
+package TBinaryProtocolFactory;
+use base('TProtocolFactory');
+
+sub new
+{
+ my $classname = shift;
+ my $self = $classname->SUPER::new();
+
+ return bless($self,$classname);
+}
+
+sub getProtocol{
+ my $self = shift;
+ my $trans = shift;
+
+ return new TBinaryProtocol($trans);
+}
+
+1;
diff --git a/lib/perl/lib/Thrift/BufferedTransport.pm b/lib/perl/lib/Thrift/BufferedTransport.pm
new file mode 100644
index 0000000..856a943
--- /dev/null
+++ b/lib/perl/lib/Thrift/BufferedTransport.pm
@@ -0,0 +1,113 @@
+#
+# Copyright (c) 2006- Facebook
+# Distributed under the Thrift Software License
+#
+# See accompanying file LICENSE or visit the Thrift site at:
+# http://developers.facebook.com/thrift/
+#
+# package - thrift.transport.buffered
+# author - T Jake Luciani <jakers@gmail.com>
+# author - Mark Slee <mcslee@facebook.com>
+#
+
+require 5.6.0;
+use strict;
+use warnings;
+
+use Thrift;
+use Thrift::Transport;
+
+package Thrift::BufferedTransport;
+use base('Thrift::Transport');
+
+sub new
+{
+ my $classname = shift;
+ my $transport = shift;
+ my $rBufSize = shift || 512;
+ my $wBufSize = shift || 512;
+
+ my $self = {
+ transport => $transport,
+ rBufSize => $rBufSize,
+ wBufSize => $wBufSize,
+ wBuf => '',
+ rBuf => '',
+ };
+
+ return bless($self,$classname);
+}
+
+sub isOpen
+{
+ my $self = shift;
+
+ return $self->{transport}->isOpen();
+}
+
+sub open
+{
+ my $self = shift;
+ $self->{transport}->open();
+}
+
+sub close()
+{
+ my $self = shift;
+ $self->{transport}->close();
+}
+
+sub readAll
+{
+ my $self = shift;
+ my $len = shift;
+
+ return $self->{transport}->readAll($len);
+}
+
+sub read
+{
+ my $self = shift;
+ my $len = shift;
+ my $ret;
+
+ # Methinks Perl is already buffering these for us
+ return $self->{transport}->read($len);
+
+ if (length($self->{rBuf}) >= $len) {
+ $ret = substr($self->{rBuf}, 0, $len);
+ $self->{rBuf} = substr($self->rBuf_, $len);
+ return $ret;
+ }
+
+ $self->{rBuf} .= $self->{transport}->read($self->{rBufSize});
+ my $give = min(length($self->{rBuf}), $len);
+ $ret = substr($self->{rBuf}, 0, $give);
+ $self->{rBuf} = substr($self->{rBuf}, $give);
+ return $ret;
+}
+
+sub write
+{
+ my $self = shift;
+ my $buf = shift;
+
+ $self->{wBuf} .= $buf;
+ if (length($self->{wBuf}) >= $self->{wBufSize}) {
+ $self->{transport}->write($self->{wBuf});
+ $self->{wBuf} = '';
+ }
+}
+
+sub flush
+{
+ my $self = shift;
+
+ if (length($self->{wBuf}) > 0) {
+ $self->{transport}->write($self->{wBuf});
+ $self->{wBuf} = '';
+ }
+}
+
+
+1;
diff --git a/lib/perl/lib/Thrift/FramedTransport.pm b/lib/perl/lib/Thrift/FramedTransport.pm
new file mode 100644
index 0000000..43e7b6f
--- /dev/null
+++ b/lib/perl/lib/Thrift/FramedTransport.pm
@@ -0,0 +1,156 @@
+#
+# Copyright (c) 2006- Facebook
+# Distributed under the Thrift Software License
+#
+# See accompanying file LICENSE or visit the Thrift site at:
+# http://developers.facebook.com/thrift/
+#
+# package - thrift
+# author - T Jake Luciani <jakers@gmail.com>
+# author - Mark Slee <mcslee@facebook.com>
+#
+require 5.6.0;
+use strict;
+use warnings;
+
+use Thrift;
+use Thrift::Transport;
+
+#
+# Framed transport. Writes and reads data in chunks that are stamped with
+# their length.
+#
+# @package thrift.transport
+# @author Mark Slee <mcslee@facebook.com>
+#
+package Thrift::FramedTransport;
+
+use base('Thrift::Transport');
+
+sub new
+{
+ my $classname = shift;
+ my $transport = shift;
+ my $read = shift || 1;
+ my $write = shift || 1;
+
+ my $self = {
+ transport => $transport,
+ read => $read,
+ write => $write,
+ wBuf => '',
+ rBuf => '',
+ };
+
+ return bless($self,$classname);
+}
+
+sub isOpen
+{
+ my $self = shift;
+ return $self->{transport}->isOpen();
+}
+
+sub open
+{
+ my $self = shift;
+
+ $self->{transport}->open();
+}
+
+sub close
+{
+ my $self = shift;
+
+ $self->{transport}->close();
+}
+
+#
+# Reads from the buffer. When more data is required reads another entire
+# chunk and serves future reads out of that.
+#
+# @param int $len How much data
+#
+sub read
+{
+ my $self = shift;
+ my $len = shift;
+
+ unless($self->{read}) {
+ return $self->{transport}->read($len);
+ }
+
+ if (length($self->{rBuf}) > 0) {
+ $self->_readFrame();
+ }
+
+ # Just return full buff
+ if ($len > length($self->{rBuf})) {
+ my $out = $self->{rBuf};
+ $self->{rBuf} = '';
+ return $out;
+ }
+
+ # Return substr
+ my $out = substr($self->{rBuf}, 0, $len);
+ $self->{rBuf} = substr($self->{rBuf}, $len);
+ return $out;
+}
+
+#
+# Reads a chunk of data into the internal read buffer.
+# (private)
+sub _readFrame
+{
+ my $self = shift;
+ my $buf = $self->{transport}->readAll(4);
+ my @val = unpack('N', $buf);
+ my $sz = $val[1];
+
+ $self->{rBuf} = $self->{transport}->readAll($sz);
+}
+
+#
+# Writes some data to the pending output buffer.
+#
+# @param string $buf The data
+# @param int $len Limit of bytes to write
+#
+sub write
+{
+ my $self = shift;
+ my $buf = shift;
+ my $len = shift;
+
+ unless($self->{write}) {
+ return $self->{transport}->write($buf, $len);
+ }
+
+ if ( defined $len && $len < length($buf)) {
+ $buf = substr($buf, 0, $len);
+ }
+
+ $self->{wBuf} .= $buf;
+ }
+
+#
+# Writes the output buffer to the stream in the format of a 4-byte length
+# followed by the actual data.
+#
+sub flush
+{
+ my $self = shift;
+
+ unless ($self->{write}) {
+ return $self->{transport}->flush();
+ }
+
+ my $out = pack('N', length($self->{wBuf}));
+ $out .= $self->{wBuf};
+ $self->{transport}->write($out);
+ $self->{transport}->flush();
+ $self->{wBuf} = '';
+
+}
+
+1;
diff --git a/lib/perl/lib/Thrift/Protocol.pm b/lib/perl/lib/Thrift/Protocol.pm
new file mode 100644
index 0000000..ceea52e
--- /dev/null
+++ b/lib/perl/lib/Thrift/Protocol.pm
@@ -0,0 +1,536 @@
+#
+# Copyright (c) 2006- Facebook
+# Distributed under the Thrift Software License
+#
+# See accompanying file LICENSE or visit the Thrift site at:
+# http://developers.facebook.com/thrift/
+#
+# package - thrift.protocol
+# author - T Jake Luciani <jakers@gmail.com>
+# author - Mark Slee <mcslee@facebook.com>
+#
+
+require 5.6.0;
+use strict;
+use warnings;
+
+use Thrift;
+
+#
+# Protocol exceptions
+#
+package TProtocolException;
+use base('Thrift::TException');
+
+use constant UNKNOWN => 0;
+use constant INVALID_DATA => 1;
+use constant NEGATIVE_SIZE => 2;
+use constant SIZE_LIMIT => 3;
+
+
+sub new {
+ my $classname = shift;
+
+ my $self = $classname->SUPER::new();
+
+ return bless($self,$classname);
+}
+
+#
+# Protocol base class module.
+#
+package Thrift::Protocol;
+
+sub new {
+ my $classname = shift;
+ my $self = {};
+
+ my $trans = shift;
+ $self->{trans}= $trans;
+
+ return bless($self,$classname);
+}
+
+sub getTransport
+{
+ my $self = shift;
+
+ return $self->{trans};
+}
+
+#
+# Writes the message header
+#
+# @param string $name Function name
+# @param int $type message type TMessageType::CALL or TMessageType::REPLY
+# @param int $seqid The sequence id of this message
+#
+sub writeMessageBegin
+{
+ my ($name, $type, $seqid);
+ die "abstract";
+}
+
+#
+# Close the message
+#
+sub writeMessageEnd {
+ die "abstract";
+}
+
+#
+# Writes a struct header.
+#
+# @param string $name Struct name
+# @throws TException on write error
+# @return int How many bytes written
+#
+sub writeStructBegin {
+ my ($name);
+
+ die "abstract";
+}
+
+#
+# Close a struct.
+#
+# @throws TException on write error
+# @return int How many bytes written
+#
+sub writeStructEnd {
+ die "abstract";
+}
+
+#
+# Starts a field.
+#
+# @param string $name Field name
+# @param int $type Field type
+# @param int $fid Field id
+# @throws TException on write error
+# @return int How many bytes written
+#
+sub writeFieldBegin {
+ my ($fieldName, $fieldType, $fieldId);
+
+ die "abstract";
+}
+
+sub writeFieldEnd {
+ die "abstract";
+}
+
+sub writeFieldStop {
+ die "abstract";
+}
+
+sub writeMapBegin {
+ my ($keyType, $valType, $size);
+
+ die "abstract";
+}
+
+sub writeMapEnd {
+ die "abstract";
+}
+
+sub writeListBegin {
+ my ($elemType, $size);
+ die "abstract";
+}
+
+sub writeListEnd {
+ die "abstract";
+}
+
+sub writeSetBegin {
+ my ($elemType, $size);
+ die "abstract";
+}
+
+sub writeSetEnd {
+ die "abstract";
+}
+
+sub writeBool {
+ my ($bool);
+ die "abstract";
+}
+
+sub writeByte {
+ my ($byte);
+ die "abstract";
+}
+
+sub writeI16 {
+ my ($i16);
+ die "abstract";
+}
+
+sub writeI32 {
+ my ($i32);
+ die "abstract";
+}
+
+sub writeI64 {
+ my ($i64);
+ die "abstract";
+}
+
+sub writeDouble {
+ my ($dub);
+ die "abstract";
+}
+
+sub writeString
+{
+ my ($str);
+ die "abstract";
+}
+
+#
+# Reads the message header
+#
+# @param string $name Function name
+# @param int $type message type TMessageType::CALL or TMessageType::REPLY
+# @parem int $seqid The sequence id of this message
+#
+sub readMessageBegin
+{
+ my ($name, $type, $seqid);
+ die "abstract";
+}
+
+#
+# Read the close of message
+#
+sub readMessageEnd
+{
+ die "abstract";
+}
+
+sub readStructBegin
+{
+ my($name);
+
+ die "abstract";
+}
+
+sub readStructEnd
+{
+ die "abstract";
+}
+
+sub readFieldBegin
+{
+ my ($name, $fieldType, $fieldId);
+ die "abstract";
+}
+
+sub readFieldEnd
+{
+ die "abstract";
+}
+
+sub readMapBegin
+{
+ my ($keyType, $valType, $size);
+ die "abstract";
+}
+
+sub readMapEnd
+{
+ die "abstract";
+}
+
+sub readListBegin
+{
+ my ($elemType, $size);
+ die "abstract";
+}
+
+sub readListEnd
+{
+ die "abstract";
+}
+
+sub readSetBegin
+{
+ my ($elemType, $size);
+ die "abstract";
+}
+
+sub readSetEnd
+{
+ die "abstract";
+}
+
+sub readBool
+{
+ my ($bool);
+ die "abstract";
+}
+
+sub readByte
+{
+ my ($byte);
+ die "abstract";
+}
+
+sub readI16
+{
+ my ($i16);
+ die "abstract";
+}
+
+sub readI32
+{
+ my ($i32);
+ die "abstract";
+}
+
+sub readI64
+{
+ my ($i64);
+ die "abstract";
+}
+
+sub readDouble
+{
+ my ($dub);
+ die "abstract";
+}
+
+sub readString
+{
+ my ($str);
+ die "abstract";
+}
+
+#
+# The skip function is a utility to parse over unrecognized data without
+# causing corruption.
+#
+# @param TType $type What type is it
+#
+sub skip
+{
+ my $self = shift;
+ my $type = shift;
+
+ my $ref;
+ my $result;
+ my $i;
+
+ if($type == TType::BOOL)
+ {
+ return $self->readBool(\$ref);
+ }
+ elsif($type == TType::BYTE){
+ return $self->readByte(\$ref);
+ }
+ elsif($type == TType::I16){
+ return $self->readI16(\$ref);
+ }
+ elsif($type == TType::I32){
+ return $self->readI32(\$ref);
+ }
+ elsif($type == TType::I64){
+ return $self->readI64(\$ref);
+ }
+ elsif($type == TType::DOUBLE){
+ return $self->readDouble(\$ref);
+ }
+ elsif($type == TType::STRING)
+ {
+ return $self->readString(\$ref);
+ }
+ elsif($type == TType::STRUCT)
+ {
+ $result = $self->readStructBegin(\$ref);
+ while (1) {
+ my ($ftype,$fid);
+ $result += $self->readFieldBegin(\$ref, \$ftype, \$fid);
+ if ($ftype == TType::STOP) {
+ last;
+ }
+ $result += $self->skip($ftype);
+ $result += $self->readFieldEnd();
+ }
+ $result += $self->readStructEnd();
+ return $result;
+ }
+ elsif($type == TType::MAP)
+ {
+ my($keyType,$valType,$size);
+ $result = $self->readMapBegin(\$keyType, \$valType, \$size);
+ for ($i = 0; $i < $size; $i++) {
+ $result += $self->skip($keyType);
+ $result += $self->skip($valType);
+ }
+ $result += $self->readMapEnd();
+ return $result;
+ }
+ elsif($type == TType::SET)
+ {
+ my ($elemType,$size);
+ $result = $self->readSetBegin(\$elemType, \$size);
+ for ($i = 0; $i < $size; $i++) {
+ $result += $self->skip($elemType);
+ }
+ $result += $self->readSetEnd();
+ return $result;
+ }
+ elsif($type == TType::LIST)
+ {
+ my ($elemType,$size);
+ $result = $self->readListBegin(\$elemType, \$size);
+ for ($i = 0; $i < $size; $i++) {
+ $result += $self->skip($elemType);
+ }
+ $result += $self->readListEnd();
+ return $result;
+ }
+
+
+ return 0;
+
+ }
+
+#
+# Utility for skipping binary data
+#
+# @param TTransport $itrans TTransport object
+# @param int $type Field type
+#
+sub skipBinary
+{
+ my $self = shift;
+ my $itrans = shift;
+ my $type = shift;
+
+ if($type == TType::BOOL)
+ {
+ return $itrans->readAll(1);
+ }
+ elsif($type == TType::BYTE)
+ {
+ return $itrans->readAll(1);
+ }
+ elsif($type == TType::I16)
+ {
+ return $itrans->readAll(2);
+ }
+ elsif($type == TType::I32)
+ {
+ return $itrans->readAll(4);
+ }
+ elsif($type == TType::I64)
+ {
+ return $itrans->readAll(8);
+ }
+ elsif($type == TType::DOUBLE)
+ {
+ return $itrans->readAll(8);
+ }
+ elsif( $type == TType::STRING )
+ {
+ my @len = unpack('N', $itrans->readAll(4));
+ my $len = $len[0];
+ if ($len > 0x7fffffff) {
+ $len = 0 - (($len - 1) ^ 0xffffffff);
+ }
+ return 4 + $itrans->readAll($len);
+ }
+ elsif( $type == TType::STRUCT )
+ {
+ my $result = 0;
+ while (1) {
+ my $ftype = 0;
+ my $fid = 0;
+ my $data = $itrans->readAll(1);
+ my @arr = unpack('c', $data);
+ $ftype = $arr[0];
+ if ($ftype == TType::STOP) {
+ last;
+ }
+ # I16 field id
+ $result += $itrans->readAll(2);
+ $result += $self->skipBinary($itrans, $ftype);
+ }
+ return $result;
+ }
+ elsif($type == TType::MAP)
+ {
+ # Ktype
+ my $data = $itrans->readAll(1);
+ my @arr = unpack('c', $data);
+ my $ktype = $arr[0];
+ # Vtype
+ $data = $itrans->readAll(1);
+ @arr = unpack('c', $data);
+ my $vtype = $arr[0];
+ # Size
+ $data = $itrans->readAll(4);
+ @arr = unpack('N', $data);
+ my $size = $arr[0];
+ if ($size > 0x7fffffff) {
+ $size = 0 - (($size - 1) ^ 0xffffffff);
+ }
+ my $result = 6;
+ for (my $i = 0; $i < $size; $i++) {
+ $result += $self->skipBinary($itrans, $ktype);
+ $result += $self->skipBinary($itrans, $vtype);
+ }
+ return $result;
+ }
+ elsif($type == TType::SET || $type == TType::LIST)
+ {
+ # Vtype
+ my $data = $itrans->readAll(1);
+ my @arr = unpack('c', $data);
+ my $vtype = $arr[0];
+ # Size
+ $data = $itrans->readAll(4);
+ @arr = unpack('N', $data);
+ my $size = $arr[0];
+ if ($size > 0x7fffffff) {
+ $size = 0 - (($size - 1) ^ 0xffffffff);
+ }
+ my $result = 5;
+ for (my $i = 0; $i < $size; $i++) {
+ $result += $self->skipBinary($itrans, $vtype);
+ }
+ return $result;
+ }
+
+ return 0;
+
+}
+
+#
+# Protocol factory creates protocol objects from transports
+#
+package TProtocolFactory;
+
+
+sub new {
+ my $classname = shift;
+ my $self = {};
+
+ return bless($self,$classname);
+}
+
+#
+# Build a protocol from the base transport
+#
+# @return TProtcol protocol
+#
+sub getProtocol
+{
+ my ($trans);
+ die "interface";
+}
+
+
+1;
diff --git a/lib/perl/lib/Thrift/Socket.pm b/lib/perl/lib/Thrift/Socket.pm
new file mode 100644
index 0000000..83daf4b
--- /dev/null
+++ b/lib/perl/lib/Thrift/Socket.pm
@@ -0,0 +1,249 @@
+#
+# Copyright (c) 2006- Facebook
+# Distributed under the Thrift Software License
+#
+# See accompanying file LICENSE or visit the Thrift site at:
+# http://developers.facebook.com/thrift/
+#
+# package - thrift.socket
+# author - T Jake Luciani <jakers@gmail.com>
+# author - Mark Slee <mcslee@facebook.com>
+#
+
+require 5.6.0;
+use strict;
+use warnings;
+
+use Thrift;
+use Thrift::Transport;
+
+use IO::Socket::INET;
+use IO::Select;
+
+package Thrift::Socket;
+
+use base('Thrift::Transport');
+
+sub new
+{
+ my $classname = shift;
+ my $host = shift || "localhost";
+ my $port = shift || 9090;
+ my $debugHandler = shift;
+
+ my $self = {
+ host => $host,
+ port => $port,
+ debugHandler => $debugHandler,
+ debug => 0,
+ sendTimeout => 100,
+ recvTimeout => 750,
+ handle => undef,
+ };
+
+ return bless($self,$classname);
+}
+
+
+sub setSendTimeout
+{
+ my $self = shift;
+ my $timeout = shift;
+
+ $self->{sendTimeout} = $timeout;
+}
+
+sub setRecvTimeout
+{
+ my $self = shift;
+ my $timeout = shift;
+
+ $self->{recvTimeout} = $timeout;
+}
+
+
+#
+#Sets debugging output on or off
+#
+# @param bool $debug
+#
+sub setDebug
+{
+ my $self = shift;
+ my $debug = shift;
+
+ $self->{debug} = $debug;
+}
+
+#
+# Tests whether this is open
+#
+# @return bool true if the socket is open
+#
+sub isOpen
+{
+ my $self = shift;
+
+ return $self->{handle}->handles->[0]->connected;
+}
+
+#
+# Connects the socket.
+#
+sub open
+{
+ my $self = shift;
+
+ my $sock = IO::Socket::INET->new(PeerAddr => $self->{host},
+ PeerPort => $self->{port},
+ Proto => 'tcp',
+ Timeout => $self->{sendTimeout}/1000)
+ || do {
+ my $error = 'TSocket: Could not connect to '.$self->{host}.':'.$self->{port}.' ('.$!.')';
+
+ if ($self->{debug}) {
+ $self->{debugHandler}->($error);
+ }
+
+ die new Thrift::TException($error);
+
+ };
+
+
+ $self->{handle} = new IO::Select( $sock );
+}
+
+#
+# Closes the socket.
+#
+sub close
+{
+ my $self = shift;
+
+ close( ($self->{handle}->handles())[0] );
+}
+
+#
+# Uses stream get contents to do the reading
+#
+# @param int $len How many bytes
+# @return string Binary data
+#
+sub readAll
+{
+ my $self = shift;
+ my $len = shift;
+
+
+ my $pre = "";
+ while (1) {
+
+ #check for timeout
+ my @sockets = $self->{handle}->can_read( $self->{recvTimeout} );
+
+ if(@sockets == 0){
+ die new Thrift::TException('TSocket: timed out reading '.$len.' bytes from '.
+ $self->{host}.':'.$self->{port});
+ }
+
+ my $sock = $sockets[0];
+
+ my ($buf,$sz);
+ $sock->recv($buf, $len);
+
+ if (!defined $buf || $buf eq '') {
+
+ die new Thrift::TException('TSocket: Could not read '.$len.' bytes from '.
+ $self->{host}.':'.$self->{port});
+
+ } elsif (($sz = length($buf)) < $len) {
+
+ $pre .= $buf;
+ $len -= $sz;
+
+ } else {
+ return $pre.$buf;
+ }
+ }
+}
+
+#
+# Read from the socket
+#
+# @param int $len How many bytes
+# @return string Binary data
+#
+sub read
+{
+ my $self = shift;
+ my $len = shift;
+
+ #check for timeout
+ my @sockets = $self->{handle}->can_read( $self->{sendTimeout} );
+
+ if(@sockets == 0){
+ die new Thrift::TException('TSocket: timed out reading '.$len.' bytes from '.
+ $self->{host}.':'.$self->{port});
+ }
+
+ my $sock = $sockets[0];
+
+ my ($buf,$sz);
+ $sock->recv($buf, $len);
+
+ if (!defined $buf || $buf eq '') {
+
+ die new TException('TSocket: Could not read '.$len.' bytes from '.
+ $self->{host}.':'.$self->{port});
+
+ }
+
+ return $buf;
+}
+
+
+#
+# Write to the socket.
+#
+# @param string $buf The data to write
+#
+sub write
+{
+ my $self = shift;
+ my $buf = shift;
+
+
+ while (length($buf) > 0) {
+
+
+ #check for timeout
+ my @sockets = $self->{handle}->can_write( $self->{recvTimeout} );
+
+ if(@sockets == 0){
+ die new Thrift::TException('TSocket: timed out writing to bytes from '.
+ $self->{host}.':'.$self->{port});
+ }
+
+ my $sock = $sockets[0];
+
+ my $got = $sock->send($buf);
+
+ if (!defined $got || $got == 0 ) {
+ die new Thrift::TException('TSocket: Could not write '.strlen($buf).' bytes '.
+ $self->{host}.':'.$self->{host});
+ }
+
+ $buf = substr($buf, $got);
+ }
+}
+
+#
+# Flush output to the socket.
+#
+sub flush
+{
+ my $self = shift;
+ my $ret = ($self->{handle}->handles())[0]->flush;
+}
+
+1;
diff --git a/lib/perl/lib/Thrift/Transport.pm b/lib/perl/lib/Thrift/Transport.pm
new file mode 100644
index 0000000..989ccb6
--- /dev/null
+++ b/lib/perl/lib/Thrift/Transport.pm
@@ -0,0 +1,122 @@
+#
+# Copyright (c) 2006- Facebook
+# Distributed under the Thrift Software License
+#
+# See accompanying file LICENSE or visit the Thrift site at:
+# http://developers.facebook.com/thrift/
+#
+# package - thrift.transport
+# author - T Jake Luciani <jakers@gmail.com>
+# author - Mark Slee <mcslee@facebook.com>
+#
+
+require 5.6.0;
+use strict;
+use warnings;
+
+use Thrift;
+
+#
+# Transport exceptions
+#
+package TTransportException;
+use base('Thrift::TException');
+
+use constant UNKNOWN => 0;
+use constant NOT_OPEN => 1;
+use constant ALREADY_OPEN => 2;
+use constant TIMED_OUT => 3;
+use constant END_OF_FILE => 4;
+
+sub new{
+ my $classname = shift;
+ my $self = $classname->SUPER::new(@_);
+
+ return bless($self,$classname);
+}
+
+package Thrift::Transport;
+
+#
+# Whether this transport is open.
+#
+# @return boolean true if open
+#
+sub isOpen
+{
+ die "abstract";
+}
+
+#
+# Open the transport for reading/writing
+#
+# @throws TTransportException if cannot open
+#
+sub open
+{
+ die "abstract";
+}
+
+#
+# Close the transport.
+#
+sub close
+{
+ die "abstract";
+}
+
+#
+# Read some data into the array.
+#
+# @param int $len How much to read
+# @return string The data that has been read
+# @throws TTransportException if cannot read any more data
+#
+sub read
+{
+ my ($len);
+ die("abstract");
+}
+
+#
+# Guarantees that the full amount of data is read.
+#
+# @return string The data, of exact length
+# @throws TTransportException if cannot read data
+#
+sub readAll
+{
+ my $self = shift;
+ my $len = shift;
+
+ my $data = '';
+ my $got = 0;
+
+ while (($got = length($data)) < $len) {
+ $data .= $self->read($len - $got);
+ }
+
+ return $data;
+}
+
+#
+# Writes the given data out.
+#
+# @param string $buf The data to write
+# @throws TTransportException if writing fails
+#
+sub write
+{
+ my ($buf);
+ die "abstract";
+}
+
+#
+# Flushes any pending data out of a buffer
+#
+# @throws TTransportException if a writing error occurs
+#
+sub flush {}
+
+1;
+