Skip to content
This repository
Browse code

perl port of the python lib!

  • Loading branch information...
commit 36f792f9cfb405fcdb6b0de3920ae8e6696c6f0d 1 parent f399af6
Michael Gregorowicz authored
6  contrib/perl/CJDNS/Changes
... ...
@@ -0,0 +1,6 @@
  1
+Revision history for Perl extension CJDNS.
  2
+
  3
+0.01  Mon Apr 16 11:47:52 2012
  4
+	- original version; created by h2xs 1.23 with options
  5
+		-AX --skip-exporter --use-new-tests -n CJDNS
  6
+
6  contrib/perl/CJDNS/MANIFEST
... ...
@@ -0,0 +1,6 @@
  1
+Changes
  2
+Makefile.PL
  3
+MANIFEST
  4
+README
  5
+t/CJDNS.t
  6
+lib/CJDNS.pm
12  contrib/perl/CJDNS/Makefile.PL
... ...
@@ -0,0 +1,12 @@
  1
+use 5.014002;
  2
+use ExtUtils::MakeMaker;
  3
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
  4
+# the contents of the Makefile that is written.
  5
+WriteMakefile(
  6
+    NAME              => 'CJDNS',
  7
+    VERSION_FROM      => 'lib/CJDNS.pm', # finds $VERSION
  8
+    PREREQ_PM         => {Bencode => 1.4, 'Digest::SHA2' => 1.1}, # e.g., Module::Name => 1.1
  9
+    ($] >= 5.005 ?     ## Add these new keywords supported since 5.005
  10
+      (ABSTRACT_FROM  => 'lib/CJDNS.pm', # retrieve abstract from module
  11
+       AUTHOR         => 'Michael Gregorowicz <mike@mg2.org>') : ()),
  12
+);
40  contrib/perl/CJDNS/README
... ...
@@ -0,0 +1,40 @@
  1
+CJDNS version 0.01
  2
+==================
  3
+
  4
+The README is used to introduce the module and provide instructions on
  5
+how to install the module, any machine dependencies it may have (for
  6
+example C compilers and installed libraries) and any other information
  7
+that should be provided before the module is installed.
  8
+
  9
+A README file is required for CPAN modules since CPAN extracts the
  10
+README file from a module distribution so that people browsing the
  11
+archive can use it get an idea of the modules uses. It is usually a
  12
+good idea to provide version information here so that people can
  13
+decide whether fixes for the module are worth downloading.
  14
+
  15
+INSTALLATION
  16
+
  17
+To install this module type the following:
  18
+
  19
+   perl Makefile.PL
  20
+   make
  21
+   make test
  22
+   make install
  23
+
  24
+DEPENDENCIES
  25
+
  26
+This module requires these other modules and libraries:
  27
+
  28
+  blah blah blah
  29
+
  30
+COPYRIGHT AND LICENCE
  31
+
  32
+Put the correct copyright and licence information here.
  33
+
  34
+Copyright (C) 2012 by Michael Gregorowicz
  35
+
  36
+This library is free software; you can redistribute it and/or modify
  37
+it under the same terms as Perl itself, either Perl version 5.14.2 or,
  38
+at your option, any later version of Perl 5 you may have available.
  39
+
  40
+
212  contrib/perl/CJDNS/lib/CJDNS.pm
... ...
@@ -0,0 +1,212 @@
  1
+package CJDNS;
  2
+
  3
+use Bencode qw(bencode bdecode);
  4
+use Carp qw/croak/;
  5
+use Digest::SHA2;
  6
+use IO::Socket;
  7
+
  8
+# buffer size for reading from teh sawkets.
  9
+use constant BUFFER_SIZE => 1024;
  10
+
  11
+our @ISA = qw();
  12
+our $VERSION = '0.01';
  13
+our $sha2 = new Digest::SHA2 256;
  14
+
  15
+# turn on autoflush for this class.
  16
+our $| = 1;
  17
+
  18
+sub new {
  19
+    my ($class, $addr, $port, $password) = @_;
  20
+
  21
+    my $self = bless({
  22
+        connection => "$addr:$port",
  23
+        password => $password,
  24
+    }, $class);
  25
+
  26
+    $self->{s} = IO::Socket::INET->new(
  27
+        PeerAddr => $addr,
  28
+        PeerPort => $port,
  29
+        Proto => 'tcp',
  30
+        Type => SOCK_STREAM
  31
+    );
  32
+
  33
+    unless ($self->_ping) {
  34
+        die "Error, cannot ping CJDNS admin service on $self->{connection}\n";
  35
+    }
  36
+
  37
+    $self->_make_methods;
  38
+
  39
+    return $self;
  40
+}
  41
+
  42
