ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/cvsroot/Net-FCP/FCP.pm
(Generate patch)

Comparing cvsroot/Net-FCP/FCP.pm (file contents):
Revision 1.11 by root, Tue Sep 9 18:52:39 2003 UTC vs.
Revision 1.29 by root, Thu May 13 21:43:16 2004 UTC

… …
35The import tag to use is named C<event=xyz>, e.g. C<event=Event>, 35The import tag to use is named C<event=xyz>, e.g. C<event=Event>,
36C<event=Glib> etc. 36C<event=Glib> etc.
37 37
38You should specify the event module to use only in the main program. 38You should specify the event module to use only in the main program.
39 39
40If no event model has been specified, FCP tries to autodetect it on first
41use (e.g. first transaction), in this order: Coro, Event, Glib, Tk.
42
43=head2 FREENET BASICS
44
45Ok, this section will not explain any freenet basics to you, just some
46problems I found that you might want to avoid:
47
48=over 4
49
50=item freenet URIs are _NOT_ URIs
51
52Whenever a "uri" is required by the protocol, freenet expects a kind of
53URI prefixed with the "freenet:" scheme, e.g. "freenet:CHK...". However,
54these are not URIs, as freeent fails to parse them correctly, that is, you
55must unescape an escaped characters ("%2c" => ",") yourself. Maybe in the
56future this library will do it for you, so watch out for this incompatible
57change.
58
59=item Numbers are in HEX
60
61Virtually every number in the FCP protocol is in hex. Be sure to use
62C<hex()> on all such numbers, as the module (currently) does nothing to
63convert these for you.
64
65=back
66
40=head2 THE Net::FCP CLASS 67=head2 THE Net::FCP CLASS
41 68
42=over 4 69=over 4
43 70
44=cut 71=cut
45 72
46package Net::FCP; 73package Net::FCP;
47 74
48use Carp; 75use Carp;
49use IO::Socket::INET;
50 76
51$VERSION = 0.05; 77$VERSION = 0.6;
52 78
53no warnings; 79no warnings;
54 80
55our $EVENT = Net::FCP::Event::Auto::; 81our $EVENT = Net::FCP::Event::Auto::;
56$EVENT = Net::FCP::Event::Event;#d#
57 82
58sub import { 83sub import {
59 shift; 84 shift;
60 85
61 for (@_) { 86 for (@_) {
62 if (/^event=(\w+)$/) { 87 if (/^event=(\w+)$/) {
63 $EVENT = "Net::FCP::Event::$1"; 88 $EVENT = "Net::FCP::Event::$1";
89 eval "require $EVENT";
64 } 90 }
65 } 91 }
66 eval "require $EVENT"; 92 die $@ if $@;
67} 93}
68 94
69sub touc($) { 95sub touc($) {
70 local $_ = shift; 96 local $_ = shift;
71 1 while s/((?:^|_)(?:svk|chk|uri)(?:_|$))/\U$1/; 97 1 while s/((?:^|_)(?:svk|chk|uri)(?:_|$))/\U$1/;
… …
73 $_; 99 $_;
74} 100}
75 101
76sub tolc($) { 102sub tolc($) {
77 local $_ = shift; 103 local $_ = shift;
104 1 while s/(SVK|CHK|URI)([^_])/$1\_$2/i;
105 1 while s/([^_])(SVK|CHK|URI)/$1\_$2/i;
78 s/(?<=[a-z])(?=[A-Z])/_/g; 106 s/(?<=[a-z])(?=[A-Z])/_/g;
79 lc $_; 107 lc $_;
80} 108}
81 109
110# the opposite of hex
111sub xeh($) {
112 sprintf "%x", $_[0];
113}
114
82=item $meta = Net::FCP::parse_metadata $string 115=item $meta = Net::FCP::parse_metadata $string
83 116
84Parse a metadata string and return it. 117Parse a metadata string and return it.
85 118
86The metadata will be a hashref with key C<version> (containing 119The metadata will be a hashref with key C<version> (containing the
87the mandatory version header entries). 120mandatory version header entries) and key C<raw> containing the original
121metadata string.
88 122
89All other headers are represented by arrayrefs (they can be repeated). 123All other headers are represented by arrayrefs (they can be repeated).
90 124
91Since this is confusing, here is a rather verbose example of a parsed 125Since this description is confusing, here is a rather verbose example of a
92manifest: 126parsed manifest:
93 127
94 ( 128 (
129 raw => "Version...",
95 version => { revision => 1 }, 130 version => { revision => 1 },
96 document => [ 131 document => [
97 { 132 {
98 "info.format" => "image/jpeg", 133 info => { format" => "image/jpeg" },
99 name => "background.jpg", 134 name => "background.jpg",
100 "redirect.target" => "freenet:CHK\@ZcagI,ra726bSw" 135 redirect => { target => "freenet:CHK\@ZcagI,ra726bSw" },
101 }, 136 },
102 { 137 {
103 "info.format" => "text/html", 138 info => { format" => "text/html" },
104 name => ".next", 139 name => ".next",
105 "redirect.target" => "freenet:SSK\@ilUPAgM/TFEE/3" 140 redirect => { target => "freenet:SSK\@ilUPAgM/TFEE/3" },
106 }, 141 },
107 { 142 {
108 "info.format" => "text/html", 143 info => { format" => "text/html" },
109 "redirect.target" => "freenet:CHK\@8M8Po8ucwI,8xA" 144 redirect => { target => "freenet:CHK\@8M8Po8ucwI,8xA" },
110 } 145 }
111 ] 146 ]
112 ) 147 )
113 148
114=cut 149=cut
115 150
116sub parse_metadata { 151sub parse_metadata {
117 my $meta;
118
119 my $data = shift; 152 my $data = shift;
153 my $meta = { raw => $data };
154
120 if ($data =~ /^Version\015?\012/gc) { 155 if ($data =~ /^Version\015?\012/gc) {
121 my $hdr = $meta->{version} = {}; 156 my $hdr = $meta->{version} = {};
122 157
123 for (;;) { 158 for (;;) {
124 while ($data =~ /\G([^=\015\012]+)=([^\015\012]*)\015?\012/gc) { 159 while ($data =~ /\G([^=\015\012]+)=([^\015\012]*)\015?\012/gc) {
125 my ($k, $v) = ($1, $2); 160 my ($k, $v) = ($1, $2);
126 $hdr->{tolc $k} = $v; 161 my @p = split /\./, tolc $k, 3;
162
163 $hdr->{$p[0]} = $v if @p == 1; # lamest code I ever wrote
164 $hdr->{$p[0]}{$p[1]} = $v if @p == 2;
165 $hdr->{$p[0]}{$p[1]}{$p[2]} = $v if @p == 3;
166 die "FATAL: 4+ dot metadata" if @p >= 4;
127 } 167 }
128 168
129 if ($data =~ /\GEndPart\015?\012/gc) { 169 if ($data =~ /\GEndPart\015?\012/gc) {
170 # nop
130 } elsif ($data =~ /\GEnd\015?\012/gc) { 171 } elsif ($data =~ /\GEnd(\015?\012|$)/gc) {
131 last; 172 last;
132 } elsif ($data =~ /\G([A-Za-z0-9.\-]+)\015?\012/gcs) { 173 } elsif ($data =~ /\G([A-Za-z0-9.\-]+)\015?\012/gcs) {
133 push @{$meta->{tolc $1}}, $hdr = {}; 174 push @{$meta->{tolc $1}}, $hdr = {};
134 } elsif ($data =~ /\G(.*)/gcs) { 175 } elsif ($data =~ /\G(.*)/gcs) {
176 print STDERR "metadata format error ($1), please report this string: <<$data>>";
135 die "metadata format error ($1)"; 177 die "metadata format error";
136 } 178 }
137 } 179 }
138 } 180 }
139 181
140 #$meta->{tail} = substr $data, pos $data; 182 #$meta->{tail} = substr $data, pos $data;
141 183
142 $meta; 184 $meta;
143} 185}
144 186
187=item $string = Net::FCP::build_metadata $meta
188
189Takes a hash reference as returned by C<Net::FCP::parse_metadata> and
190returns the corresponding string form. If a string is given, it's returned
191as is.
192
193=cut
194
195sub build_metadata_subhash($$$) {
196 my ($prefix, $level, $hash) = @_;
197
198 join "",
199 map
200 ref $hash->{$_} ? build_metadata_subhash ($prefix . (Net::FCP::touc $_) . ".", $level + 1, $hash->{$_})
201 : $prefix . ($level > 1 ? $_ : Net::FCP::touc $_) . "=" . $hash->{$_} . "\n",
202 keys %$hash;
203}
204
205sub build_metadata_hash($$) {
206 my ($header, $hash) = @_;
207
208 if (ref $hash eq ARRAY::) {
209 join "", map build_metadata_hash ($header, $_), @$hash
210 } else {
211 (Net::FCP::touc $header) . "\n"
212 . (build_metadata_subhash "", 0, $hash)
213 . "EndPart\n";
214 }
215}
216
217sub build_metadata($) {
218 my ($meta) = @_;
219
220 return $meta unless ref $meta;
221
222 $meta = { %$meta };
223
224 delete $meta->{raw};
225
226 my $res =
227 (build_metadata_hash version => delete $meta->{version})
228 . (join "", map +(build_metadata_hash $_, $meta->{$_}), keys %$meta);
229
230 substr $res, 0, -5; # get rid of "Part". Broken Syntax....
231}
232
233
145=item $fcp = new Net::FCP [host => $host][, port => $port] 234=item $fcp = new Net::FCP [host => $host][, port => $port][, progress => \&cb]
146 235
147Create a new virtual FCP connection to the given host and port (default 236Create a new virtual FCP connection to the given host and port (default
148127.0.0.1:8481, or the environment variables C<FREDHOST> and C<FREDPORT>). 237127.0.0.1:8481, or the environment variables C<FREDHOST> and C<FREDPORT>).
149 238
150Connections are virtual because no persistent physical connection is 239Connections are virtual because no persistent physical connection is
240established.
241
242You can install a progress callback that is being called with the Net::FCP
243object, a txn object, the type of the transaction and the attributes. Use
244it like this:
245
246 sub progress_cb {
247 my ($self, $txn, $type, $attr) = @_;
248
249 warn "progress<$txn,$type," . (join ":", %$attr) . ">\n";
250 }
251
252=begin comment
253
151established. However, the existance of the node is checked by executing a 254However, the existance of the node is checked by executing a
152C<ClientHello> transaction. 255C<ClientHello> transaction.
256
257=end
153 258
154=cut 259=cut
155 260
156sub new { 261sub new {
157 my $class = shift; 262 my $class = shift;
158 my $self = bless { @_ }, $class; 263 my $self = bless { @_ }, $class;
159 264
160 $self->{host} ||= $ENV{FREDHOST} || "127.0.0.1"; 265 $self->{host} ||= $ENV{FREDHOST} || "127.0.0.1";
161 $self->{port} ||= $ENV{FREDPORt} || 8481; 266 $self->{port} ||= $ENV{FREDPORT} || 8481;
162 267
163 $self->{nodehello} = $self->client_hello 268 #$self->{nodehello} = $self->client_hello
164 or croak "unable to get nodehello from node\n"; 269 # or croak "unable to get nodehello from node\n";
165 270
166 $self; 271 $self;
167} 272}
168 273
169sub progress { 274sub progress {
170 my ($self, $txn, $type, $attr) = @_; 275 my ($self, $txn, $type, $attr) = @_;
171 warn "progress<$txn,$type," . (join ":", %$attr) . ">\n"; 276
277 $self->{progress}->($self, $txn, $type, $attr)
278 if $self->{progress};
172} 279}
173 280
174=item $txn = $fcp->txn(type => attr => val,...) 281=item $txn = $fcp->txn(type => attr => val,...)
175 282
176The low-level interface to transactions. Don't use it. 283The low-level interface to transactions. Don't use it.
284
285Here are some examples of using transactions:
286
287The blocking case, no (visible) transactions involved:
288
289 my $nodehello = $fcp->client_hello;
290
291A transaction used in a blocking fashion:
292
293 my $txn = $fcp->txn_client_hello;
294 ...
295 my $nodehello = $txn->result;
296
297Or shorter:
298
299 my $nodehello = $fcp->txn_client_hello->result;
300
301Setting callbacks:
302
303 $fcp->txn_client_hello->cb(
304 sub { my $nodehello => $_[0]->result }
305 );
177 306
178=cut 307=cut
179 308
180sub txn { 309sub txn {
181 my ($self, $type, %attr) = @_; 310 my ($self, $type, %attr) = @_;
182 311
183 $type = touc $type; 312 $type = touc $type;
184 313
185 my $txn = "Net::FCP::Txn::$type"->new(fcp => $self, type => tolc $type, attr => \%attr); 314 my $txn = "Net::FCP::Txn::$type"->new (fcp => $self, type => tolc $type, attr => \%attr);
186 315
187 $txn; 316 $txn;
188} 317}
189 318
190sub _txn($&) { 319{ # transactions
320
321my $txn = sub {
191 my ($name, $sub) = @_; 322 my ($name, $sub) = @_;
192 *{"$name\_txn"} = $sub; 323 *{"txn_$name"} = $sub;
193 *{$name} = sub { $sub->(@_)->result }; 324 *{$name} = sub { $sub->(@_)->result };
194} 325};
195 326
196=item $txn = $fcp->txn_client_hello 327=item $txn = $fcp->txn_client_hello
197 328
198=item $nodehello = $fcp->client_hello 329=item $nodehello = $fcp->client_hello
199 330
… …
205 protocol => "1.2", 336 protocol => "1.2",
206 } 337 }
207 338
208=cut 339=cut
209 340
210_txn client_hello => sub { 341$txn->(client_hello => sub {
211 my ($self) = @_; 342 my ($self) = @_;
212 343
213 $self->txn ("client_hello"); 344 $self->txn ("client_hello");
214}; 345});
215 346
216=item $txn = $fcp->txn_client_info 347=item $txn = $fcp->txn_client_info
217 348
218=item $nodeinfo = $fcp->client_info 349=item $nodeinfo = $fcp->client_info
219 350
… …
243 routing_time => "a5", 374 routing_time => "a5",
244 } 375 }
245 376
246=cut 377=cut
247 378
248_txn client_info => sub { 379$txn->(client_info => sub {
249 my ($self) = @_; 380 my ($self) = @_;
250 381
251 $self->txn ("client_info"); 382 $self->txn ("client_info");
252}; 383});
253 384
254=item $txn = $fcp->txn_generate_chk ($metadata, $data) 385=item $txn = $fcp->txn_generate_chk ($metadata, $data[, $cipher])
255 386
256=item $uri = $fcp->generate_chk ($metadata, $data) 387=item $uri = $fcp->generate_chk ($metadata, $data[, $cipher])
257 388
258Creates a new CHK, given the metadata and data. UNTESTED. 389Calculates a CHK, given the metadata and data. C<$cipher> is either
390C<Rijndael> or C<Twofish>, with the latter being the default.
259 391
260=cut 392=cut
261 393
262_txn generate_chk => sub { 394$txn->(generate_chk => sub {
263 my ($self, $metadata, $data) = @_; 395 my ($self, $metadata, $data, $cipher) = @_;
264 396
265 $self->txn (generate_chk => data => "$data$metadata", metadata_length => length $metadata); 397 $self->txn (generate_chk =>
398 data => "$metadata$data",
399 metadata_length => xeh length $metadata,
400 cipher => $cipher || "Twofish");
266}; 401});
267 402
268=item $txn = $fcp->txn_generate_svk_pair 403=item $txn = $fcp->txn_generate_svk_pair
269 404
270=item ($public, $private) = @{ $fcp->generate_svk_pair } 405=item ($public, $private) = @{ $fcp->generate_svk_pair }
271 406
272Creates a new SVK pair. Returns an arrayref. 407Creates a new SVK pair. Returns an arrayref with the public key, the
408private key and a crypto key, which is just additional entropy.
273 409
274 [ 410 [
275 "hKs0-WDQA4pVZyMPKNFsK1zapWY", 411 "acLx4dux9fvvABH15Gk6~d3I-yw",
276 "ZnmvMITaTXBMFGl4~jrjuyWxOWg" 412 "cPoDkDMXDGSMM32plaPZDhJDxSs",
413 "BH7LXCov0w51-y9i~BoB3g",
277 ] 414 ]
278 415
279=cut 416A private key (for inserting) can be constructed like this:
280 417
418 SSK@<private_key>,<crypto_key>/<name>
419
420It can be used to insert data. The corresponding public key looks like this:
421
422 SSK@<public_key>PAgM,<crypto_key>/<name>
423
424Watch out for the C<PAgM>-part!
425
426=cut
427
281_txn generate_svk_pair => sub { 428$txn->(generate_svk_pair => sub {
282 my ($self) = @_; 429 my ($self) = @_;
283 430
284 $self->txn ("generate_svk_pair"); 431 $self->txn ("generate_svk_pair");
285}; 432});
286 433
287=item $txn = $fcp->txn_insert_private_key ($private) 434=item $txn = $fcp->txn_invert_private_key ($private)
288 435
289=item $uri = $fcp->insert_private_key ($private) 436=item $public = $fcp->invert_private_key ($private)
290 437
291Inserts a private key. $private can be either an insert URI (must start 438Inverts a private key (returns the public key). C<$private> can be either
292with freenet:SSK@) or a raw private key (i.e. the private value you get back 439an insert URI (must start with C<freenet:SSK@>) or a raw private key (i.e.
293from C<generate_svk_pair>). 440the private value you get back from C<generate_svk_pair>).
294 441
295Returns the public key. 442Returns the public key.
296 443
297UNTESTED.
298
299=cut 444=cut
300 445
301_txn insert_private_key => sub { 446$txn->(invert_private_key => sub {
302 my ($self, $privkey) = @_; 447 my ($self, $privkey) = @_;
303 448
304 $self->txn (invert_private_key => private => $privkey); 449 $self->txn (invert_private_key => private => $privkey);
305}; 450});
306 451
307=item $txn = $fcp->txn_get_size ($uri) 452=item $txn = $fcp->txn_get_size ($uri)
308 453
309=item $length = $fcp->get_size ($uri) 454=item $length = $fcp->get_size ($uri)
310 455
311Finds and returns the size (rounded up to the nearest power of two) of the 456Finds and returns the size (rounded up to the nearest power of two) of the
312given document. 457given document.
313 458
314UNTESTED.
315
316=cut 459=cut
317 460
318_txn get_size => sub { 461$txn->(get_size => sub {
319 my ($self, $uri) = @_; 462 my ($self, $uri) = @_;
320 463
321 $self->txn (get_size => URI => $uri); 464 $self->txn (get_size => URI => $uri);
322}; 465});
323 466
324=item $txn = $fcp->txn_client_get ($uri [, $htl = 15 [, $removelocal = 0]]) 467=item $txn = $fcp->txn_client_get ($uri [, $htl = 15 [, $removelocal = 0]])
325 468
326=item ($metadata, $data) = @{ $fcp->client_get ($uri, $htl, $removelocal) 469=item ($metadata, $data) = @{ $fcp->client_get ($uri, $htl, $removelocal)
327 470
328Fetches a (small, as it should fit into memory) file from 471Fetches a (small, as it should fit into memory) file from
329freenet. C<$meta> is the metadata (as returned by C<parse_metadata> or 472freenet. C<$meta> is the metadata (as returned by C<parse_metadata> or
330C<undef>). 473C<undef>).
474
475The C<$uri> should begin with C<freenet:>, but the scheme is currently
476added, if missing.
331 477
332Due to the overhead, a better method to download big files should be used. 478Due to the overhead, a better method to download big files should be used.
333 479
334 my ($meta, $data) = @{ 480 my ($meta, $data) = @{
335 $fcp->client_get ( 481 $fcp->client_get (
… …
337 ) 483 )
338 }; 484 };
339 485
340=cut 486=cut
341 487
342_txn client_get => sub { 488$txn->(client_get => sub {
343 my ($self, $uri, $htl, $removelocal) = @_; 489 my ($self, $uri, $htl, $removelocal) = @_;
344 490
345 $self->txn (client_get => URI => $uri, hops_to_live => ($htl || 15), remove_local => $removelocal*1); 491 $uri =~ s/^freenet://;
492 $uri = "freenet:$uri";
493
494 $self->txn (client_get => URI => $uri, hops_to_live => xeh (defined $htl ? $htl : 15),
495 remove_local_key => $removelocal ? "true" : "false");
346}; 496});
347 497
348=item MISSING: ClientPut 498=item $txn = $fcp->txn_client_put ($uri, $metadata, $data, $htl, $removelocal)
499
500=item my $uri = $fcp->client_put ($uri, $metadata, $data, $htl, $removelocal);
501
502Insert a new key. If the client is inserting a CHK, the URI may be
503abbreviated as just CHK@. In this case, the node will calculate the
504CHK. If the key is a private SSK key, the node will calculcate the public
505key and the resulting public URI.
506
507C<$meta> can be a hash reference (same format as returned by
508C<Net::FCP::parse_metadata>) or a string.
509
510The result is an arrayref with the keys C<uri>, C<public_key> and C<private_key>.
511
512=cut
513
514$txn->(client_put => sub {
515 my ($self, $uri, $meta, $data, $htl, $removelocal) = @_;
516
517 $meta = build_metadata $meta;
518
519 $self->txn (client_put => URI => $uri,
520 hops_to_live => xeh (defined $htl ? $htl : 15),
521 remove_local_key => $removelocal ? "true" : "false",
522 data => "$meta$data", metadata_length => xeh length $meta);
523});
524
525} # transactions
349 526
350=back 527=back
351 528
352=head2 THE Net::FCP::Txn CLASS 529=head2 THE Net::FCP::Txn CLASS
353 530
354All requests (or transactions) are executed in a asynchroneous way (LIE: 531All requests (or transactions) are executed in a asynchronous way. For
355uploads are blocking). For each request, a C<Net::FCP::Txn> object is 532each request, a C<Net::FCP::Txn> object is created (worse: a tcp
356created (worse: a tcp connection is created, too). 533connection is created, too).
357 534
358For each request there is actually a different subclass (and it's possible 535For each request there is actually a different subclass (and it's possible
359to subclass these, although of course not documented). 536to subclass these, although of course not documented).
360 537
361The most interesting method is C<result>. 538The most interesting method is C<result>.
… …
363=over 4 540=over 4
364 541
365=cut 542=cut
366 543
367package Net::FCP::Txn; 544package Net::FCP::Txn;
545
546use Fcntl;
547use Socket;
368 548
369=item new arg => val,... 549=item new arg => val,...
370 550
371Creates a new C<Net::FCP::Txn> object. Not normally used. 551Creates a new C<Net::FCP::Txn> object. Not normally used.
372 552
… …
374 554
375sub new { 555sub new {
376 my $class = shift; 556 my $class = shift;
377 my $self = bless { @_ }, $class; 557 my $self = bless { @_ }, $class;
378 558
559 $self->{signal} = $EVENT->new_signal;
560
561 $self->{fcp}{txn}{$self} = $self;
562
379 my $attr = ""; 563 my $attr = "";
380 my $data = delete $self->{attr}{data}; 564 my $data = delete $self->{attr}{data};
381 565
382 while (my ($k, $v) = each %{$self->{attr}}) { 566 while (my ($k, $v) = each %{$self->{attr}}) {
383 $attr .= (Net::FCP::touc $k) . "=$v\012" 567 $attr .= (Net::FCP::touc $k) . "=$v\012"
384 } 568 }
385 569
386 if (defined $data) { 570 if (defined $data) {
387 $attr .= "DataLength=" . (length $data) . "\012"; 571 $attr .= sprintf "DataLength=%x\012", length $data;
388 $data = "Data\012$data"; 572 $data = "Data\012$data";
389 } else { 573 } else {
390 $data = "EndMessage\012"; 574 $data = "EndMessage\012";
391 } 575 }
392 576
393 my $fh = new IO::Socket::INET 577 socket my $fh, PF_INET, SOCK_STREAM, 0
394 PeerHost => $self->{fcp}{host}, 578 or Carp::croak "unable to create new tcp socket: $!";
395 PeerPort => $self->{fcp}{port}
396 or Carp::croak "FCP::txn: unable to connect to $self->{fcp}{host}:$self->{fcp}{port}: $!\n";
397
398 binmode $fh, ":raw"; 579 binmode $fh, ":raw";
580 fcntl $fh, F_SETFL, O_NONBLOCK;
581 connect $fh, (sockaddr_in $self->{fcp}{port}, inet_aton $self->{fcp}{host})
582 and !$!{EWOULDBLOCK}
583 and !$!{EINPROGRESS}
584 and Carp::croak "FCP::txn: unable to connect to $self->{fcp}{host}:$self->{fcp}{port}: $!\n";
399 585
400 if (0) { 586 $self->{sbuf} =
401 print 587 "\x00\x00\x00\x02"
402 Net::FCP::touc $self->{type}, "\012",
403 $attr,
404 $data, "\012";
405 }
406
407 print $fh
408 "\x00\x00", "\x00\x02", # SESSID, PRESID
409 Net::FCP::touc $self->{type}, "\012", 588 . (Net::FCP::touc $self->{type})
410 $attr, 589 . "\012$attr$data";
411 $data;
412 590
413 #$fh->shutdown (1); # freenet buggy?, well, it's java... 591 #shutdown $fh, 1; # freenet buggy?, well, it's java...
414 592
415 $self->{fh} = $fh; 593 $self->{fh} = $fh;
416 594
417 $EVENT->reg_r_cb ($self); 595 $self->{w} = $EVENT->new_from_fh ($fh)->cb(sub { $self->fh_ready_w })->poll(0, 1, 1);
418 596
419 $self; 597 $self;
420} 598}
421 599
600=item $txn = $txn->cb ($coderef)
601
602Sets a callback to be called when the request is finished. The coderef
603will be called with the txn as it's sole argument, so it has to call
604C<result> itself.
605
606Returns the txn object, useful for chaining.
607
608Example:
609
610 $fcp->txn_client_get ("freenet:CHK....")
611 ->userdata ("ehrm")
612 ->cb(sub {
613 my $data = shift->result;
614 });
615
616=cut
617
618sub cb($$) {
619 my ($self, $cb) = @_;
620 $self->{cb} = $cb;
621 $self;
622}
623
422=item $userdata = $txn->userdata ([$userdata]) 624=item $txn = $txn->userdata ([$userdata])
423 625
424Get and/or set user-specific data. This is useful in progress callbacks. 626Set user-specific data. This is useful in progress callbacks. The data can be accessed
627using C<< $txn->{userdata} >>.
425 628
426=cut 629Returns the txn object, useful for chaining.
427 630
631=cut
632
428sub userdata($;$) { 633sub userdata($$) {
429 my ($self, $data) = @_; 634 my ($self, $data) = @_;
430 $self->{userdata} = $data if @_ >= 2; 635 $self->{userdata} = $data;
431 $self->{userdata}; 636 $self;
432} 637}
433 638
639=item $txn->cancel (%attr)
640
641Cancels the operation with a C<cancel> exception anf the given attributes
642(consider at least giving the attribute C<reason>).
643
644UNTESTED.
645
646=cut
647
648sub cancel {
649 my ($self, %attr) = @_;
650 $self->throw (Net::FCP::Exception->new (cancel => { %attr }));
651 $self->set_result;
652 $self->eof;
653}
654
434sub fh_ready { 655sub fh_ready_w {
656 my ($self) = @_;
657
658 my $len = syswrite $self->{fh}, $self->{sbuf};
659
660 if ($len > 0) {
661 substr $self->{sbuf}, 0, $len, "";
662 unless (length $self->{sbuf}) {
663 fcntl $self->{fh}, F_SETFL, 0;
664 $self->{w}->cb(sub { $self->fh_ready_r })->poll (1, 0, 1);
665 }
666 } elsif (defined $len) {
667 $self->throw (Net::FCP::Exception->new (network_error => { reason => "unexpected end of file while writing" }));
668 } else {
669 $self->throw (Net::FCP::Exception->new (network_error => { reason => "$!" }));
670 }
671}
672
673sub fh_ready_r {
435 my ($self) = @_; 674 my ($self) = @_;
436 675
437 if (sysread $self->{fh}, $self->{buf}, 65536, length $self->{buf}) { 676 if (sysread $self->{fh}, $self->{buf}, 65536, length $self->{buf}) {
438 for (;;) { 677 for (;;) {
439 if ($self->{datalen}) { 678 if ($self->{datalen}) {
679 #warn "expecting new datachunk $self->{datalen}, got ".(length $self->{buf})."\n";#d#
440 if (length $self->{buf} >= $self->{datalen}) { 680 if (length $self->{buf} >= $self->{datalen}) {
441 $self->rcv_data (substr $self->{buf}, 0, delete $self->{datalen}, ""); 681 $self->rcv_data (substr $self->{buf}, 0, delete $self->{datalen}, "");
442 } else { 682 } else {
443 last; 683 last;
444 } 684 }
445 } elsif ($self->{buf} =~ s/^DataChunk\015?\012Length=([0-9a-fA-F]+)\015?\012Data\015?\012//) { 685 } elsif ($self->{buf} =~ s/^DataChunk\015?\012Length=([0-9a-fA-F]+)\015?\012Data\015?\012//) {
446 $self->{datalen} = hex $1; 686 $self->{datalen} = hex $1;
687 #warn "expecting new datachunk $self->{datalen}\n";#d#
447 } elsif ($self->{buf} =~ s/^([a-zA-Z]+)\015?\012(?:(.+?)\015?\012)?EndMessage\015?\012//s) { 688 } elsif ($self->{buf} =~ s/^([a-zA-Z]+)\015?\012(?:(.+?)\015?\012)?EndMessage\015?\012//s) {
448 $self->rcv ($1, { 689 $self->rcv ($1, {
449 map { my ($a, $b) = split /=/, $_, 2; ((Net::FCP::tolc $a), $b) } 690 map { my ($a, $b) = split /=/, $_, 2; ((Net::FCP::tolc $a), $b) }
450 split /\015?\012/, $2 691 split /\015?\012/, $2
451 }); 692 });
452 } else { 693 } else {
453 last; 694 last;
454 } 695 }
455 } 696 }
456 } else { 697 } else {
457 $EVENT->unreg_r_cb ($self);
458 delete $self->{fh};
459 $self->eof; 698 $self->eof;
460 } 699 }
461}
462
463sub rcv_data {
464 my ($self, $chunk) = @_;
465
466 $self->{data} .= $chunk;
467
468 $self->progress ("data", { chunk => length $chunk, total => length $self->{data}, end => $self->{datalength} });
469} 700}
470 701
471sub rcv { 702sub rcv {
472 my ($self, $type, $attr) = @_; 703 my ($self, $type, $attr) = @_;
473 704
… …
480 } else { 711 } else {
481 warn "received unexpected reply type '$type' for '$self->{type}', ignoring\n"; 712 warn "received unexpected reply type '$type' for '$self->{type}', ignoring\n";
482 } 713 }
483} 714}
484 715
716# used as a default exception thrower
717sub rcv_throw_exception {
718 my ($self, $attr, $type) = @_;
719 $self->throw (Net::FCP::Exception->new ($type, $attr));
720}
721
722*rcv_failed = \&Net::FCP::Txn::rcv_throw_exception;
723*rcv_format_error = \&Net::FCP::Txn::rcv_throw_exception;
724
485sub throw { 725sub throw {
486 my ($self, $exc) = @_; 726 my ($self, $exc) = @_;
487 727
488 $self->{exception} = $exc; 728 $self->{exception} = $exc;
489 $self->set_result (1); 729 $self->set_result;
730 $self->eof; # must be last to avoid loops
490} 731}
491 732
492sub set_result { 733sub set_result {
493 my ($self, $result) = @_; 734 my ($self, $result) = @_;
494 735
495 $self->{result} = $result unless exists $self->{result}; 736 unless (exists $self->{result}) {
737 $self->{result} = $result;
738 $self->{cb}->($self) if exists $self->{cb};
739 $self->{signal}->send;
740 }
496} 741}
497 742
498sub eof { 743sub eof {
499 my ($self) = @_; 744 my ($self) = @_;
500 $self->set_result; 745
746 delete $self->{w};
747 delete $self->{fh};
748
749 delete $self->{fcp}{txn}{$self};
750
751 unless (exists $self->{result}) {
752 $self->throw (Net::FCP::Exception->new (short_data => {
753 reason => "unexpected eof or internal node error",
754 }));
755 }
501} 756}
502 757
503sub progress { 758sub progress {
504 my ($self, $type, $attr) = @_; 759 my ($self, $type, $attr) = @_;
760
505 $self->{fcp}->progress ($self, $type, $attr); 761 $self->{fcp}->progress ($self, $type, $attr);
506} 762}
507 763
508=item $result = $txn->result 764=item $result = $txn->result
509 765
510Waits until a result is available and then returns it. 766Waits until a result is available and then returns it.
511 767
512This waiting is (depending on your event model) not very efficient, as it 768This waiting is (depending on your event model) not very efficient, as it
513is done outside the "mainloop". 769is done outside the "mainloop". The biggest problem, however, is that it's
770blocking one thread of execution. Try to use the callback mechanism, if
771possible, and call result from within the callback (or after is has been
772run), as then no waiting is necessary.
514 773
515=cut 774=cut
516 775
517sub result { 776sub result {
518 my ($self) = @_; 777 my ($self) = @_;
519 778
520 $EVENT->wait_event while !exists $self->{result}; 779 $self->{signal}->wait while !exists $self->{result};
521 780
522 die $self->{exception} if $self->{exception}; 781 die $self->{exception} if $self->{exception};
523 782
524 return $self->{result}; 783 return $self->{result};
525}
526
527sub DESTROY {
528 $EVENT->unreg_r_cb ($_[0]);
529 #$EVENT->unreg_w_cb ($_[0]);
530} 784}
531 785
532package Net::FCP::Txn::ClientHello; 786package Net::FCP::Txn::ClientHello;
533 787
534use base Net::FCP::Txn; 788use base Net::FCP::Txn;
… …
554use base Net::FCP::Txn; 808use base Net::FCP::Txn;
555 809
556sub rcv_success { 810sub rcv_success {
557 my ($self, $attr) = @_; 811 my ($self, $attr) = @_;
558 812
559 $self->set_result ($attr); 813 $self->set_result ($attr->{uri});
560} 814}
561 815
562package Net::FCP::Txn::GenerateSVKPair; 816package Net::FCP::Txn::GenerateSVKPair;
563 817
564use base Net::FCP::Txn; 818use base Net::FCP::Txn;
565 819
566sub rcv_success { 820sub rcv_success {
567 my ($self, $attr) = @_; 821 my ($self, $attr) = @_;
568
569 $self->set_result ([$attr->{PublicKey}, $attr->{PrivateKey}]); 822 $self->set_result ([$attr->{public_key}, $attr->{private_key}, $attr->{crypto_key}]);
570} 823}
571 824
572package Net::FCP::Txn::InvertPrivateKey; 825package Net::FCP::Txn::InvertPrivateKey;
573 826
574use base Net::FCP::Txn; 827use base Net::FCP::Txn;
575 828
576sub rcv_success { 829sub rcv_success {
577 my ($self, $attr) = @_; 830 my ($self, $attr) = @_;
578
579 $self->set_result ($attr->{PublicKey}); 831 $self->set_result ($attr->{public_key});
580} 832}
581 833
582package Net::FCP::Txn::GetSize; 834package Net::FCP::Txn::GetSize;
583 835
584use base Net::FCP::Txn; 836use base Net::FCP::Txn;
585 837
586sub rcv_success { 838sub rcv_success {
587 my ($self, $attr) = @_; 839 my ($self, $attr) = @_;
588
589 $self->set_result ($attr->{Length}); 840 $self->set_result (hex $attr->{length});
841}
842
843package Net::FCP::Txn::GetPut;
844
845# base class for get and put
846
847use base Net::FCP::Txn;
848
849*rcv_uri_error = \&Net::FCP::Txn::rcv_throw_exception;
850*rcv_route_not_found = \&Net::FCP::Txn::rcv_throw_exception;
851
852sub rcv_restarted {
853 my ($self, $attr, $type) = @_;
854
855 delete $self->{datalength};
856 delete $self->{metalength};
857 delete $self->{data};
858
859 $self->progress ($type, $attr);
590} 860}
591 861
592package Net::FCP::Txn::ClientGet; 862package Net::FCP::Txn::ClientGet;
593 863
594use base Net::FCP::Txn; 864use base Net::FCP::Txn::GetPut;
865
866*rcv_data_not_found = \&Net::FCP::Txn::rcv_throw_exception;
867
868sub rcv_data {
869 my ($self, $chunk) = @_;
870
871 $self->{data} .= $chunk;
872
873 $self->progress ("data", { chunk => length $chunk, received => length $self->{data}, total => $self->{datalength} });
874
875 if ($self->{datalength} == length $self->{data}) {
876 my $data = delete $self->{data};
877 my $meta = Net::FCP::parse_metadata substr $data, 0, $self->{metalength}, "";
878
879 $self->set_result ([$meta, $data]);
880 $self->eof;
881 }
882}
595 883
596sub rcv_data_found { 884sub rcv_data_found {
597 my ($self, $attr, $type) = @_; 885 my ($self, $attr, $type) = @_;
598 886
599 $self->progress ($type, $attr); 887 $self->progress ($type, $attr);
600 888
601 $self->{datalength} = hex $attr->{data_length}; 889 $self->{datalength} = hex $attr->{data_length};
602 $self->{metalength} = hex $attr->{metadata_length}; 890 $self->{metalength} = hex $attr->{metadata_length};
603} 891}
604 892
605sub rcv_route_not_found { 893package Net::FCP::Txn::ClientPut;
606 my ($self, $attr, $type) = @_;
607 894
608 $self->throw (new Net::FCP::Exception $type, $attr); 895use base Net::FCP::Txn::GetPut;
609}
610 896
611sub rcv_data_not_found { 897*rcv_size_error = \&Net::FCP::Txn::rcv_throw_exception;
612 my ($self, $attr, $type) = @_; 898*rcv_key_collision = \&Net::FCP::Txn::rcv_throw_exception;
613 899
614 $self->throw (new Net::FCP::Exception $type, $attr); 900sub rcv_pending {
615}
616
617sub rcv_format_error {
618 my ($self, $attr, $type) = @_;
619
620 $self->throw (new Net::FCP::Exception $type, $attr);
621}
622
623sub rcv_restarted {
624 my ($self, $attr, $type) = @_; 901 my ($self, $attr, $type) = @_;
625 $self->progress ($type, $attr); 902 $self->progress ($type, $attr);
626} 903}
627 904
628sub eof { 905sub rcv_success {
629 my ($self) = @_; 906 my ($self, $attr, $type) = @_;
630
631 my $data = delete $self->{data};
632 my $meta = Net::FCP::parse_metadata substr $data, 0, $self->{metalength}, "";
633
634 $self->set_result ([$meta, $data]); 907 $self->set_result ($attr);
635} 908}
909
910=back
911
912=head2 The Net::FCP::Exception CLASS
913
914Any unexpected (non-standard) responses that make it impossible to return
915the advertised result will result in an exception being thrown when the
916C<result> method is called.
917
918These exceptions are represented by objects of this class.
919
920=over 4
921
922=cut
636 923
637package Net::FCP::Exception; 924package Net::FCP::Exception;
638 925
639use overload 926use overload
640 '""' => sub { 927 '""' => sub {
641 "Net::FCP::Exception<<$_[0][0]," . (join ":", %{$_[0][1]}) . ">>\n"; 928 "Net::FCP::Exception<<$_[0][0]," . (join ":", %{$_[0][1]}) . ">>";
642 }; 929 };
930
931=item $exc = new Net::FCP::Exception $type, \%attr
932
933Create a new exception object of the given type (a string like
934C<route_not_found>), and a hashref containing additional attributes
935(usually the attributes of the message causing the exception).
936
937=cut
643 938
644sub new { 939sub new {
645 my ($class, $type, $attr) = @_; 940 my ($class, $type, $attr) = @_;
646 941
647 bless [$type, { %$attr }], $class; 942 bless [Net::FCP::tolc $type, { %$attr }], $class;
943}
944
945=item $exc->type([$type])
946
947With no arguments, returns the exception type. Otherwise a boolean
948indicating wether the exception is of the given type is returned.
949
950=cut
951
952sub type {
953 my ($self, $type) = @_;
954
955 @_ >= 2
956 ? $self->[0] eq $type
957 : $self->[0];
958}
959
960=item $exc->attr([$attr])
961
962With no arguments, returns the attributes. Otherwise the named attribute
963value is returned.
964
965=cut
966
967sub attr {
968 my ($self, $attr) = @_;
969
970 @_ >= 2
971 ? $self->[1]{$attr}
972 : $self->[1];
648} 973}
649 974
650=back 975=back
651 976
652=head1 SEE ALSO 977=head1 SEE ALSO
… …
660 Marc Lehmann <pcg@goof.com> 985 Marc Lehmann <pcg@goof.com>
661 http://www.goof.com/pcg/marc/ 986 http://www.goof.com/pcg/marc/
662 987
663=cut 988=cut
664 989
990package Net::FCP::Event::Auto;
991
992my @models = (
993 [Coro => Coro::Event::],
994 [Event => Event::],
995 [Glib => Glib::],
996 [Tk => Tk::],
997);
998
999sub AUTOLOAD {
1000 $AUTOLOAD =~ s/.*://;
1001
1002 for (@models) {
1003 my ($model, $package) = @$_;
1004 if (defined ${"$package\::VERSION"}) {
1005 $EVENT = "Net::FCP::Event::$model";
1006 eval "require $EVENT"; die if $@;
1007 goto &{"$EVENT\::$AUTOLOAD"};
1008 }
1009 }
1010
1011 for (@models) {
1012 my ($model, $package) = @$_;
1013 $EVENT = "Net::FCP::Event::$model";
1014 if (eval "require $EVENT") {
1015 goto &{"$EVENT\::$AUTOLOAD"};
1016 }
1017 }
1018
1019 die "No event module selected for Net::FCP and autodetect failed. Install any of these: Coro, Event, Glib or Tk.";
1020}
1021
6651; 10221;
666 1023

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines