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.8 by root, Mon Sep 8 01:47:31 2003 UTC vs.
Revision 1.11 by root, Tue Sep 9 18:52:39 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.
24 39
25=head2 THE Net::FCP CLASS 40=head2 THE Net::FCP CLASS
26 41
27=over 4 42=over 4
28 43
… …
31package Net::FCP; 46package Net::FCP;
32 47
33use Carp; 48use Carp;
34use IO::Socket::INET; 49use IO::Socket::INET;
35 50
36$VERSION = 0.04; 51$VERSION = 0.05;
37 52
38sub event_reg_cb { 53no warnings;
39 my ($obj) = @_;
40 require Event;
41 54
42 $obj->{eventdata} = Event->io ( 55our $EVENT = Net::FCP::Event::Auto::;
43 fd => $obj->{fh}, 56$EVENT = Net::FCP::Event::Event;#d#
44 poll => 'r', 57
45 cb => sub { 58sub import {
46 $obj->fh_ready; 59 shift;
60
61 for (@_) {
62 if (/^event=(\w+)$/) {
63 $EVENT = "Net::FCP::Event::$1";
47 }, 64 }
48 ); 65 }
66 eval "require $EVENT";
49} 67}
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 68
64sub touc($) { 69sub touc($) {
65 local $_ = shift; 70 local $_ = shift;
66 1 while s/((?:^|_)(?:svk|chk|uri)(?:_|$))/\U$1/; 71 1 while s/((?:^|_)(?:svk|chk|uri)(?:_|$))/\U$1/;
67 s/(?:^|_)(.)/\U$1/g; 72 s/(?:^|_)(.)/\U$1/g;
… …
157 162
158 $self->{nodehello} = $self->client_hello 163 $self->{nodehello} = $self->client_hello
159 or croak "unable to get nodehello from node\n"; 164 or croak "unable to get nodehello from node\n";
160 165
161 $self; 166 $self;
167}
168
169sub progress {
170 my ($self, $txn, $type, $attr) = @_;
171 warn "progress<$txn,$type," . (join ":", %$attr) . ">\n";
162} 172}
163 173
164=item $txn = $fcp->txn(type => attr => val,...) 174=item $txn = $fcp->txn(type => attr => val,...)
165 175
166The low-level interface to transactions. Don't use it. 176The low-level interface to transactions. Don't use it.
… …
402 412
403 #$fh->shutdown (1); # freenet buggy?, well, it's java... 413 #$fh->shutdown (1); # freenet buggy?, well, it's java...
404 414
405 $self->{fh} = $fh; 415 $self->{fh} = $fh;
406 416
407 $Net::FCP::regcb->($self); 417 $EVENT->reg_r_cb ($self);
408 418
409 $self; 419 $self;
420}
421
422=item $userdata = $txn->userdata ([$userdata])
423
424Get and/or set user-specific data. This is useful in progress callbacks.
425
426=cut
427
428sub userdata($;$) {
429 my ($self, $data) = @_;
430 $self->{userdata} = $data if @_ >= 2;
431 $self->{userdata};
410} 432}
411 433
412sub fh_ready { 434sub fh_ready {
413 my ($self) = @_; 435 my ($self) = @_;
414 436
415 if (sysread $self->{fh}, $self->{buf}, 65536, length $self->{buf}) { 437 if (sysread $self->{fh}, $self->{buf}, 65536, length $self->{buf}) {
416 for (;;) { 438 for (;;) {
417 if ($self->{datalen}) { 439 if ($self->{datalen}) {
418 if (length $self->{buf} >= $self->{datalen}) { 440 if (length $self->{buf} >= $self->{datalen}) {
419 $self->rcv_data (substr $self->{buf}, 0, $self->{datalen}, ""); 441 $self->rcv_data (substr $self->{buf}, 0, delete $self->{datalen}, "");
420 } else { 442 } else {
421 last; 443 last;
422 } 444 }
423 } elsif ($self->{buf} =~ s/^DataChunk\015?\012Length=([0-9a-fA-F]+)\015?\012Data\015?\012//) { 445 } elsif ($self->{buf} =~ s/^DataChunk\015?\012Length=([0-9a-fA-F]+)\015?\012Data\015?\012//) {
424 $self->{datalen} = hex $1; 446 $self->{datalen} = hex $1;
… …
430 } else { 452 } else {
431 last; 453 last;
432 } 454 }
433 } 455 }
434 } else { 456 } else {
435 $Net::FCP::unregcb->($self); 457 $EVENT->unreg_r_cb ($self);
436 delete $self->{fh}; 458 delete $self->{fh};
437 $self->eof; 459 $self->eof;
438 } 460 }
439} 461}
440 462
441sub rcv_data { 463sub rcv_data {
442 my ($self, $chunk) = @_; 464 my ($self, $chunk) = @_;
443 465
444 $self->{data} .= $chunk; 466 $self->{data} .= $chunk;
467
468 $self->progress ("data", { chunk => length $chunk, total => length $self->{data}, end => $self->{datalength} });
445} 469}
446 470
447sub rcv { 471sub rcv {
448 my ($self, $type, $attr) = @_; 472 my ($self, $type, $attr) = @_;
449 473
… …
456 } else { 480 } else {
457 warn "received unexpected reply type '$type' for '$self->{type}', ignoring\n"; 481 warn "received unexpected reply type '$type' for '$self->{type}', ignoring\n";
458 } 482 }
459} 483}
460 484
485sub throw {
486 my ($self, $exc) = @_;
487
488 $self->{exception} = $exc;
489 $self->set_result (1);
490}
491
461sub set_result { 492sub set_result {
462 my ($self, $result) = @_; 493 my ($self, $result) = @_;
463 494
464 $self->{result} = $result unless exists $self->{result}; 495 $self->{result} = $result unless exists $self->{result};
465} 496}
… …
467sub eof { 498sub eof {
468 my ($self) = @_; 499 my ($self) = @_;
469 $self->set_result; 500 $self->set_result;
470} 501}
471 502
503sub progress {
504 my ($self, $type, $attr) = @_;
505 $self->{fcp}->progress ($self, $type, $attr);
506}
507
472=item $result = $txn->result 508=item $result = $txn->result
473 509
474Waits until a result is available and then returns it. 510Waits until a result is available and then returns it.
475 511
476This waiting is (depending on your event model) not very efficient, as it 512This waiting is (depending on your event model) not very efficient, as it
… …
479=cut 515=cut
480 516
481sub result { 517sub result {
482 my ($self) = @_; 518 my ($self) = @_;
483 519
484 $Net::FCP::waitcb->() while !exists $self->{result}; 520 $EVENT->wait_event while !exists $self->{result};
521
522 die $self->{exception} if $self->{exception};
485 523
486 return $self->{result}; 524 return $self->{result};
487} 525}
488 526
489sub DESTROY { 527sub DESTROY {
490 $Net::FCP::unregcb->($_[0]); 528 $EVENT->unreg_r_cb ($_[0]);
529 #$EVENT->unreg_w_cb ($_[0]);
491} 530}
492 531
493package Net::FCP::Txn::ClientHello; 532package Net::FCP::Txn::ClientHello;
494 533
495use base Net::FCP::Txn; 534use base Net::FCP::Txn;
… …
553package Net::FCP::Txn::ClientGet; 592package Net::FCP::Txn::ClientGet;
554 593
555use base Net::FCP::Txn; 594use base Net::FCP::Txn;
556 595
557sub rcv_data_found { 596sub rcv_data_found {
558 my ($self, $attr) = @_; 597 my ($self, $attr, $type) = @_;
598
599 $self->progress ($type, $attr);
559 600
560 $self->{datalength} = hex $attr->{data_length}; 601 $self->{datalength} = hex $attr->{data_length};
561 $self->{metalength} = hex $attr->{metadata_length}; 602 $self->{metalength} = hex $attr->{metadata_length};
562} 603}
563 604
605sub rcv_route_not_found {
606 my ($self, $attr, $type) = @_;
607
608 $self->throw (new Net::FCP::Exception $type, $attr);
609}
610
611sub rcv_data_not_found {
612 my ($self, $attr, $type) = @_;
613
614 $self->throw (new Net::FCP::Exception $type, $attr);
615}
616
617sub rcv_format_error {
618 my ($self, $attr, $type) = @_;
619
620 $self->throw (new Net::FCP::Exception $type, $attr);
621}
622
564sub rcv_restarted { 623sub rcv_restarted {
565 # nop, maybe feedback 624 my ($self, $attr, $type) = @_;
625 $self->progress ($type, $attr);
566} 626}
567 627
568sub eof { 628sub eof {
569 my ($self) = @_; 629 my ($self) = @_;
570 630
… …
572 my $meta = Net::FCP::parse_metadata substr $data, 0, $self->{metalength}, ""; 632 my $meta = Net::FCP::parse_metadata substr $data, 0, $self->{metalength}, "";
573 633
574 $self->set_result ([$meta, $data]); 634 $self->set_result ([$meta, $data]);
575} 635}
576 636
637package Net::FCP::Exception;
638
639use overload
640 '""' => sub {
641 "Net::FCP::Exception<<$_[0][0]," . (join ":", %{$_[0][1]}) . ">>\n";
642 };
643
644sub new {
645 my ($class, $type, $attr) = @_;
646
647 bless [$type, { %$attr }], $class;
648}
649
577=back 650=back
578 651
579=head1 SEE ALSO 652=head1 SEE ALSO
580 653
581L<http://freenet.sf.net>. 654L<http://freenet.sf.net>.

Diff Legend

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