+sub _make_methods {
  43
+    my ($self) = @_;
  44
+    my $s = $self->s;
  45
+
  46
+    my ($to_decode);
  47
+    print $s "d1:q7:invalide";
  48
+    while (1) {
  49
+        my $data;
  50
+        recv($s, $data, BUFFER_SIZE, undef);
  51
+        if (length($data)) {
  52
+            $to_decode .= $data;
  53
+            if (length($data) < BUFFER_SIZE) {
  54
+                last;
  55
+            }
  56
+        }
  57
+    }
  58
+
  59
+    my $decoded = bdecode($to_decode);
  60
+
  61
+    # first let's start by loading them as named into the CJDNS namespace.
  62
+
  63
+    foreach my $method_name (keys %{$decoded->{availableFunctions}}) {
  64
+        my $prototype = $decoded->{availableFunctions}->{$method_name};
  65
+        $self->{capabilities}->{$method_name} = $prototype;
  66
+
  67
+        # This is the code that actually calls the function!
  68
+        my $method = sub {
  69
+            my ($self, %args) = @_;
  70
+            my $s = $self->s;
  71
+            my ($to_decode);
  72
+            print $s "d1:q6:cookiee";
  73
+            while (1) {
  74
+                my $data;
  75
+                recv($s, $data, BUFFER_SIZE, undef);
  76
+                if (length($data)) {
  77
+                    $to_decode .= $data;
  78
+                    if (length($data) < BUFFER_SIZE) {
  79
+                        last;
  80
+                    }
  81
+                }
  82
+            }
  83
+
  84
+            my $dec = bdecode($to_decode);
  85
+
  86
+            my $cookie = $dec->{cookie};
  87
+
  88
+            my $req = {
  89
+                q => 'auth',
  90
+                aq => $method_name,
  91
+                hash => $self->_sha2_hexdigest($self->{password} . $cookie),
  92
+                cookie => " $cookie",
  93
+                args => \%args,
  94
+            };
  95
+
  96
+            # replace $req->{hash} with a hash of the bencoded request.
  97
+            my $req_benc = bencode($req);
  98
+            $req->{hash} = $self->_sha2_hexdigest($req_benc);
  99
+
  100
+            # then re-encode thusly:
  101
+            $req_benc = bencode($req);
  102
+
  103
+            print $s $req_benc;
  104
+
  105
+            my ($to_decode);
  106
+            while (1) {
  107
+                my $data;
  108
+                recv($s, $data, BUFFER_SIZE, undef);
  109
+                if (length($data)) {
  110
+                    $to_decode .= $data;
  111
+                    if (length($data) < BUFFER_SIZE) {
  112
+                        last;
  113
+                    }
  114
+                }
  115
+            }
  116
+            my $dec = bdecode($to_decode);
  117
+            if (ref($dec)) {
  118
+                if ($dec->{error}) {
  119
+                    croak "[error] CJDNS method '$method_name': $dec->{error}";
  120
+                } 
  121
+            }
  122
+            return $dec;
  123
+        };
  124
+
  125
+        # and now it's a method!
  126
+        my $full_name = "CJDNS::$method_name";
  127
+        *{$full_name} = $method;
  128
+    }
  129
+}
  130
+
  131
+sub capabilities {
  132
+    my ($self) = @_;
  133
+    my $return = "CJDNS Administration Protocol Capabilities\n";
  134
+    $return .= "------------------------------------------\n";
  135
+    foreach my $func (keys %{$self->{capabilities}}) {
  136
+        $return .= " $func\n";
  137
+        foreach my $attr (keys %{$self->{capabilities}->{$func}}) {
  138
+            $return .= "   + $attr: $self->{capabilities}->{$func}->{$attr}->{type} ";
  139
+
  140
+            if ($self->{capabilities}->{$func}->{$attr}->{required}) {
  141
+                $return .= "[required]";
  142
+            }
  143
+            
  144
+            $return .= "\n";
  145
+        }
  146
+        $return .= "\n";
  147
+    }
  148
+    return $return;
  149
+}
  150
+
  151
+sub _sha2_hexdigest {
  152
+    my ($self, $string) = @_;
  153
+    $sha2->reset();
  154
+    $sha2->add($string);
  155
+    return $sha2->hexdigest;
  156
+}
  157
+
  158
+sub _ping {
  159
+    my ($self) = @_;
  160
+    my $s = $self->s;
  161
+
  162
+    my $data;
  163
+    print $s "d1:q4:pinge";
  164
+    recv($s, $data, BUFFER_SIZE, undef);
  165
+
  166
+    if ($data eq "d1:q4:ponge") {
  167
+        return 1;
  168
+    } else {
  169
+        return undef;
  170
+    }
  171
+}
  172
+
  173
+sub s {
  174
+    my ($self) = @_;
  175
+    return $self->{s};
  176
+}
  177
+
  178
+# Preloaded methods go here.
  179
+
  180
+1;
  181
+__END__
  182
+
  183
+=head1 NAME
  184
+
  185
+CJDNS - Perl interface to the CJDNS Administration Interface
  186
+
  187
+=head1 SYNOPSIS
  188
+
  189
+  use CJDNS;
  190
+  blah blah blah
  191
+
  192
+=head1 DESCRIPTION
  193
+
  194
+Perl interface to the CJDNS Administration system
  195
+
  196
+=head1 SEE ALSO
  197
+
  198
+https://github.com/cjdelisle/cjdns
  199
+
  200
+=head1 AUTHOR
  201
+
  202
+Michael Gregorowicz, E<lt>mikei@mg2.orgE<gt>
  203
+
  204
+=head1 COPYRIGHT AND LICENSE
  205
+
  206
+Copyright (C) 2012 by Michael Gregorowicz
  207
+
  208
+This library is free software; you can redistribute it and/or modify
  209
+it under the same terms as Perl itself, either Perl version 5.14.2 or,
  210
+at your option, any later version of Perl 5 you may have available.
  211
+
  212
+=cut
18  contrib/perl/CJDNS/t/CJDNS.t
... ...
@@ -0,0 +1,18 @@
  1
+# Before `make install' is performed this script should be runnable with
  2
+# `make test'. After `make install' it should work as `perl CJDNS.t'
  3
+
  4
+#########################
  5
+
  6
+# change 'tests => 1' to 'tests => last_test_to_print';
  7
+
  8
+use strict;
  9
+use warnings;
  10
+
  11
+use Test::More tests => 1;
  12
+BEGIN { use_ok('CJDNS') };
  13
+
  14
+#########################
  15
+
  16
+# Insert your test code below, the Test::More module is use()ed here so read
  17
+# its man page ( perldoc Test::More ) for help writing this test script.
  18
+

0 notes on commit 36f792f

Please sign in to comment.
Something went wrong with that request. Please try again.