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

Comparing Net-FCP/FCP.pm (file contents):
Revision 1.8 by root, Mon Sep 8 01:47:31 2003 UTC vs.
Revision 1.21 by root, Tue Sep 16 07:00:59 2003 UTC

…		…
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.
		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
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
31	package Net::FCP;	73	package Net::FCP;
32		74
33	use Carp;	75	use Carp;
34	use IO::Socket::INET;
35		76
36	$VERSION = 0.04;	77	$VERSION = 0.08;
37		78
38	sub event_reg_cb {	79	no warnings;
39	my ($obj) = @_;
40	require Event;
41		80
42	$obj->{eventdata} = Event->io (	81	our $EVENT = Net::FCP::Event::Auto::;
43	fd => $obj->{fh},	82
44	poll => 'r',	83	sub 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	}
48	);	91	}
		92	die $@ if $@;
49	}	93	}
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		94
64	sub touc($) {	95	sub touc($) {
65	local $_ = shift;	96	local $_ = shift;
66	1 while s/((?:^\|_)(?:svk\|chk\|uri)(?:_\|$))/\U$1/;	97	1 while s/((?:^\|_)(?:svk\|chk\|uri)(?:_\|$))/\U$1/;
67	s/(?:^\|_)(.)/\U$1/g;	98	s/(?:^\|_)(.)/\U$1/g;
…		…
76		107
77	=item $meta = Net::FCP::parse_metadata $string	108	=item $meta = Net::FCP::parse_metadata $string
78		109
79	Parse a metadata string and return it.	110	Parse a metadata string and return it.
80		111
81	The metadata will be a hashref with key C<version> (containing	112	The metadata will be a hashref with key C<version> (containing the
82	the mandatory version header entries).	113	mandatory version header entries) and key C<raw> containing the original
		114	metadata string.
83		115
84	All other headers are represented by arrayrefs (they can be repeated).	116	All other headers are represented by arrayrefs (they can be repeated).
85		117
86	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
87	manifest:	119	parsed manifest:
88		120
89	(	121	(
		122	raw => "Version...",
90	version => { revision => 1 },	123	version => { revision => 1 },
91	document => [	124	document => [
92	{	125	{
93	"info.format" => "image/jpeg",	126	info => { format" => "image/jpeg" },
94	name => "background.jpg",	127	name => "background.jpg",
95	"redirect.target" => "freenet:CHK\@ZcagI,ra726bSw"	128	redirect => { target => "freenet:CHK\@ZcagI,ra726bSw" },
96	},	129	},
97	{	130	{
98	"info.format" => "text/html",	131	info => { format" => "text/html" },
99	name => ".next",	132	name => ".next",
100	"redirect.target" => "freenet:SSK\@ilUPAgM/TFEE/3"	133	redirect => { target => "freenet:SSK\@ilUPAgM/TFEE/3" },
101	},	134	},
102	{	135	{
103	"info.format" => "text/html",	136	info => { format" => "text/html" },
104	"redirect.target" => "freenet:CHK\@8M8Po8ucwI,8xA"	137	redirect => { target => "freenet:CHK\@8M8Po8ucwI,8xA" },
105	}	138	}
106	]	139	]
107	)	140	)
108		141
109	=cut	142	=cut
110		143
111	sub parse_metadata {	144	sub parse_metadata {
112	my $meta;
113
114	my $data = shift;	145	my $data = shift;
		146	my $meta = { raw => $data };
		147
115	if ($data =~ /^Version\015?\012/gc) {	148	if ($data =~ /^Version\015?\012/gc) {
116	my $hdr = $meta->{version} = {};	149	my $hdr = $meta->{version} = {};
117		150
118	for (;;) {	151	for (;;) {
119	while ($data =~ /\G([^=\015\012]+)=([^\015\012]*)\015?\012/gc) {	152	while ($data =~ /\G([^=\015\012]+)=([^\015\012]*)\015?\012/gc) {
120	my ($k, $v) = ($1, $2);	153	my ($k, $v) = ($1, $2);
121	$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;
122	}	160	}
123		161
124	if ($data =~ /\GEndPart\015?\012/gc) {	162	if ($data =~ /\GEndPart\015?\012/gc) {
		163	# nop
125	} elsif ($data =~ /\GEnd\015?\012/gc) {	164	} elsif ($data =~ /\GEnd(\015?\012\|$)/gc) {
126	last;	165	last;
127	} elsif ($data =~ /\G([A-Za-z0-9.\-]+)\015?\012/gcs) {	166	} elsif ($data =~ /\G([A-Za-z0-9.\-]+)\015?\012/gcs) {
128	push @{$meta->{tolc $1}}, $hdr = {};	167	push @{$meta->{tolc $1}}, $hdr = {};
129	} elsif ($data =~ /\G(.*)/gcs) {	168	} elsif ($data =~ /\G(.*)/gcs) {
		169	print STDERR "metadata format error ($1), please report this string: <<$data>>";
130	die "metadata format error ($1)";	170	die "metadata format error";
131	}	171	}
132	}	172	}
133	}	173	}
134		174
135	#$meta->{tail} = substr $data, pos $data;	175	#$meta->{tail} = substr $data, pos $data;
…		…
141		181
142	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
143	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>).
144		184
145	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
146	established. However, the existance of the node is checked by executing a	190	However, the existance of the node is checked by executing a
147	C<ClientHello> transaction.	191	C<ClientHello> transaction.
		192
		193	=end
148		194
149	=cut	195	=cut
150		196
151	sub new {	197	sub new {
152	my $class = shift;	198	my $class = shift;
153	my $self = bless { @_ }, $class;	199	my $self = bless { @_ }, $class;
154		200
155	$self->{host} \|\|= $ENV{FREDHOST} \|\| "127.0.0.1";	201	$self->{host} \|\|= $ENV{FREDHOST} \|\| "127.0.0.1";
156	$self->{port} \|\|= $ENV{FREDPORt} \|\| 8481;	202	$self->{port} \|\|= $ENV{FREDPORT} \|\| 8481;
157		203
158	$self->{nodehello} = $self->client_hello	204	#$self->{nodehello} = $self->client_hello
159	or croak "unable to get nodehello from node\n";	205	# or croak "unable to get nodehello from node\n";
160		206
161	$self;	207	$self;
162	}	208	}
163		209
		210	sub progress {
		211	my ($self, $txn, $type, $attr) = @_;
		212	#warn "progress<$txn,$type," . (join ":", %$attr) . ">\n";
		213	}
		214
164	=item $txn = $fcp->txn(type => attr => val,...)	215	=item $txn = $fcp->txn(type => attr => val,...)
165		216
166	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	);
167		240
168	=cut	241	=cut
169		242
170	sub txn {	243	sub txn {
171	my ($self, $type, %attr) = @_;	244	my ($self, $type, %attr) = @_;
…		…
175	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);
176		249
177	$txn;	250	$txn;
178	}	251	}
179		252
180	sub _txn($&) {	253	{ # transactions
		254
		255	my $txn = sub {
181	my ($name, $sub) = @_;	256	my ($name, $sub) = @_;
182	*{"$name\_txn"} = $sub;	257	*{"txn_$name"} = $sub;
183	*{$name} = sub { $sub->(@_)->result };	258	*{$name} = sub { $sub->(@_)->result };
184	}	259	};
185		260
186	=item $txn = $fcp->txn_client_hello	261	=item $txn = $fcp->txn_client_hello
187		262
188	=item $nodehello = $fcp->client_hello	263	=item $nodehello = $fcp->client_hello
189		264
…		…
195	protocol => "1.2",	270	protocol => "1.2",
196	}	271	}
197		272
198	=cut	273	=cut
199		274
200	_txn client_hello => sub {	275	$txn->(client_hello => sub {
201	my ($self) = @_;	276	my ($self) = @_;
202		277
203	$self->txn ("client_hello");	278	$self->txn ("client_hello");
204	};	279	});
205		280
206	=item $txn = $fcp->txn_client_info	281	=item $txn = $fcp->txn_client_info
207		282
208	=item $nodeinfo = $fcp->client_info	283	=item $nodeinfo = $fcp->client_info
209		284
…		…
233	routing_time => "a5",	308	routing_time => "a5",
234	}	309	}
235		310
236	=cut	311	=cut
237		312
238	_txn client_info => sub {	313	$txn->(client_info => sub {
239	my ($self) = @_;	314	my ($self) = @_;
240		315
241	$self->txn ("client_info");	316	$self->txn ("client_info");
242	};	317	});
243		318
244	=item $txn = $fcp->txn_generate_chk ($metadata, $data)	319	=item $txn = $fcp->txn_generate_chk ($metadata, $data[, $cipher])
245		320
246	=item $uri = $fcp->generate_chk ($metadata, $data)	321	=item $uri = $fcp->generate_chk ($metadata, $data[, $cipher])
247		322
248	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.
249		325
250	=cut	326	=cut
251		327
252	_txn generate_chk => sub {	328	$txn->(generate_chk => sub {
253	my ($self, $metadata, $data) = @_;	329	my ($self, $metadata, $data, $cipher) = @_;
254		330
255	$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");
256	};	335	});
257		336
258	=item $txn = $fcp->txn_generate_svk_pair	337	=item $txn = $fcp->txn_generate_svk_pair
259		338
260	=item ($public, $private) = @{ $fcp->generate_svk_pair }	339	=item ($public, $private) = @{ $fcp->generate_svk_pair }
261		340
…		…
266	"ZnmvMITaTXBMFGl4~jrjuyWxOWg"	345	"ZnmvMITaTXBMFGl4~jrjuyWxOWg"
267	]	346	]
268		347
269	=cut	348	=cut
270		349
271	_txn generate_svk_pair => sub {	350	$txn->(generate_svk_pair => sub {
272	my ($self) = @_;	351	my ($self) = @_;
273		352
274	$self->txn ("generate_svk_pair");	353	$self->txn ("generate_svk_pair");
275	};	354	});
276		355
277	=item $txn = $fcp->txn_insert_private_key ($private)	356	=item $txn = $fcp->txn_insert_private_key ($private)
278		357
279	=item $uri = $fcp->insert_private_key ($private)	358	=item $public = $fcp->insert_private_key ($private)
280		359
281	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
282	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
283	from C<generate_svk_pair>).	362	back from C<generate_svk_pair>).
284		363
285	Returns the public key.	364	Returns the public key.
286		365
287	UNTESTED.	366	UNTESTED.
288		367
289	=cut	368	=cut
290		369
291	_txn insert_private_key => sub {	370	$txn->(insert_private_key => sub {
292	my ($self, $privkey) = @_;	371	my ($self, $privkey) = @_;
293		372
294	$self->txn (invert_private_key => private => $privkey);	373	$self->txn (invert_private_key => private => $privkey);
295	};	374	});
296		375
297	=item $txn = $fcp->txn_get_size ($uri)	376	=item $txn = $fcp->txn_get_size ($uri)
298		377
299	=item $length = $fcp->get_size ($uri)	378	=item $length = $fcp->get_size ($uri)
300		379
…		…
303		382
304	UNTESTED.	383	UNTESTED.
305		384
306	=cut	385	=cut
307		386
308	_txn get_size => sub {	387	$txn->(get_size => sub {
309	my ($self, $uri) = @_;	388	my ($self, $uri) = @_;
310		389
311	$self->txn (get_size => URI => $uri);	390	$self->txn (get_size => URI => $uri);
312	};	391	});
313		392
314	=item $txn = $fcp->txn_client_get ($uri [, $htl = 15 [, $removelocal = 0]])	393	=item $txn = $fcp->txn_client_get ($uri [, $htl = 15 [, $removelocal = 0]])
315		394
316	=item ($metadata, $data) = @{ $fcp->client_get ($uri, $htl, $removelocal)	395	=item ($metadata, $data) = @{ $fcp->client_get ($uri, $htl, $removelocal)
317		396
…		…
327	)	406	)
328	};	407	};
329		408
330	=cut	409	=cut
331		410
332	_txn client_get => sub {	411	$txn->(client_get => sub {
333	my ($self, $uri, $htl, $removelocal) = @_;	412	my ($self, $uri, $htl, $removelocal) = @_;
334		413
335	$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");
336	};	416	});
337		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
338	=item MISSING: ClientPut	442	=item MISSING: (ClientPut), InsretKey
339		443
340	=back	444	=back
341		445
342	=head2 THE Net::FCP::Txn CLASS	446	=head2 THE Net::FCP::Txn CLASS
343		447
…		…
354		458
355	=cut	459	=cut
356		460
357	package Net::FCP::Txn;	461	package Net::FCP::Txn;
358		462
		463	use Fcntl;
		464	use Socket;
		465
