… | |
… | |
17 | of what the messages do. I am too lazy to document all this here. |
17 | of what the messages do. I am too lazy to document all this here. |
18 | |
18 | |
19 | =head1 WARNING |
19 | =head1 WARNING |
20 | |
20 | |
21 | This module is alpha. While it probably won't destroy (much :) of your |
21 | This module is alpha. While it probably won't destroy (much :) of your |
22 | data, it currently works only with the Event module (alkthough the event |
22 | data, it currently falls short of what it should provide (intelligent uri |
23 | mechanism is fully pluggable). |
23 | following, splitfile downloads, healing...) |
|
|
24 | |
|
|
25 | =head2 IMPORT TAGS |
|
|
26 | |
|
|
27 | Nothing much can be "imported" from this module right now. There are, |
|
|
28 | however, certain "import tags" that can be used to select the event model |
|
|
29 | to be used. |
|
|
30 | |
|
|
31 | Event models are implemented as modules under the C<Net::FCP::Event::xyz> |
|
|
32 | class, where C<xyz> is the event model to use. The default is C<Event> (or |
|
|
33 | later C<Auto>). |
|
|
34 | |
|
|
35 | The import tag to use is named C<event=xyz>, e.g. C<event=Event>, |
|
|
36 | C<event=Glib> etc. |
|
|
37 | |
|
|
38 | You 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 | |
… | |
… | |
31 | package Net::FCP; |
46 | package Net::FCP; |
32 | |
47 | |
33 | use Carp; |
48 | use Carp; |
34 | use IO::Socket::INET; |
49 | use IO::Socket::INET; |
35 | |
50 | |
36 | $VERSION = 0.04; |
51 | $VERSION = 0.05; |
37 | |
52 | |
38 | sub event_reg_cb { |
53 | no warnings; |
39 | my ($obj) = @_; |
|
|
40 | require Event; |
|
|
41 | |
54 | |
42 | $obj->{eventdata} = Event->io ( |
55 | our $EVENT = Net::FCP::Event::Auto::; |
43 | fd => $obj->{fh}, |
56 | $EVENT = Net::FCP::Event::Event;#d# |
44 | poll => 'r', |
57 | |
45 | cb => sub { |
58 | sub 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 | |
|
|
51 | sub event_unreg_cb { |
|
|
52 | $_[0]{eventdata} |
|
|
53 | and (delete $_[0]{eventdata})->cancel; |
|
|
54 | } |
|
|
55 | |
|
|
56 | sub 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 | |
64 | sub touc($) { |
69 | sub 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 | |
|
|
169 | sub 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 | |
166 | The low-level interface to transactions. Don't use it. |
176 | The 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 | |
|
|
424 | Get and/or set user-specific data. This is useful in progress callbacks. |
|
|
425 | |
|
|
426 | =cut |
|
|
427 | |
|
|
428 | sub userdata($;$) { |
|
|
429 | my ($self, $data) = @_; |
|
|
430 | $self->{userdata} = $data if @_ >= 2; |
|
|
431 | $self->{userdata}; |
410 | } |
432 | } |
411 | |
433 | |
412 | sub fh_ready { |
434 | sub fh_ready { |
413 | my ($self) = @_; |
435 | my ($self) = @_; |
414 | |
436 | |
… | |
… | |
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 | |
441 | sub rcv_data { |
463 | sub 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 | |
447 | sub rcv { |
471 | sub 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 | |
|
|
485 | sub throw { |
|
|
486 | my ($self, $exc) = @_; |
|
|
487 | |
|
|
488 | $self->{exception} = $exc; |
|
|
489 | $self->set_result (1); |
|
|
490 | } |
|
|
491 | |
461 | sub set_result { |
492 | sub 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 | } |
… | |
… | |
467 | sub eof { |
498 | sub eof { |
468 | my ($self) = @_; |
499 | my ($self) = @_; |
469 | $self->set_result; |
500 | $self->set_result; |
470 | } |
501 | } |
471 | |
502 | |
|
|
503 | sub 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 | |
474 | Waits until a result is available and then returns it. |
510 | Waits until a result is available and then returns it. |
475 | |
511 | |
476 | This waiting is (depending on your event model) not very efficient, as it |
512 | This waiting is (depending on your event model) not very efficient, as it |
… | |
… | |
479 | =cut |
515 | =cut |
480 | |
516 | |
481 | sub result { |
517 | sub 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 | |
489 | sub DESTROY { |
527 | sub DESTROY { |
490 | $Net::FCP::unregcb->($_[0]); |
528 | $EVENT->unreg_r_cb ($_[0]); |
|
|
529 | #$EVENT->unreg_w_cb ($_[0]); |
491 | } |
530 | } |
492 | |
531 | |
493 | package Net::FCP::Txn::ClientHello; |
532 | package Net::FCP::Txn::ClientHello; |
494 | |
533 | |
495 | use base Net::FCP::Txn; |
534 | use base Net::FCP::Txn; |
… | |
… | |
553 | package Net::FCP::Txn::ClientGet; |
592 | package Net::FCP::Txn::ClientGet; |
554 | |
593 | |
555 | use base Net::FCP::Txn; |
594 | use base Net::FCP::Txn; |
556 | |
595 | |
557 | sub rcv_data_found { |
596 | sub 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 | |
|
|
605 | sub rcv_route_not_found { |
|
|
606 | my ($self, $attr, $type) = @_; |
|
|
607 | |
|
|
608 | $self->throw (new Net::FCP::Exception $type, $attr); |
|
|
609 | } |
|
|
610 | |
|
|
611 | sub rcv_data_not_found { |
|
|
612 | my ($self, $attr, $type) = @_; |
|
|
613 | |
|
|
614 | $self->throw (new Net::FCP::Exception $type, $attr); |
|
|
615 | } |
|
|
616 | |
|
|
617 | sub rcv_format_error { |
|
|
618 | my ($self, $attr, $type) = @_; |
|
|
619 | |
|
|
620 | $self->throw (new Net::FCP::Exception $type, $attr); |
|
|
621 | } |
|
|
622 | |
564 | sub rcv_restarted { |
623 | sub rcv_restarted { |
565 | # nop, maybe feedback |
624 | my ($self, $attr, $type) = @_; |
|
|
625 | $self->progress ($type, $attr); |
566 | } |
626 | } |
567 | |
627 | |
568 | sub eof { |
628 | sub 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 | |
|
|
637 | package Net::FCP::Exception; |
|
|
638 | |
|
|
639 | use overload |
|
|
640 | '""' => sub { |
|
|
641 | "Net::FCP::Exception<<$_[0][0]," . (join ":", %{$_[0][1]}) . ">>\n"; |
|
|
642 | }; |
|
|
643 | |
|
|
644 | sub 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 | |
581 | L<http://freenet.sf.net>. |
654 | L<http://freenet.sf.net>. |