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

Comparing AnyEvent-FCP/FCP.pm (file contents):
Revision 1.12 by root, Sat Aug 8 04:02:48 2015 UTC vs.
Revision 1.16 by root, Sat Sep 5 13:26:47 2015 UTC

… …
69 69
70use AnyEvent; 70use AnyEvent;
71use AnyEvent::Handle; 71use AnyEvent::Handle;
72use AnyEvent::Util (); 72use AnyEvent::Util ();
73 73
74our %TOLC; # tolc cache
75
74sub touc($) { 76sub touc($) {
75 local $_ = shift; 77 local $_ = shift;
76 1 while s/((?:^|_)(?:svk|chk|uri|fcp|ds|mime|dda)(?:_|$))/\U$1/; 78 1 while s/((?:^|_)(?:svk|chk|uri|fcp|ds|mime|dda)(?:_|$))/\U$1/;
77 s/(?:^|_)(.)/\U$1/g; 79 s/(?:^|_)(.)/\U$1/g;
78 $_ 80 $_
… …
96 98
97=cut 99=cut
98 100
99sub new { 101sub new {
100 my $class = shift; 102 my $class = shift;
103
104 my $rand = join "", map chr 0x21 + rand 94, 1..40; # ~ 262 bits entropy
105
101 my $self = bless { 106 my $self = bless {
102 host => $ENV{FREDHOST} || "127.0.0.1", 107 host => $ENV{FREDHOST} || "127.0.0.1",
103 port => $ENV{FREDPORT} || 9481, 108 port => $ENV{FREDPORT} || 9481,
104 timeout => 3600 * 2, 109 timeout => 3600 * 2,
105 name => time.rand.rand.rand, # lame 110 name => time.rand.rand.rand, # lame
106 @_, 111 @_,
107 queue => [], 112 queue => [],
108 req => {}, 113 req => {},
114 prefix => "..:aefcpid:$rand:",
109 id => "a0", 115 idseq => "a0",
110 }, $class; 116 }, $class;
111 117
112 { 118 {
113 Scalar::Util::weaken (my $self = $self); 119 Scalar::Util::weaken (my $self = $self);
114 120
… …
131 ); 137 );
132 138
133 $self 139 $self
134} 140}
135 141
142sub identifier {
143 $_[0]{prefix} . ++$_[0]{idseq}
144}
145
136sub send_msg { 146sub send_msg {
137 my ($self, $type, %kv) = @_; 147 my ($self, $type, %kv) = @_;
138 148
139 my $data = delete $kv{data}; 149 my $data = delete $kv{data};
140 150
141 if (exists $kv{id_cb}) { 151 if (exists $kv{id_cb}) {
142 my $id = $kv{identifier} ||= ++$self->{id}; 152 my $id = $kv{identifier} ||= $self->identifier;
143 $self->{id}{$id} = delete $kv{id_cb}; 153 $self->{id}{$id} = delete $kv{id_cb};
144 } 154 }
145 155
146 my $msg = (touc $type) . "\012" 156 my $msg = (touc $type) . "\012"
147 . join "", map +(touc $_) . "=$kv{$_}\012", keys %kv; 157 . join "", map +(touc $_) . "=$kv{$_}\012", keys %kv;
… …
224 234
225 if (my $cb = $PERSISTENT_TYPE{$type}) { 235 if (my $cb = $PERSISTENT_TYPE{$type}) {
226 my $id = $kv->{identifier}; 236 my $id = $kv->{identifier};
227 my $req = $_[0]{req}{$id} ||= {}; 237 my $req = $_[0]{req}{$id} ||= {};
228 $cb->($self, $req, $kv); 238 $cb->($self, $req, $kv);
229 $self->recv (request_change => $kv, $type, @extra); 239 $self->recv (request_changed => $kv, $type, @extra);
230 } 240 }
231 241
232 my $on = $self->{on}; 242 my $on = $self->{on};
233 for (0 .. $#$on) { 243 for (0 .. $#$on) {
234 unless (my $res = $on->[$_]($self, $type, $kv, @extra)) { 244 unless (my $res = $on->[$_]($self, $type, $kv, @extra)) {
… …
246} 256}
247 257
248sub on_read { 258sub on_read {
249 my ($self) = @_; 259 my ($self) = @_;
250 260
251 my $type; 261 my ($k, $v, $type);
252 my %kv; 262 my %kv;
253 my $rdata; 263 my $rdata;
254 264
255 my $hdr_cb; $hdr_cb = sub { 265 my $hdr_cb; $hdr_cb = sub {
256 if ($_[1] =~ /^([^=]+)=(.*)$/) { 266 if (($v = index $_[1], "=") >= 0) {
257 my ($k, $v) = ($1, $2); 267 $k = substr $_[1], 0, $v;
268 $v = substr $_[1], $v + 1;
269 $k = ($TOLC{$k} ||= tolc $k);
270
271 if ($k !~ /\./) {
272 # special case common case, for performance only
273 $kv{$k} = $v;
274 } else {
258 my @k = split /\./, tolc $k; 275 my @k = split /\./, $k;
259 my $ro = \\%kv; 276 my $ro = \\%kv;
260 277
261 while (@k) { 278 while (@k) {
262 my $k = shift @k; 279 $k = shift @k;
263 if ($k =~ /^\d+$/) { 280 if ($k =~ /^\d+$/) {
264 $ro = \$$ro->[$k]; 281 $ro = \$$ro->[$k];
265 } else { 282 } else {
266 $ro = \$$ro->{$k}; 283 $ro = \$$ro->{$k};
284 }
267 } 285 }
286
287 $$ro = $v;
268 } 288 }
269
270 $$ro = $v;
271 289
272 $_[0]->push_read (line => $hdr_cb); 290 $_[0]->push_read (line => $hdr_cb);
273 } elsif ($_[1] eq "Data") { 291 } elsif ($_[1] eq "Data") {
274 $_[0]->push_read (chunk => delete $kv{data_length}, sub { 292 $_[0]->push_read (chunk => delete $kv{data_length}, sub {
275 $rdata = \$_[1]; 293 $rdata = \$_[1];
… …
281 die "protocol error, expected message end, got $_[1]\n";#d# 299 die "protocol error, expected message end, got $_[1]\n";#d#
282 } 300 }
283 }; 301 };
284 302
285 $self->{hdl}->push_read (line => sub { 303 $self->{hdl}->push_read (line => sub {
286 $type = tolc $_[1]; 304 $type = ($TOLC{$_[1]} ||= tolc $_[1]);
287 $_[0]->push_read (line => $hdr_cb); 305 $_[0]->push_read (line => $hdr_cb);
288 }); 306 });
289} 307}
290 308
291sub default_recv { 309sub default_recv {
… …
371 my ($name, $sub) = @_; 389 my ($name, $sub) = @_;
372 390
373 *{$name} = sub { 391 *{$name} = sub {
374 my $cv = AE::cv; 392 my $cv = AE::cv;
375 393
376 splice @_, 1, 0, $cv, sub { $cv->throw ($_[0]{extra_description}) }; 394 splice @_, 1, 0, $cv, sub { $cv->croak ($_[0]{extra_description}) };
377 &$sub; 395 &$sub;
378 $cv->recv 396 $cv->recv
379 }; 397 };
380 398
381 *{"$name\_"} = sub { 399 *{"$name\_"} = sub {
382 my ($ok, $err) = pop; 400 my ($ok, $err) = pop;
383 401
384 if (ARRAY:: eq ref $ok) { 402 if (ARRAY:: eq ref $ok) {
385 ($ok, $err) = @$ok; 403 ($ok, $err) = @$ok;
386 } elsif (UNIVERSAL::isa $ok, AnyEvent::CondVar::) { 404 } elsif (UNIVERSAL::isa $ok, AnyEvent::CondVar::) {
387 $err = sub { $ok->throw ($_[0]{extra_description}) }; 405 $err = sub { $ok->croak ($_[0]{extra_description}) };
388 } else { 406 } else {
389 my $bt = Carp::longmess ""; 407 my $bt = Carp::longmess "";
390 $err = sub { 408 $err = sub {
391 die "$_[0]{extra_description}$bt"; 409 die "$_[0]{code_description} ($_[0]{extra_description})$bt";
392 }; 410 };
393 } 411 }
394 412
395 $ok ||= $NOP_CB; 413 $ok ||= $NOP_CB;
396 414
… …
517 ); 535 );
518 536
519 $self->on (sub { 537 $self->on (sub {
520 my ($self, $type, $kv, @extra) = @_; 538 my ($self, $type, $kv, @extra) = @_;
521 539
540 $guard if 0;
541
522 if ($kv->{identifier} eq $identifier) { 542 if ($kv->{identifier} eq $identifier) {
523 if ($type eq "persistent_request_modified") { 543 if ($type eq "persistent_request_modified") {
524 $ok->($kv); 544 $ok->($kv);
525 return; 545 return;
526 } elsif ($type eq "protocol_error") { 546 } elsif ($type eq "protocol_error") {
… …
539=cut 559=cut
540 560
541_txn get_plugin_info => sub { 561_txn get_plugin_info => sub {
542 my ($self, $ok, $err, $name, $detailed) = @_; 562 my ($self, $ok, $err, $name, $detailed) = @_;
543 563
564 my $id = $self->identifier;
565
544 $self->send_msg (get_plugin_info => 566 $self->send_msg (get_plugin_info =>
567 identifier => $id,
545 plugin_name => $name, 568 plugin_name => $name,
546 detailed => $detailed ? "true" : "false", 569 detailed => $detailed ? "true" : "false",
547 id_cb => sub {
548 my ($self, $type, $kv, $rdata) = @_;
549
550 $ok->($kv);
551 1
552 },
553 ); 570 );
571 $self->on (sub {
572 my ($self, $type, $kv) = @_;
573
574 if ($kv->{identifier} eq $id) {
575 if ($type eq "get_plugin_info") {
576 $ok->($kv);
577 } else {
578 $err->($kv, $type);
579 }
580 return;
581 }
582
583 1
584 });
554}; 585};
555 586
556=item $status = $fcp->client_get ($uri, $identifier, %kv) 587=item $status = $fcp->client_get ($uri, $identifier, %kv)
557 588
558%kv can contain (L<http://wiki.freenetproject.org/FCP2p0ClientGet>). 589%kv can contain (L<http://wiki.freenetproject.org/FCP2p0ClientGet>).
… …
564=cut 595=cut
565 596
566_txn client_get => sub { 597_txn client_get => sub {
567 my ($self, $ok, $err, $uri, $identifier, %kv) = @_; 598 my ($self, $ok, $err, $uri, $identifier, %kv) = @_;
568 599
600 $self->serialise ($identifier => sub {
601 my ($self, $guard) = @_;
602
569 $self->send_msg (client_get => 603 $self->send_msg (client_get =>
570 %kv, 604 %kv,
571 uri => $uri, 605 uri => $uri,
572 identifier => $identifier, 606 identifier => $identifier,
607 );
608
609 $self->on (sub {
610 my ($self, $type, $kv, @extra) = @_;
611
612 $guard if 0;
613
614 if ($kv->{identifier} eq $identifier) {
615 if ($type eq "persistent_get") {
616 $ok->($kv);
617 return;
618 } elsif ($type eq "protocol_error") {
619 $err->($kv);
620 return;
621 }
622 }
623
624 1
625 });
573 ); 626 });
574
575 $ok->();
576}; 627};
577 628
578=item $status = $fcp->remove_request ($identifier[, $global]) 629=item $status = $fcp->remove_request ($identifier[, $global])
579 630
580Remove the request with the given isdentifier. Returns true if successful, 631Remove the request with the given isdentifier. Returns true if successful,
… …
592 identifier => $identifier, 643 identifier => $identifier,
593 global => $global ? "true" : "false", 644 global => $global ? "true" : "false",
594 ); 645 );
595 $self->on (sub { 646 $self->on (sub {
596 my ($self, $type, $kv, @extra) = @_; 647 my ($self, $type, $kv, @extra) = @_;
648
649 $guard if 0;
597 650
598 if ($kv->{identifier} eq $identifier) { 651 if ($kv->{identifier} eq $identifier) {
599 if ($type eq "persistent_request_removed") { 652 if ($type eq "persistent_request_removed") {
600 $ok->(1); 653 $ok->(1);
601 return; 654 return;

Diff Legend

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