359	=item new arg => val,...	466	=item new arg => val,...
360		467
361	Creates a new C<Net::FCP::Txn> object. Not normally used.	468	Creates a new C<Net::FCP::Txn> object. Not normally used.
362		469
363	=cut	470	=cut
364		471
365	sub new {	472	sub new {
366	my $class = shift;	473	my $class = shift;
367	my $self = bless { @_ }, $class;	474	my $self = bless { @_ }, $class;
368		475
		476	$self->{signal} = $EVENT->new_signal;
		477
		478	$self->{fcp}{txn}{$self} = $self;
		479
369	my $attr = "";	480	my $attr = "";
370	my $data = delete $self->{attr}{data};	481	my $data = delete $self->{attr}{data};
371		482
372	while (my ($k, $v) = each %{$self->{attr}}) {	483	while (my ($k, $v) = each %{$self->{attr}}) {
373	$attr .= (Net::FCP::touc $k) . "=$v\012"	484	$attr .= (Net::FCP::touc $k) . "=$v\012"
374	}	485	}
375		486
376	if (defined $data) {	487	if (defined $data) {
377	$attr .= "DataLength=" . (length $data) . "\012";	488	$attr .= sprintf "DataLength=%x\012", length $data;
378	$data = "Data\012$data";	489	$data = "Data\012$data";
379	} else {	490	} else {
380	$data = "EndMessage\012";	491	$data = "EndMessage\012";
381	}	492	}
382		493
383	my $fh = new IO::Socket::INET	494	socket my $fh, PF_INET, SOCK_STREAM, 0
384	PeerHost => $self->{fcp}{host},	495	or Carp::croak "unable to create new tcp socket: $!";
385	PeerPort => $self->{fcp}{port}
386	or Carp::croak "FCP::txn: unable to connect to $self->{fcp}{host}:$self->{fcp}{port}: $!\n";
387
388	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";
389		502
390	if (0) {	503	$self->{sbuf} =
391	print	504	"\x00\x00\x00\x02"
392	Net::FCP::touc $self->{type}, "\012",
393	$attr,
394	$data, "\012";
395	}
396
397	print $fh
398	"\x00\x00", "\x00\x02", # SESSID, PRESID
399	Net::FCP::touc $self->{type}, "\012",	505	. (Net::FCP::touc $self->{type})
400	$attr,	506	. "\012$attr$data";
401	$data;
402		507
403	#$fh->shutdown (1); # freenet buggy?, well, it's java...	508	#shutdown $fh, 1; # freenet buggy?, well, it's java...
404		509
405	$self->{fh} = $fh;	510	$self->{fh} = $fh;
406		511
407	$Net::FCP::regcb->($self);	512	$self->{w} = $EVENT->new_from_fh ($fh)->cb(sub { $self->fh_ready_w })->poll(0, 1, 1);
408		513
409	$self;	514	$self;
410	}	515	}
411		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
		541	=item $txn = $txn->userdata ([$userdata])
		542
		543	Set user-specific data. This is useful in progress callbacks. The data can be accessed
		544	using C<< $txn->{userdata} >>.
		545
		546	Returns the txn object, useful for chaining.
		547
		548	=cut
		549
		550	sub userdata($$) {
		551	my ($self, $data) = @_;
		552	$self->{userdata} = $data;
		553	$self;
		554	}
		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
