[ViewVC] Diff of: cvs/cvsroot/Net-FCP/FCP.pm

Comparing cvsroot/Net-FCP/FCP.pm (file contents):
Revision 1.10 by root, Tue Sep 9 06:22:58 2003 UTC vs.
Revision 1.22 by root, Wed Sep 17 05:05:33 2003 UTC

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

Diff Legend

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

Comparing cvsroot/Net-FCP/FCP.pm (file contents): Revision 1.10 by root, Tue Sep 9 06:22:58 2003 UTC vs. Revision 1.22 by root, Wed Sep 17 05:05:33 2003 UTC

Diff Legend

Comparing cvsroot/Net-FCP/FCP.pm (file contents):
Revision 1.10 by root, Tue Sep 9 06:22:58 2003 UTC vs.
Revision 1.22 by root, Wed Sep 17 05:05:33 2003 UTC