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

Diff Legend

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