412	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 {
413	my ($self) = @_;	591	my ($self) = @_;
414		592
415	if (sysread $self->{fh}, $self->{buf}, 65536, length $self->{buf}) {	593	if (sysread $self->{fh}, $self->{buf}, 65536, length $self->{buf}) {
416	for (;;) {	594	for (;;) {
417	if ($self->{datalen}) {	595	if ($self->{datalen}) {
		596	#warn "expecting new datachunk $self->{datalen}, got ".(length $self->{buf})."\n";#d#
418	if (length $self->{buf} >= $self->{datalen}) {	597	if (length $self->{buf} >= $self->{datalen}) {
419	$self->rcv_data (substr $self->{buf}, 0, $self->{datalen}, "");	598	$self->rcv_data (substr $self->{buf}, 0, delete $self->{datalen}, "");
420	} else {	599	} else {
421	last;	600	last;
422	}	601	}
423	} 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//) {
424	$self->{datalen} = hex $1;	603	$self->{datalen} = hex $1;
		604	#warn "expecting new datachunk $self->{datalen}\n";#d#
425	} 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) {
426	$self->rcv ($1, {	606	$self->rcv ($1, {
427	map { my ($a, $b) = split /=/, $_, 2; ((Net::FCP::tolc $a), $b) }	607	map { my ($a, $b) = split /=/, $_, 2; ((Net::FCP::tolc $a), $b) }
428	split /\015?\012/, $2	608	split /\015?\012/, $2
429	});	609	});
430	} else {	610	} else {
431	last;	611	last;
432	}	612	}
433	}	613	}
434	} else {	614	} else {
435	$Net::FCP::unregcb->($self);
436	delete $self->{fh};
437	$self->eof;	615	$self->eof;
438	}	616	}
439	}
440
441	sub rcv_data {
442	my ($self, $chunk) = @_;
443
444	$self->{data} .= $chunk;
445	}	617	}
446		618
447	sub rcv {	619	sub rcv {
448	my ($self, $type, $attr) = @_;	620	my ($self, $type, $attr) = @_;
449		621
…		…
456	} else {	628	} else {
457	warn "received unexpected reply type '$type' for '$self->{type}', ignoring\n";	629	warn "received unexpected reply type '$type' for '$self->{type}', ignoring\n";
458	}	630	}
459	}	631	}
460		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
		642	sub throw {
		643	my ($self, $exc) = @_;
		644
		645	$self->{exception} = $exc;
		646	$self->set_result;
		647	$self->eof; # must be last to avoid loops
		648	}
		649
