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

Comparing Net-FCP/FCP.pm (file contents):
Revision 1.2 by root, Sun Sep 7 23:20:20 2003 UTC vs.
Revision 1.26 by root, Wed Dec 10 02:36:37 2003 UTC

… …
17of what the messages do. I am too lazy to document all this here. 17of what the messages do. I am too lazy to document all this here.
18 18
19=head1 WARNING 19=head1 WARNING
20 20
21This module is alpha. While it probably won't destroy (much :) of your 21This module is alpha. While it probably won't destroy (much :) of your
22data, it currently works only with the Event module (alkthough the event 22data, it currently falls short of what it should provide (intelligent uri
23mechanism is fully pluggable). 23following, splitfile downloads, healing...)
24
25=head2 IMPORT TAGS
26
27Nothing much can be "imported" from this module right now. There are,
28however, certain "import tags" that can be used to select the event model
29to be used.
30
31Event models are implemented as modules under the C<Net::FCP::Event::xyz>
32class, where C<xyz> is the event model to use. The default is C<Event> (or
33later C<Auto>).
34
35The import tag to use is named C<event=xyz>, e.g. C<event=Event>,
36C<event=Glib> etc.
37
38You should specify the event module to use only in the main program.
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
24 66
25=head2 THE Net::FCP CLASS 67=head2 THE Net::FCP CLASS
26 68
27=over 4 69=over 4
28 70
29=cut 71=cut
30 72
31package Net::FCP; 73package Net::FCP;
32 74
33use Carp; 75use Carp;
34use IO::Socket::INET;
35 76
36$VERSION = 0.01; 77$VERSION = 0.6;
37 78
38sub event_reg_cb { 79no warnings;
39 my ($obj) = @_;
40 require Event;
41 80
42 $obj->{eventdata} = Event->io ( 81our $EVENT = Net::FCP::Event::Auto::;
43 fd => $obj->{fh}, 82
44 poll => 'r', 83sub import {
45 cb => sub { 84 shift;
46 $obj->fh_ready; 85
86 for (@_) {
87 if (/^event=(\w+)$/) {
88 $EVENT = "Net::FCP::Event::$1";
89 eval "require $EVENT";
47 }, 90 }
48 ); 91 }
92 die $@ if $@;
49} 93}
50
51sub event_unreg_cb {
52 $_[0]{eventdata}
53 and (delete $_[0]{eventdata})->cancel;
54}
55
56sub event_wait_cb {
57 Event::one_event();
58}
59
60$regcb = \&event_reg_cb;
61$unregcb = \&event_unreg_cb;
62$waitcb = \&event_wait_cb;
63 94
64sub touc($) { 95sub touc($) {
65 local $_ = shift; 96 local $_ = shift;
66 1 while s/((?:^|_)(?:svk|chk|uri)(?:_|$))/\U$1/; 97 1 while s/((?:^|_)(?:svk|chk|uri)(?:_|$))/\U$1/;
67 s/(?:^|_)(.)/\U$1/g; 98 s/(?:^|_)(.)/\U$1/g;
68 $_; 99 $_;
69} 100}
70 101
71sub tolc($) { 102sub tolc($) {
72 local $_ = shift; 103 local $_ = shift;
104 1 while s/(SVK|CHK|URI)/\L$1\_/;
73 s/(?<=[a-z])(?=[A-Z])/_/g; 105 s/(?<=[a-z])(?=[A-Z])/_/g;
74 lc $_; 106 lc $_;
75} 107}
76 108
109# the opposite of hex
110sub xeh($) {
111 sprintf "%x", $_[0];
112}
113
114=item $meta = Net::FCP::parse_metadata $string
115
116Parse a metadata string and return it.
117
118The metadata will be a hashref with key C<version> (containing the
119mandatory version header entries) and key C<raw> containing the original
120metadata string.
121
122All other headers are represented by arrayrefs (they can be repeated).
123
124Since this description is confusing, here is a rather verbose example of a
125parsed manifest:
126
127 (
128 raw => "Version...",
129 version => { revision => 1 },
130 document => [
131 {
132 info => { format" => "image/jpeg" },
133 name => "background.jpg",
134 redirect => { target => "freenet:CHK\@ZcagI,ra726bSw" },
135 },
136 {
137 info => { format" => "text/html" },
138 name => ".next",
139 redirect => { target => "freenet:SSK\@ilUPAgM/TFEE/3" },
140 },
141 {
142 info => { format" => "text/html" },
143 redirect => { target => "freenet:CHK\@8M8Po8ucwI,8xA" },
144 }
145 ]
146 )
147
148=cut
149
150sub parse_metadata {
151 my $data = shift;
152 my $meta = { raw => $data };
153
154 if ($data =~ /^Version\015?\012/gc) {
155 my $hdr = $meta->{version} = {};
156
157 for (;;) {
158 while ($data =~ /\G([^=\015\012]+)=([^\015\012]*)\015?\012/gc) {
159 my ($k, $v) = ($1, $2);
160 my @p = split /\./, tolc $k, 3;
161
162 $hdr->{$p[0]} = $v if @p == 1; # lamest code I ever wrote
163 $hdr->{$p[0]}{$p[1]} = $v if @p == 2;
164 $hdr->{$p[0]}{$p[1]}{$p[2]} = $v if @p == 3;
165 die "FATAL: 4+ dot metadata" if @p >= 4;
166 }
167
168 if ($data =~ /\GEndPart\015?\012/gc) {
169 # nop
170 } elsif ($data =~ /\GEnd(\015?\012|$)/gc) {
171 last;
172 } elsif ($data =~ /\G([A-Za-z0-9.\-]+)\015?\012/gcs) {
173 push @{$meta->{tolc $1}}, $hdr = {};
174 } elsif ($data =~ /\G(.*)/gcs) {
175 print STDERR "metadata format error ($1), please report this string: <<$data>>";
176 die "metadata format error";
177 }
178 }
179 }
180
181 #$meta->{tail} = substr $data, pos $data;
182
183 $meta;
184}
185
77=item $fcp = new Net::FCP [host => $host][, port => $port] 186=item $fcp = new Net::FCP [host => $host][, port => $port]
78 187
79Create a new virtual FCP connection to the given host and port (default 188Create a new virtual FCP connection to the given host and port (default
80127.0.0.1:8481). 189127.0.0.1:8481, or the environment variables C<FREDHOST> and C<FREDPORT>).
81 190
82Connections are virtual because no persistent physical connection is 191Connections are virtual because no persistent physical connection is
192established.
193
194=begin comment
195
83established. However, the existance of the node is checked by executing a 196However, the existance of the node is checked by executing a
84C<ClientHello> transaction. 197C<ClientHello> transaction.
198
199=end
85 200
86=cut 201=cut
87 202
88sub new { 203sub new {
89 my $class = shift; 204 my $class = shift;
90 my $self = bless { @_ }, $class; 205 my $self = bless { @_ }, $class;
91 206
92 $self->{host} ||= "127.0.0.1"; 207 $self->{host} ||= $ENV{FREDHOST} || "127.0.0.1";
93 $self->{port} ||= 8481; 208 $self->{port} ||= $ENV{FREDPORT} || 8481;
94 209
95 $self->{nodehello} = $self->txn("ClientHello")->result 210 #$self->{nodehello} = $self->client_hello
96 or croak "unable to get nodehello from node\n"; 211 # or croak "unable to get nodehello from node\n";
97 212
98 $self; 213 $self;
99} 214}
100 215
216sub progress {
217 my ($self, $txn, $type, $attr) = @_;
218 #warn "progress<$txn,$type," . (join ":", %$attr) . ">\n";
219}
220
101=item $txn = $fcp->txn(type => attr => val,...) 221=item $txn = $fcp->txn(type => attr => val,...)
102 222
103The low-level interface to transactions. Don't use it. 223The low-level interface to transactions. Don't use it.
224
225Here are some examples of using transactions:
226
227The blocking case, no (visible) transactions involved:
228
229 my $nodehello = $fcp->client_hello;
230
231A transaction used in a blocking fashion:
232
233 my $txn = $fcp->txn_client_hello;
234 ...
235 my $nodehello = $txn->result;
236
237Or shorter:
238
239 my $nodehello = $fcp->txn_client_hello->result;
240
241Setting callbacks:
242
243 $fcp->txn_client_hello->cb(
244 sub { my $nodehello => $_[0]->result }
245 );
104 246
105=cut 247=cut
106 248
107sub txn { 249sub txn {
108 my ($self, $type, %attr) = @_; 250 my ($self, $type, %attr) = @_;
… …
112 my $txn = "Net::FCP::Txn::$type"->new(fcp => $self, type => tolc $type, attr => \%attr); 254 my $txn = "Net::FCP::Txn::$type"->new(fcp => $self, type => tolc $type, attr => \%attr);
113 255
114 $txn; 256 $txn;
115} 257}
116 258
117sub _txn($&) { 259{ # transactions
260
261my $txn = sub {
118 my ($name, $sub) = @_; 262 my ($name, $sub) = @_;
119 *{"$name\_txn"} = $sub; 263 *{"txn_$name"} = $sub;
120 *{$name} = sub { $sub->(@_)->result }; 264 *{$name} = sub { $sub->(@_)->result };
121} 265};
122 266
123=item $txn = $fcp->txn_client_hello 267=item $txn = $fcp->txn_client_hello
124 268
125=item $nodehello = $fcp->client_hello 269=item $nodehello = $fcp->client_hello
126 270
127Executes a ClientHello request and returns it's results. 271Executes a ClientHello request and returns it's results.
128 272
129 { 273 {
130 max_file_size => "5f5e100", 274 max_file_size => "5f5e100",
275 node => "Fred,0.6,1.46,7050"
131 protocol => "1.2", 276 protocol => "1.2",
132 node => "Fred,0.6,1.46,7050"
133 } 277 }
134 278
135=cut 279=cut
136 280
137_txn client_hello => sub { 281$txn->(client_hello => sub {
138 my ($self) = @_; 282 my ($self) = @_;
139 283
140 $self->txn ("client_hello"); 284 $self->txn ("client_hello");
141}; 285});
142 286
143=item $txn = $fcp->txn_client_info 287=item $txn = $fcp->txn_client_info
144 288
145=item $nodeinfo = $fcp->client_info 289=item $nodeinfo = $fcp->client_info
146 290
147Executes a ClientInfo request and returns it's results. 291Executes a ClientInfo request and returns it's results.
148 292
149 { 293 {
150 max_file_size => "5f5e100",
151 datastore_max => "2540be400",
152 node_port => 369,
153 java_name => "Java HotSpot(_T_M) Server VM",
154 operating_system_version => "2.4.20",
155 estimated_load => 52,
156 free_memory => "5cc0148",
157 datastore_free => "5ce03400",
158 node_address => "1.2.3.4",
159 active_jobs => "1f", 294 active_jobs => "1f",
160 allocated_memory => "bde0000", 295 allocated_memory => "bde0000",
161 architecture => "i386", 296 architecture => "i386",
297 available_threads => 17,
298 datastore_free => "5ce03400",
299 datastore_max => "2540be400",
300 datastore_used => "1f72bb000",
301 estimated_load => 52,
302 free_memory => "5cc0148",
303 is_transient => "false",
304 java_name => "Java HotSpot(_T_M) Server VM",
305 java_vendor => "http://www.blackdown.org/",
306 java_version => "Blackdown-1.4.1-01",
307 least_recent_timestamp => "f41538b878",
308 max_file_size => "5f5e100",
309 most_recent_timestamp => "f77e2cc520"
310 node_address => "1.2.3.4",
311 node_port => 369,
312 operating_system => "Linux",
313 operating_system_version => "2.4.20",
162 routing_time => "a5", 314 routing_time => "a5",
163 least_recent_timestamp => "f41538b878",
164 available_threads => 17,
165 datastore_used => "1f72bb000",
166 java_version => "Blackdown-1.4.1-01",
167 is_transient => "false",
168 operating_system => "Linux",
169 java_vendor => "http://www.blackdown.org/",
170 most_recent_timestamp => "f77e2cc520"
171 } 315 }
172 316
173=cut 317=cut
174 318
175_txn client_info => sub { 319$txn->(client_info => sub {
176 my ($self) = @_; 320 my ($self) = @_;
177 321
178 $self->txn ("client_info"); 322 $self->txn ("client_info");
179}; 323});
180 324
181=item $txn = $fcp->txn_generate_chk ($metadata, $data) 325=item $txn = $fcp->txn_generate_chk ($metadata, $data[, $cipher])
182 326
183=item $uri = $fcp->generate_chk ($metadata, $data) 327=item $uri = $fcp->generate_chk ($metadata, $data[, $cipher])
184 328
185Creates a new CHK, given the metadata and data. UNTESTED. 329Calculcates a CHK, given the metadata and data. C<$cipher> is either
330C<Rijndael> or C<Twofish>, with the latter being the default.
186 331
187=cut 332=cut
188 333
189_txn generate_chk => sub { 334$txn->(generate_chk => sub {
190 my ($self, $metadata, $data) = @_; 335 my ($self, $metadata, $data, $cipher) = @_;
191 336
192 $self->txn (generate_chk => data => "$data$metadata", meta_data_length => length $metadata); 337 $self->txn (generate_chk =>
338 data => "$metadata$data",
339 metadata_length => xeh length $metadata,
340 cipher => $cipher || "Twofish");
193}; 341});
194 342
195=item $txn = $fcp->txn_generate_svk_pair 343=item $txn = $fcp->txn_generate_svk_pair
196 344
197=item ($public, $private) = @{ $fcp->generate_svk_pair } 345=item ($public, $private) = @{ $fcp->generate_svk_pair }
198 346
… …
203 "ZnmvMITaTXBMFGl4~jrjuyWxOWg" 351 "ZnmvMITaTXBMFGl4~jrjuyWxOWg"
204 ] 352 ]
205 353
206=cut 354=cut
207 355
208_txn generate_svk_pair => sub { 356$txn->(generate_svk_pair => sub {
209 my ($self) = @_; 357 my ($self) = @_;
210 358
211 $self->txn ("generate_svk_pair"); 359 $self->txn ("generate_svk_pair");
212}; 360});
213 361
214=item $txn = $fcp->txn_insert_private_key ($private) 362=item $txn = $fcp->txn_insert_private_key ($private)
215 363
216=item $uri = $fcp->insert_private_key ($private) 364=item $public = $fcp->insert_private_key ($private)
217 365
218Inserts a private key. $private can be either an insert URI (must start 366Inserts a private key. $private can be either an insert URI (must start
219with freenet:SSK@) or a raw private key (i.e. the private value you get back 367with C<freenet:SSK@>) or a raw private key (i.e. the private value you get
220from C<generate_svk_pair>). 368back from C<generate_svk_pair>).
221 369
222Returns the public key. 370Returns the public key.
223 371
224UNTESTED. 372UNTESTED.
225 373
226=cut 374=cut
227 375
228_txn insert_private_key => sub { 376$txn->(insert_private_key => sub {
229 my ($self, $privkey) = @_; 377 my ($self, $privkey) = @_;
230 378
231 $self->txn (invert_private_key => private => $privkey); 379 $self->txn (invert_private_key => private => $privkey);
232}; 380});
233 381
234=item $txn = $fcp->txn_get_size ($uri) 382=item $txn = $fcp->txn_get_size ($uri)
235 383
236=item $length = $fcp->get_size ($uri) 384=item $length = $fcp->get_size ($uri)
237 385
… …
240 388
241UNTESTED. 389UNTESTED.
242 390
243=cut 391=cut
244 392
245_txn get_size => sub { 393$txn->(get_size => sub {
246 my ($self, $uri) = @_; 394 my ($self, $uri) = @_;
247 395
248 $self->txn (get_size => URI => $uri); 396 $self->txn (get_size => URI => $uri);
249}; 397});
250 398
251=item MISSING: ClientGet, ClientPut 399=item $txn = $fcp->txn_client_get ($uri [, $htl = 15 [, $removelocal = 0]])
400
401=item ($metadata, $data) = @{ $fcp->client_get ($uri, $htl, $removelocal)
402
403Fetches a (small, as it should fit into memory) file from
404freenet. C<$meta> is the metadata (as returned by C<parse_metadata> or
405C<undef>).
406
407Due to the overhead, a better method to download big files should be used.
408
409 my ($meta, $data) = @{
410 $fcp->client_get (
411 "freenet:CHK@hdXaxkwZ9rA8-SidT0AN-bniQlgPAwI,XdCDmBuGsd-ulqbLnZ8v~w"
412 )
413 };
414
415=cut
416
417$txn->(client_get => sub {
418 my ($self, $uri, $htl, $removelocal) = @_;
419
420 $uri =~ s/^freenet://;
421 $uri = "freenet:$uri";
422
423 $self->txn (client_get => URI => $uri, hops_to_live => xeh (defined $htl ? $htl : 15),
424 remove_local_key => $removelocal ? "true" : "false");
425});
426
427=item $txn = $fcp->txn_client_put ($uri, $metadata, $data, $htl, $removelocal)
428
429=item my $uri = $fcp->client_put ($uri, $metadata, $data, $htl, $removelocal);
430
431Insert a new key. If the client is inserting a CHK, the URI may be
432abbreviated as just CHK@. In this case, the node will calculate the
433CHK.
434
435C<$meta> can be a reference or a string (ONLY THE STRING CASE IS IMPLEMENTED!).
436
437THIS INTERFACE IS UNTESTED AND SUBJECT TO CHANGE.
438
439=cut
440
441$txn->(client_put => sub {
442 my ($self, $uri, $meta, $data, $htl, $removelocal) = @_;
443
444 $self->txn (client_put => URI => $uri, xeh (defined $htl ? $htl : 15),
445 remove_local_key => $removelocal ? "true" : "false",
446 data => "$meta$data", metadata_length => xeh length $meta);
447});
448
449} # transactions
450
451=item MISSING: (ClientPut), InsertKey
252 452
253=back 453=back
254 454
255=head2 THE Net::FCP::Txn CLASS 455=head2 THE Net::FCP::Txn CLASS
256 456
257All requests (or transactions) are executed in a asynchroneous way (LIE: 457All requests (or transactions) are executed in a asynchronous way. For
258uploads are blocking). For each request, a C<Net::FCP::Txn> object is 458each request, a C<Net::FCP::Txn> object is created (worse: a tcp
259created (worse: a tcp connection is created, too). 459connection is created, too).
260 460
261For each request there is actually a different subclass (and it's possible 461For each request there is actually a different subclass (and it's possible
262to subclass these, although of course not documented). 462to subclass these, although of course not documented).
263 463
264The most interesting method is C<result>. 464The most interesting method is C<result>.
… …
266=over 4 466=over 4
267 467
268=cut 468=cut
269 469
270package Net::FCP::Txn; 470package Net::FCP::Txn;
471
472use Fcntl;
473use Socket;
271 474
272=item new arg => val,... 475=item new arg => val,...
273 476
274Creates a new C<Net::FCP::Txn> object. Not normally used. 477Creates a new C<Net::FCP::Txn> object. Not normally used.
275 478
… …
277 480
278sub new { 481sub new {
279 my $class = shift; 482 my $class = shift;
280 my $self = bless { @_ }, $class; 483 my $self = bless { @_ }, $class;
281 484
485 $self->{signal} = $EVENT->new_signal;
486
487 $self->{fcp}{txn}{$self} = $self;
488
282 my $attr = ""; 489 my $attr = "";
283 my $data = delete $self->{attr}{data}; 490 my $data = delete $self->{attr}{data};
284 491
285 while (my ($k, $v) = each %{$self->{attr}}) { 492 while (my ($k, $v) = each %{$self->{attr}}) {
286 $attr .= (Net::FCP::touc $k) . "=$v\012" 493 $attr .= (Net::FCP::touc $k) . "=$v\012"
287 } 494 }
288 495
289 if (defined $data) { 496 if (defined $data) {
290 $attr .= "DataLength=" . (length $data) . "\012"; 497 $attr .= sprintf "DataLength=%x\012", length $data;
291 $data = "Data\012$data"; 498 $data = "Data\012$data";
292 } else { 499 } else {
293 $data = "EndMessage\012"; 500 $data = "EndMessage\012";
294 } 501 }
295 502
296 my $fh = new IO::Socket::INET 503 socket my $fh, PF_INET, SOCK_STREAM, 0
297 PeerHost => $self->{fcp}{host}, 504 or Carp::croak "unable to create new tcp socket: $!";
298 PeerPort => $self->{fcp}{port}
299 or Carp::croak "FCP::txn: unable to connect to $self->{fcp}{host}:$self->{fcp}{port}: $!\n";
300
301 binmode $fh, ":raw"; 505 binmode $fh, ":raw";
506 fcntl $fh, F_SETFL, O_NONBLOCK;
507 connect $fh, (sockaddr_in $self->{fcp}{port}, inet_aton $self->{fcp}{host})
508 and !$!{EWOULDBLOCK}
509 and !$!{EINPROGRESS}
510 and Carp::croak "FCP::txn: unable to connect to $self->{fcp}{host}:$self->{fcp}{port}: $!\n";
302 511
303 if (0) { 512 $self->{sbuf} =
304 print 513 "\x00\x00\x00\x02"
305 Net::FCP::touc $self->{type}, "\012",
306 $attr,
307 $data, "\012";
308 }
309
310 print $fh
311 "\x00\x00", "\x00\x02", # SESSID, PRESID
312 Net::FCP::touc $self->{type}, "\012", 514 . (Net::FCP::touc $self->{type})
313 $attr, 515 . "\012$attr$data";
314 $data;
315 516
316 #$fh->shutdown (1); # freenet buggy?, well, it's java... 517 #shutdown $fh, 1; # freenet buggy?, well, it's java...
317 518
318 $self->{fh} = $fh; 519 $self->{fh} = $fh;
319 520
320 $Net::FCP::regcb->($self); 521 $self->{w} = $EVENT->new_from_fh ($fh)->cb(sub { $self->fh_ready_w })->poll(0, 1, 1);
321 522
322 $self; 523 $self;
323} 524}
324 525
526=item $txn = $txn->cb ($coderef)
527
528Sets a callback to be called when the request is finished. The coderef
529will be called with the txn as it's sole argument, so it has to call
530C<result> itself.
531
532Returns the txn object, useful for chaining.
533
534Example:
535
536 $fcp->txn_client_get ("freenet:CHK....")
537 ->userdata ("ehrm")
538 ->cb(sub {
539 my $data = shift->result;
540 });
541
542=cut
543
544sub cb($$) {
545 my ($self, $cb) = @_;
546 $self->{cb} = $cb;
547 $self;
548}
549
550=item $txn = $txn->userdata ([$userdata])
551
552Set user-specific data. This is useful in progress callbacks. The data can be accessed
553using C<< $txn->{userdata} >>.
554
555Returns the txn object, useful for chaining.
556
557=cut
558
559sub userdata($$) {
560 my ($self, $data) = @_;
561 $self->{userdata} = $data;
562 $self;
563}
564
565=item $txn->cancel (%attr)
566
567Cancels the operation with a C<cancel> exception anf the given attributes
568(consider at least giving the attribute C<reason>).
569
570UNTESTED.
571
572=cut
573
574sub cancel {
575 my ($self, %attr) = @_;
576 $self->throw (Net::FCP::Exception->new (cancel => { %attr }));
577 $self->set_result;
578 $self->eof;
579}
580
325sub fh_ready { 581sub fh_ready_w {
582 my ($self) = @_;
583
584 my $len = syswrite $self->{fh}, $self->{sbuf};
585
586 if ($len > 0) {
587 substr $self->{sbuf}, 0, $len, "";
588 unless (length $self->{sbuf}) {
589 fcntl $self->{fh}, F_SETFL, 0;
590 $self->{w}->cb(sub { $self->fh_ready_r })->poll (1, 0, 1);
591 }
592 } elsif (defined $len) {
593 $self->throw (Net::FCP::Exception->new (network_error => { reason => "unexpected end of file while writing" }));
594 } else {
595 $self->throw (Net::FCP::Exception->new (network_error => { reason => "$!" }));
596 }
597}
598
599sub fh_ready_r {
326 my ($self) = @_; 600 my ($self) = @_;
327 601
328 if (sysread $self->{fh}, $self->{buf}, 65536, length $self->{buf}) { 602 if (sysread $self->{fh}, $self->{buf}, 65536, length $self->{buf}) {
329 for (;;) { 603 for (;;) {
330 if ($self->{datalen}) { 604 if ($self->{datalen}) {
605 #warn "expecting new datachunk $self->{datalen}, got ".(length $self->{buf})."\n";#d#
331 if (length $self->{buf} >= $self->{datalen}) { 606 if (length $self->{buf} >= $self->{datalen}) {
332 $self->recv_data (substr $self->{buf}, 0, $self->{datalen}, ""); 607 $self->rcv_data (substr $self->{buf}, 0, delete $self->{datalen}, "");
333 } else { 608 } else {
334 last; 609 last;
335 } 610 }
336 } elsif ($self->{buf} =~ s/^DataChunk\015?\012Length=(\d+)\015?\012Data\015?\012//) { 611 } elsif ($self->{buf} =~ s/^DataChunk\015?\012Length=([0-9a-fA-F]+)\015?\012Data\015?\012//) {
337 $self->{datalen} = $1; 612 $self->{datalen} = hex $1;
613 #warn "expecting new datachunk $self->{datalen}\n";#d#
338 } elsif ($self->{buf} =~ s/^([a-zA-Z]+)\015?\012(.*?)\015?\012EndMessage\015?\012//s) { 614 } elsif ($self->{buf} =~ s/^([a-zA-Z]+)\015?\012(?:(.+?)\015?\012)?EndMessage\015?\012//s) {
339 $self->rcv ($1, { 615 $self->rcv ($1, {
340 map { my ($a, $b) = split /=/, $_, 2; ((Net::FCP::tolc $a), $b) } 616 map { my ($a, $b) = split /=/, $_, 2; ((Net::FCP::tolc $a), $b) }
341 split /\015?\012/, $2 617 split /\015?\012/, $2
342 }); 618 });
343 } else { 619 } else {
344 last; 620 last;
345 } 621 }
346 } 622 }
347 } else { 623 } else {
348 $Net::FCP::unregcb->($self);
349 delete $self->{fh};
350 $self->eof; 624 $self->eof;
351 } 625 }
352}
353
354sub rcv_data {
355 my ($self, $chunk) = @_;
356} 626}
357 627
358sub rcv { 628sub rcv {
359 my ($self, $type, $attr) = @_; 629 my ($self, $type, $attr) = @_;
360 630
361 $type = Net::FCP::tolc $type; 631 $type = Net::FCP::tolc $type;
632
633 #use PApp::Util; warn PApp::Util::dumpval [$type, $attr];
362 634
363 if (my $method = $self->can("rcv_$type")) { 635 if (my $method = $self->can("rcv_$type")) {
364 $method->($self, $attr, $type); 636 $method->($self, $attr, $type);
365 } else { 637 } else {
366 warn "received unexpected reply type '$type' for '$self->{type}', ignoring\n"; 638 warn "received unexpected reply type '$type' for '$self->{type}', ignoring\n";
367 $self->eof; 639 }
640}
641
642# used as a default exception thrower
643sub rcv_throw_exception {
644 my ($self, $attr, $type) = @_;
645 $self->throw (Net::FCP::Exception->new ($type, $attr));
646}
647
648*rcv_failed = \&Net::FCP::Txn::rcv_throw_exception;
649*rcv_format_error = \&Net::FCP::Txn::rcv_throw_exception;
650
651sub throw {
652 my ($self, $exc) = @_;
653
654 $self->{exception} = $exc;
655 $self->set_result;
656 $self->eof; # must be last to avoid loops
657}
658
659sub set_result {
660 my ($self, $result) = @_;
661
662 unless (exists $self->{result}) {
663 $self->{result} = $result;
664 $self->{cb}->($self) if exists $self->{cb};
665 $self->{signal}->send;
368 } 666 }
369} 667}
370 668
371sub eof { 669sub eof {
372 my ($self, $result) = @_; 670 my ($self) = @_;
373 671
374 $self->{result} = $result unless exists $self->{result}; 672 delete $self->{w};
673 delete $self->{fh};
674
675 delete $self->{fcp}{txn}{$self};
676
677 unless (exists $self->{result}) {
678 $self->throw (Net::FCP::Exception->new (short_data => {
679 reason => "unexpected eof or internal node error",
680 }));
681 }
682}
683
684sub progress {
685 my ($self, $type, $attr) = @_;
686 $self->{fcp}->progress ($self, $type, $attr);
375} 687}
376 688
377=item $result = $txn->result 689=item $result = $txn->result
378 690
379Waits until a result is available and then returns it. 691Waits until a result is available and then returns it.
380 692
381This waiting is (depending on your event modul) not very efficient, as it 693This waiting is (depending on your event model) not very efficient, as it
382is done outside the "mainloop". 694is done outside the "mainloop". The biggest problem, however, is that it's
695blocking one thread of execution. Try to use the callback mechanism, if
696possible, and call result from within the callback (or after is has been
697run), as then no waiting is necessary.
383 698
384=cut 699=cut
385 700
386sub result { 701sub result {
387 my ($self) = @_; 702 my ($self) = @_;
388 703
389 $Net::FCP::waitcb->() while !exists $self->{result}; 704 $self->{signal}->wait while !exists $self->{result};
705
706 die $self->{exception} if $self->{exception};
390 707
391 return $self->{result}; 708 return $self->{result};
392}
393
394sub DESTROY {
395 $Net::FCP::unregcb->($_[0]);
396} 709}
397 710
398package Net::FCP::Txn::ClientHello; 711package Net::FCP::Txn::ClientHello;
399 712
400use base Net::FCP::Txn; 713use base Net::FCP::Txn;
401 714
402sub rcv_node_hello { 715sub rcv_node_hello {
403 my ($self, $attr) = @_; 716 my ($self, $attr) = @_;
404 717
405 $self->eof ($attr); 718 $self->set_result ($attr);
406} 719}
407 720
408package Net::FCP::Txn::ClientInfo; 721package Net::FCP::Txn::ClientInfo;
409 722
410use base Net::FCP::Txn; 723use base Net::FCP::Txn;
411 724
412sub rcv_node_info { 725sub rcv_node_info {
413 my ($self, $attr) = @_; 726 my ($self, $attr) = @_;
414 727
415 $self->eof ($attr); 728 $self->set_result ($attr);
416} 729}
417 730
418package Net::FCP::Txn::GenerateCHK; 731package Net::FCP::Txn::GenerateCHK;
419 732
420use base Net::FCP::Txn; 733use base Net::FCP::Txn;
421 734
422sub rcv_success { 735sub rcv_success {
423 my ($self, $attr) = @_; 736 my ($self, $attr) = @_;
424 737
425 $self->eof ($attr); 738 $self->set_result ($attr->{uri});
426} 739}
427 740
428package Net::FCP::Txn::GenerateSVKPair; 741package Net::FCP::Txn::GenerateSVKPair;
429 742
430use base Net::FCP::Txn; 743use base Net::FCP::Txn;
431 744
432sub rcv_success { 745sub rcv_success {
433 my ($self, $attr) = @_; 746 my ($self, $attr) = @_;
434
435 $self->eof ([$attr->{PublicKey}, $attr->{PrivateKey}]); 747 $self->set_result ([$attr->{PublicKey}, $attr->{PrivateKey}]);
436} 748}
437 749
438package Net::FCP::Txn::InvertPrivateKey; 750package Net::FCP::Txn::InsertPrivateKey;
439 751
440use base Net::FCP::Txn; 752use base Net::FCP::Txn;
441 753
442sub rcv_success { 754sub rcv_success {
443 my ($self, $attr) = @_; 755 my ($self, $attr) = @_;
444
445 $self->eof ($attr->{PublicKey}); 756 $self->set_result ($attr->{PublicKey});
446} 757}
447 758
448package Net::FCP::Txn::GetSize; 759package Net::FCP::Txn::GetSize;
449 760
450use base Net::FCP::Txn; 761use base Net::FCP::Txn;
451 762
452sub rcv_success { 763sub rcv_success {
453 my ($self, $attr) = @_; 764 my ($self, $attr) = @_;
454
455 $self->eof ($attr->{Length}); 765 $self->set_result (hex $attr->{Length});
766}
767
768package Net::FCP::Txn::GetPut;
769
770# base class for get and put
771
772use base Net::FCP::Txn;
773
774*rcv_uri_error = \&Net::FCP::Txn::rcv_throw_exception;
775*rcv_route_not_found = \&Net::FCP::Txn::rcv_throw_exception;
776
777sub rcv_restarted {
778 my ($self, $attr, $type) = @_;
779
780 delete $self->{datalength};
781 delete $self->{metalength};
782 delete $self->{data};
783
784 $self->progress ($type, $attr);
785}
786
787package Net::FCP::Txn::ClientGet;
788
789use base Net::FCP::Txn::GetPut;
790
791*rcv_data_not_found = \&Net::FCP::Txn::rcv_throw_exception;
792
793sub rcv_data {
794 my ($self, $chunk) = @_;
795
796 $self->{data} .= $chunk;
797
798 $self->progress ("data", { chunk => length $chunk, received => length $self->{data}, total => $self->{datalength} });
799
800 if ($self->{datalength} == length $self->{data}) {
801 my $data = delete $self->{data};
802 my $meta = Net::FCP::parse_metadata substr $data, 0, $self->{metalength}, "";
803
804 $self->set_result ([$meta, $data]);
805 $self->eof;
806 }
807}
808
809sub rcv_data_found {
810 my ($self, $attr, $type) = @_;
811
812 $self->progress ($type, $attr);
813
814 $self->{datalength} = hex $attr->{data_length};
815 $self->{metalength} = hex $attr->{metadata_length};
816}
817
818package Net::FCP::Txn::ClientPut;
819
820use base Net::FCP::Txn::GetPut;
821
822*rcv_size_error = \&Net::FCP::Txn::rcv_throw_exception;
823*rcv_key_collision = \&Net::FCP::Txn::rcv_throw_exception;
824
825sub rcv_pending {
826 my ($self, $attr, $type) = @_;
827 $self->progress ($type, $attr);
828}
829
830sub rcv_success {
831 my ($self, $attr, $type) = @_;
832 $self->set_result ($attr);
833}
834
835=back
836
837=head2 The Net::FCP::Exception CLASS
838
839Any unexpected (non-standard) responses that make it impossible to return
840the advertised result will result in an exception being thrown when the
841C<result> method is called.
842
843These exceptions are represented by objects of this class.
844
845=over 4
846
847=cut
848
849package Net::FCP::Exception;
850
851use overload
852 '""' => sub {
853 "Net::FCP::Exception<<$_[0][0]," . (join ":", %{$_[0][1]}) . ">>";
854 };
855
856=item $exc = new Net::FCP::Exception $type, \%attr
857
858Create a new exception object of the given type (a string like
859C<route_not_found>), and a hashref containing additional attributes
860(usually the attributes of the message causing the exception).
861
862=cut
863
864sub new {
865 my ($class, $type, $attr) = @_;
866
867 bless [Net::FCP::tolc $type, { %$attr }], $class;
868}
869
870=item $exc->type([$type])
871
872With no arguments, returns the exception type. Otherwise a boolean
873indicating wether the exception is of the given type is returned.
874
875=cut
876
877sub type {
878 my ($self, $type) = @_;
879
880 @_ >= 2
881 ? $self->[0] eq $type
882 : $self->[0];
883}
884
885=item $exc->attr([$attr])
886
887With no arguments, returns the attributes. Otherwise the named attribute
888value is returned.
889
890=cut
891
892sub attr {
893 my ($self, $attr) = @_;
894
895 @_ >= 2
896 ? $self->[1]{$attr}
897 : $self->[1];
456} 898}
457 899
458=back 900=back
459 901
460=head1 SEE ALSO 902=head1 SEE ALSO
… …
468 Marc Lehmann <pcg@goof.com> 910 Marc Lehmann <pcg@goof.com>
469 http://www.goof.com/pcg/marc/ 911 http://www.goof.com/pcg/marc/
470 912
471=cut 913=cut
472 914
915package Net::FCP::Event::Auto;
916
917my @models = (
918 [Coro => Coro::Event:: ],
919 [Event => Event::],
920 [Glib => Glib:: ],
921 [Tk => Tk::],
922);
923
924sub AUTOLOAD {
925 $AUTOLOAD =~ s/.*://;
926
927 for (@models) {
928 my ($model, $package) = @$_;
929 if (defined ${"$package\::VERSION"}) {
930 $EVENT = "Net::FCP::Event::$model";
931 eval "require $EVENT"; die if $@;
932 goto &{"$EVENT\::$AUTOLOAD"};
933 }
934 }
935
936 for (@models) {
937 my ($model, $package) = @$_;
938 $EVENT = "Net::FCP::Event::$model";
939 if (eval "require $EVENT") {
940 goto &{"$EVENT\::$AUTOLOAD"};
941 }
942 }
943
944 die "No event module selected for Net::FCP and autodetect failed. Install any of these: Coro, Event, Glib or Tk.";
945}
946
4731; 9471;
474 948

Diff Legend

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