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

Diff Legend

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