461	sub set_result {	650	sub set_result {
462	my ($self, $result) = @_;	651	my ($self, $result) = @_;
463		652
464	$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	}
465	}	658	}
466		659
467	sub eof {	660	sub eof {
468	my ($self) = @_;	661	my ($self) = @_;
469	$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	}
		673	}
		674
		675	sub progress {
		676	my ($self, $type, $attr) = @_;
		677	$self->{fcp}->progress ($self, $type, $attr);
470	}	678	}
471		679
472	=item $result = $txn->result	680	=item $result = $txn->result
473		681
474	Waits until a result is available and then returns it.	682	Waits until a result is available and then returns it.
…		…
479	=cut	687	=cut
480		688
481	sub result {	689	sub result {
482	my ($self) = @_;	690	my ($self) = @_;
483		691
484	$Net::FCP::waitcb->() while !exists $self->{result};	692	$self->{signal}->wait while !exists $self->{result};
		693
		694	die $self->{exception} if $self->{exception};
485		695
486	return $self->{result};	696	return $self->{result};
487	}
488
489	sub DESTROY {
490	$Net::FCP::unregcb->($_[0]);
491	}	697	}
492		698
493	package Net::FCP::Txn::ClientHello;	699	package Net::FCP::Txn::ClientHello;
494		700
495	use base Net::FCP::Txn;	701	use base Net::FCP::Txn;
…		…
515	use base Net::FCP::Txn;	721	use base Net::FCP::Txn;
516		722
517	sub rcv_success {	723	sub rcv_success {
518	my ($self, $attr) = @_;	724	my ($self, $attr) = @_;
519		725
520	$self->set_result ($attr);	726	$self->set_result ($attr->{uri});
521	}	727	}
522		728
523	package Net::FCP::Txn::GenerateSVKPair;	729	package Net::FCP::Txn::GenerateSVKPair;
524		730
525	use base Net::FCP::Txn;	731	use base Net::FCP::Txn;
526		732
527	sub rcv_success {	733	sub rcv_success {
528	my ($self, $attr) = @_;	734	my ($self, $attr) = @_;
529
530	$self->set_result ([$attr->{PublicKey}, $attr->{PrivateKey}]);	735	$self->set_result ([$attr->{PublicKey}, $attr->{PrivateKey}]);
531	}	736	}
532		737
533	package Net::FCP::Txn::InvertPrivateKey;	738	package Net::FCP::Txn::InsertPrivateKey;
534		739
535	use base Net::FCP::Txn;	740	use base Net::FCP::Txn;
536		741
537	sub rcv_success {	742	sub rcv_success {
538	my ($self, $attr) = @_;	743	my ($self, $attr) = @_;
539
540	$self->set_result ($attr->{PublicKey});	744	$self->set_result ($attr->{PublicKey});
541	}	745	}
542		746
543	package Net::FCP::Txn::GetSize;	747	package Net::FCP::Txn::GetSize;
544		748
545	use base Net::FCP::Txn;	749	use base Net::FCP::Txn;
546		750
547	sub rcv_success {	751	sub rcv_success {
548	my ($self, $attr) = @_;	752	my ($self, $attr) = @_;
549
550	$self->set_result ($attr->{Length});	753	$self->set_result ($attr->{Length});
551	}	754	}
552		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
553	package Net::FCP::Txn::ClientGet;	775	package Net::FCP::Txn::ClientGet;
554		776
555	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	}
		794	}
556		795
557	sub rcv_data_found {	796	sub rcv_data_found {
558	my ($self, $attr) = @_;	797	my ($self, $attr, $type) = @_;
		798
		799	$self->progress ($type, $attr);
559		800
560	$self->{datalength} = hex $attr->{data_length};	801	$self->{datalength} = hex $attr->{data_length};
561	$self->{metalength} = hex $attr->{metadata_length};	802	$self->{metalength} = hex $attr->{metadata_length};
562	}	803	}
563		804
564	sub rcv_restarted {	805	package Net::FCP::Txn::ClientPut;
565	# nop, maybe feedback
566	}
567		806
		807	use base Net::FCP::Txn::GetPut;
		808
		809	*rcv_size_error = \&Net::FCP::Txn::rcv_throw_exception;
		810	*rcv_key_collision = \&Net::FCP::Txn::rcv_throw_exception;
		811
		812	sub rcv_pending {
		813	my ($self, $attr, $type) = @_;
		814	$self->progress ($type, $attr);
		815	}
		816
		817	sub rcv_success {
		818	my ($self, $attr, $type) = @_;
		819	$self->set_result ($attr);
		820	}
		821
		822	=back
		823
		824	=head2 The Net::FCP::Exception CLASS
		825
		826	Any unexpected (non-standard) responses that make it impossible to return
		827	the advertised result will result in an exception being thrown when the
		828	C<result> method is called.
		829
		830	These exceptions are represented by objects of this class.
		831
		832	=over 4
		833
		834	=cut
		835
		836	package Net::FCP::Exception;
		837
		838	use overload
		839	'""' => sub {
		840	"Net::FCP::Exception<<$_[0][0]," . (join ":", %{$_[0][1]}) . ">>\n";
		841	};
		842
		843	=item $exc = new Net::FCP::Exception $type, \%attr
		844
		845	Create a new exception object of the given type (a string like
		846	C<route_not_found>), and a hashref containing additional attributes
		847	(usually the attributes of the message causing the exception).
		848
		849	=cut
		850
568	sub eof {	851	sub new {
		852	my ($class, $type, $attr) = @_;
		853
		854	bless [Net::FCP::tolc $type, { %$attr }], $class;
		855	}
		856
		857	=item $exc->type([$type])
		858
		859	With no arguments, returns the exception type. Otherwise a boolean
		860	indicating wether the exception is of the given type is returned.
		861
		862	=cut
		863
		864	sub type {
569	my ($self) = @_;	865	my ($self, $type) = @_;
570		866
571	my $data = delete $self->{data};	867	@_ >= 2
572	my $meta = Net::FCP::parse_metadata substr $data, 0, $self->{metalength}, "";	868	? $self->[0] eq $type
		869	: $self->[0];
		870	}
573		871
574	$self->set_result ([$meta, $data]);	872	=item $exc->attr([$attr])
		873
		874	With no arguments, returns the attributes. Otherwise the named attribute
		875	value is returned.
		876
		877	=cut
		878
		879	sub attr {
		880	my ($self, $attr) = @_;
		881
		882	@_ >= 2
		883	? $self->[1]{$attr}
		884	: $self->[1];
575	}	885	}
576		886
577	=back	887	=back
578		888
579	=head1 SEE ALSO	889	=head1 SEE ALSO
…		…
587	Marc Lehmann <pcg@goof.com>	897	Marc Lehmann <pcg@goof.com>
588	http://www.goof.com/pcg/marc/	898	http://www.goof.com/pcg/marc/
589		899
590	=cut	900	=cut
591		901
		902	package Net::FCP::Event::Auto;
		903
		904	my @models = (
		905	[Coro => Coro::Event:: ],
		906	[Event => Event::],
		907	[Glib => Glib:: ],
		908	[Tk => Tk::],
		909	);
		910
		911	sub AUTOLOAD {
		912	$AUTOLOAD =~ s/.*://;
		913
		914	for (@models) {
		915	my ($model, $package) = @$_;
		916	if (defined ${"$package\::VERSION"}) {
		917	$EVENT = "Net::FCP::Event::$model";
		918	eval "require $EVENT"; die if $@;
		919	goto &{"$EVENT\::$AUTOLOAD"};
		920	}
		921	}
		922
		923	for (@models) {
		924	my ($model, $package) = @$_;
		925	$EVENT = "Net::FCP::Event::$model";
		926	if (eval "require $EVENT") {
		927	goto &{"$EVENT\::$AUTOLOAD"};
		928	}
		929	}
		930
		931	die "No event module selected for Net::FCP and autodetect failed. Install any of these: Coro, Event, Glib or Tk.";
		932	}
		933
592	1;	934	1;
593		935

Diff Legend

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

Comparing Net-FCP/FCP.pm (file contents): Revision 1.8 by root, Mon Sep 8 01:47:31 2003 UTC vs. Revision 1.21 by root, Tue Sep 16 07:00:59 2003 UTC

Diff Legend

Comparing Net-FCP/FCP.pm (file contents):
Revision 1.8 by root, Mon Sep 8 01:47:31 2003 UTC vs.
Revision 1.21 by root, Tue Sep 16 07:00:59 2003 UTC