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

Comparing cvsroot/Net-FCP/FCP.pm (file contents):
Revision 1.9 by root, Tue Sep 9 06:13:18 2003 UTC vs.
Revision 1.30 by root, Fri May 14 16:12:26 2004 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.04;	77	$VERSION = 0.7;
		78
		79	no warnings;
		80
		81	use Net::FCP::Metadata;
52		82
53	our $EVENT = Net::FCP::Event::Auto::;	83	our $EVENT = Net::FCP::Event::Auto::;
54	$EVENT = Net::FCP::Event::Event::;#d#
55		84
56	sub import {	85	sub import {
57	shift;	86	shift;
58		87
59	for (@_) {	88	for (@_) {
60	if (/^event=(\w+)$/) {	89	if (/^event=(\w+)$/) {
61	$EVENT = "Net::FCP::Event::$1";	90	$EVENT = "Net::FCP::Event::$1";
		91	eval "require $EVENT";
62	}	92	}
63	}	93	}
64	eval "require $EVENT";	94	die $@ if $@;
65	}	95	}
66		96
67	sub touc($) {	97	sub touc($) {
68	local $_ = shift;	98	local $_ = shift;
69	1 while s/((?:^\|_)(?:svk\|chk\|uri)(?:_\|$))/\U$1/;	99	1 while s/((?:^\|_)(?:svk\|chk\|uri)(?:_\|$))/\U$1/;
…		…
71	$_;	101	$_;
72	}	102	}
73		103
74	sub tolc($) {	104	sub tolc($) {
75	local $_ = shift;	105	local $_ = shift;
		106	1 while s/(SVK\|CHK\|URI)([^_])/$1\_$2/i;
		107	1 while s/([^_])(SVK\|CHK\|URI)/$1\_$2/i;
76	s/(?<=[a-z])(?=[A-Z])/_/g;	108	s/(?<=[a-z])(?=[A-Z])/_/g;
77	lc $_;	109	lc $_;
78	}	110	}
79		111
80	=item $meta = Net::FCP::parse_metadata $string	112	# the opposite of hex
81		113	sub xeh($) {
82	Parse a metadata string and return it.	114	sprintf "%x", $_[0];
83
84	The metadata will be a hashref with key C<version> (containing
85	the mandatory version header entries).
86
87	All other headers are represented by arrayrefs (they can be repeated).
88
89	Since this is confusing, here is a rather verbose example of a parsed
90	manifest:
91
92	(
93	version => { revision => 1 },
94	document => [
95	{
96	"info.format" => "image/jpeg",
97	name => "background.jpg",
98	"redirect.target" => "freenet:CHK\@ZcagI,ra726bSw"
99	},
100	{
101	"info.format" => "text/html",
102	name => ".next",
103	"redirect.target" => "freenet:SSK\@ilUPAgM/TFEE/3"
104	},
105	{
106	"info.format" => "text/html",
107	"redirect.target" => "freenet:CHK\@8M8Po8ucwI,8xA"
108	}
109	]
110	)
111
112	=cut
113
114	sub parse_metadata {
115	my $meta;
116
117	my $data = shift;
118	if ($data =~ /^Version\015?\012/gc) {
119	my $hdr = $meta->{version} = {};
120
121	for (;;) {
122	while ($data =~ /\G([^=\015\012]+)=([^\015\012]*)\015?\012/gc) {
123	my ($k, $v) = ($1, $2);
124	$hdr->{tolc $k} = $v;
125	}
126
127	if ($data =~ /\GEndPart\015?\012/gc) {
128	} elsif ($data =~ /\GEnd\015?\012/gc) {
129	last;
130	} elsif ($data =~ /\G([A-Za-z0-9.\-]+)\015?\012/gcs) {
131	push @{$meta->{tolc $1}}, $hdr = {};
132	} elsif ($data =~ /\G(.*)/gcs) {
133	die "metadata format error ($1)";
134	}
135	}
136	}
137
138	#$meta->{tail} = substr $data, pos $data;
139
140	$meta;
141	}	115	}
142		116
143	=item $fcp = new Net::FCP [host => $host][, port => $port]	117	=item $fcp = new Net::FCP [host => $host][, port => $port][, progress => \&cb]
144		118
145	Create a new virtual FCP connection to the given host and port (default	119	Create a new virtual FCP connection to the given host and port (default
146	127.0.0.1:8481, or the environment variables C<FREDHOST> and C<FREDPORT>).	120	127.0.0.1:8481, or the environment variables C<FREDHOST> and C<FREDPORT>).
147		121
148	Connections are virtual because no persistent physical connection is	122	Connections are virtual because no persistent physical connection is
149	established. However, the existance of the node is checked by executing a	123	established.
150	C<ClientHello> transaction.	124
		125	You can install a progress callback that is being called with the Net::FCP
		126	object, a txn object, the type of the transaction and the attributes. Use
		127	it like this:
		128
		129	sub progress_cb {
		130	my ($self, $txn, $type, $attr) = @_;
		131
		132	warn "progress<$txn,$type," . (join ":", %$attr) . ">\n";
		133	}
151		134
152	=cut	135	=cut
153		136
154	sub new {	137	sub new {
155	my $class = shift;	138	my $class = shift;
156	my $self = bless { @_ }, $class;	139	my $self = bless { @_ }, $class;
157		140
158	$self->{host} \|\|= $ENV{FREDHOST} \|\| "127.0.0.1";	141	$self->{host} \|\|= $ENV{FREDHOST} \|\| "127.0.0.1";
159	$self->{port} \|\|= $ENV{FREDPORt} \|\| 8481;	142	$self->{port} \|\|= $ENV{FREDPORT} \|\| 8481;
160
161	$self->{nodehello} = $self->client_hello
162	or croak "unable to get nodehello from node\n";
163		143
164	$self;	144	$self;
165	}	145	}
166		146
167	sub progress {	147	sub progress {
168	my ($self, $txn, $type, $attr) = @_;	148	my ($self, $txn, $type, $attr) = @_;
169	warn "progress<$txn,$type," . (join ":", %$attr) . ">\n";
170	}
171		149
		150	$self->{progress}->($self, $txn, $type, $attr)
		151	if $self->{progress};
		152	}
		153
172	=item $txn = $fcp->txn(type => attr => val,...)	154	=item $txn = $fcp->txn (type => attr => val,...)
173		155
174	The low-level interface to transactions. Don't use it.	156	The low-level interface to transactions. Don't use it unless you have
		157	"special needs". Instead, use predefiend transactions like this:
		158
		159	The blocking case, no (visible) transactions involved:
		160
		161	my $nodehello = $fcp->client_hello;
		162
		163	A transaction used in a blocking fashion:
		164
		165	my $txn = $fcp->txn_client_hello;
		166	...
		167	my $nodehello = $txn->result;
		168
		169	Or shorter:
		170
		171	my $nodehello = $fcp->txn_client_hello->result;
		172
		173	Setting callbacks:
		174
		175	$fcp->txn_client_hello->cb(
		176	sub { my $nodehello => $_[0]->result }
		177	);
175		178
176	=cut	179	=cut
177		180
178	sub txn {	181	sub txn {
179	my ($self, $type, %attr) = @_;	182	my ($self, $type, %attr) = @_;
180		183
181	$type = touc $type;	184	$type = touc $type;
182		185
183	my $txn = "Net::FCP::Txn::$type"->new(fcp => $self, type => tolc $type, attr => \%attr);	186	my $txn = "Net::FCP::Txn::$type"->new (fcp => $self, type => tolc $type, attr => \%attr);
184		187
185	$txn;	188	$txn;
186	}	189	}
187		190
188	sub _txn($&) {	191	{ # transactions
		192
		193	my $txn = sub {
189	my ($name, $sub) = @_;	194	my ($name, $sub) = @_;
190	*{"$name\_txn"} = $sub;	195	*{"txn_$name"} = $sub;
191	*{$name} = sub { $sub->(@_)->result };	196	*{$name} = sub { $sub->(@_)->result };
192	}	197	};
193		198
194	=item $txn = $fcp->txn_client_hello	199	=item $txn = $fcp->txn_client_hello
195		200
196	=item $nodehello = $fcp->client_hello	201	=item $nodehello = $fcp->client_hello
197		202
…		…
203	protocol => "1.2",	208	protocol => "1.2",
204	}	209	}
205		210
206	=cut	211	=cut
207		212
208	_txn client_hello => sub {	213	$txn->(client_hello => sub {
209	my ($self) = @_;	214	my ($self) = @_;
210		215
211	$self->txn ("client_hello");	216	$self->txn ("client_hello");
212	};	217	});
213		218
214	=item $txn = $fcp->txn_client_info	219	=item $txn = $fcp->txn_client_info
215		220
216	=item $nodeinfo = $fcp->client_info	221	=item $nodeinfo = $fcp->client_info
217		222
…		…
241	routing_time => "a5",	246	routing_time => "a5",
242	}	247	}
243		248
244	=cut	249	=cut
245		250
246	_txn client_info => sub {	251	$txn->(client_info => sub {
247	my ($self) = @_;	252	my ($self) = @_;
248		253
249	$self->txn ("client_info");	254	$self->txn ("client_info");
250	};	255	});
251		256
252	=item $txn = $fcp->txn_generate_chk ($metadata, $data)	257	=item $txn = $fcp->txn_generate_chk ($metadata, $data[, $cipher])
253		258
254	=item $uri = $fcp->generate_chk ($metadata, $data)	259	=item $uri = $fcp->generate_chk ($metadata, $data[, $cipher])
255		260
256	Creates a new CHK, given the metadata and data. UNTESTED.	261	Calculates a CHK, given the metadata and data. C<$cipher> is either
		262	C<Rijndael> or C<Twofish>, with the latter being the default.
257		263
258	=cut	264	=cut
259		265
260	_txn generate_chk => sub {	266	$txn->(generate_chk => sub {
261	my ($self, $metadata, $data) = @_;	267	my ($self, $metadata, $data, $cipher) = @_;
262		268
263	$self->txn (generate_chk => data => "$data$metadata", metadata_length => length $metadata);	269	$metadata = Net::FCP::Metadata::build_metadata $metadata;
		270
		271	$self->txn (generate_chk =>
		272	data => "$metadata$data",
		273	metadata_length => xeh length $metadata,
		274	cipher => $cipher \|\| "Twofish");
264	};	275	});
265		276
266	=item $txn = $fcp->txn_generate_svk_pair	277	=item $txn = $fcp->txn_generate_svk_pair
267		278
268	=item ($public, $private) = @{ $fcp->generate_svk_pair }	279	=item ($public, $private) = @{ $fcp->generate_svk_pair }
269		280
270	Creates a new SVK pair. Returns an arrayref.	281	Creates a new SVK pair. Returns an arrayref with the public key, the
		282	private key and a crypto key, which is just additional entropy.
271		283
272	[	284	[
273	"hKs0-WDQA4pVZyMPKNFsK1zapWY",	285	"acLx4dux9fvvABH15Gk6~d3I-yw",
274	"ZnmvMITaTXBMFGl4~jrjuyWxOWg"	286	"cPoDkDMXDGSMM32plaPZDhJDxSs",
		287	"BH7LXCov0w51-y9i~BoB3g",
275	]	288	]
276		289
277	=cut	290	A private key (for inserting) can be constructed like this:
278		291
		292	SSK@<private_key>,<crypto_key>/<name>
		293
		294	It can be used to insert data. The corresponding public key looks like this:
		295
		296	SSK@<public_key>PAgM,<crypto_key>/<name>
		297
		298	Watch out for the C<PAgM>-part!
		299
		300	=cut
		301
279	_txn generate_svk_pair => sub {	302	$txn->(generate_svk_pair => sub {
280	my ($self) = @_;	303	my ($self) = @_;
281		304
282	$self->txn ("generate_svk_pair");	305	$self->txn ("generate_svk_pair");
283	};	306	});
284		307
285	=item $txn = $fcp->txn_insert_private_key ($private)	308	=item $txn = $fcp->txn_invert_private_key ($private)
286		309
287	=item $uri = $fcp->insert_private_key ($private)	310	=item $public = $fcp->invert_private_key ($private)
288		311
289	Inserts a private key. $private can be either an insert URI (must start	312	Inverts a private key (returns the public key). C<$private> can be either
290	with freenet:SSK@) or a raw private key (i.e. the private value you get back	313	an insert URI (must start with C<freenet:SSK@>) or a raw private key (i.e.
291	from C<generate_svk_pair>).	314	the private value you get back from C<generate_svk_pair>).
292		315
293	Returns the public key.	316	Returns the public key.
294		317
295	UNTESTED.
296
297	=cut	318	=cut
298		319
299	_txn insert_private_key => sub {	320	$txn->(invert_private_key => sub {
300	my ($self, $privkey) = @_;	321	my ($self, $privkey) = @_;
301		322
302	$self->txn (invert_private_key => private => $privkey);	323	$self->txn (invert_private_key => private => $privkey);
303	};	324	});
304		325
305	=item $txn = $fcp->txn_get_size ($uri)	326	=item $txn = $fcp->txn_get_size ($uri)
306		327
307	=item $length = $fcp->get_size ($uri)	328	=item $length = $fcp->get_size ($uri)
308		329
309	Finds and returns the size (rounded up to the nearest power of two) of the	330	Finds and returns the size (rounded up to the nearest power of two) of the
310	given document.	331	given document.
311		332
312	UNTESTED.
313
314	=cut	333	=cut
315		334
316	_txn get_size => sub {	335	$txn->(get_size => sub {
317	my ($self, $uri) = @_;	336	my ($self, $uri) = @_;
318		337
319	$self->txn (get_size => URI => $uri);	338	$self->txn (get_size => URI => $uri);
320	};	339	});
321		340
322	=item $txn = $fcp->txn_client_get ($uri [, $htl = 15 [, $removelocal = 0]])	341	=item $txn = $fcp->txn_client_get ($uri [, $htl = 15 [, $removelocal = 0]])
323		342
324	=item ($metadata, $data) = @{ $fcp->client_get ($uri, $htl, $removelocal)	343	=item ($metadata, $data) = @{ $fcp->client_get ($uri, $htl, $removelocal)
325		344
326	Fetches a (small, as it should fit into memory) file from	345	Fetches a (small, as it should fit into memory) key content block from
327	freenet. C<$meta> is the metadata (as returned by C<parse_metadata> or	346	freenet. C<$meta> is a C<Net::FCP::Metadata> object or C<undef>).
328	C<undef>).
329		347
330	Due to the overhead, a better method to download big files should be used.	348	The C<$uri> should begin with C<freenet:>, but the scheme is currently
		349	added, if missing.
331		350
332	my ($meta, $data) = @{	351	my ($meta, $data) = @{
333	$fcp->client_get (	352	$fcp->client_get (
334	"freenet:CHK@hdXaxkwZ9rA8-SidT0AN-bniQlgPAwI,XdCDmBuGsd-ulqbLnZ8v~w"	353	"freenet:CHK@hdXaxkwZ9rA8-SidT0AN-bniQlgPAwI,XdCDmBuGsd-ulqbLnZ8v~w"
335	)	354	)
336	};	355	};
337		356
338	=cut	357	=cut
339		358
340	_txn client_get => sub {	359	$txn->(client_get => sub {
341	my ($self, $uri, $htl, $removelocal) = @_;	360	my ($self, $uri, $htl, $removelocal) = @_;
342		361
343	$self->txn (client_get => URI => $uri, hops_to_live => ($htl \|\| 15), remove_local => $removelocal*1);	362	$uri =~ s/^freenet://; $uri = "freenet:$uri";
		363
		364	$self->txn (client_get => URI => $uri, hops_to_live => xeh (defined $htl ? $htl : 15),
		365	remove_local_key => $removelocal ? "true" : "false");
344	};	366	});
345		367
346	=item MISSING: ClientPut	368	=item $txn = $fcp->txn_client_put ($uri, $metadata, $data, $htl, $removelocal)
		369
		370	=item my $uri = $fcp->client_put ($uri, $metadata, $data, $htl, $removelocal);
		371
		372	Insert a new key. If the client is inserting a CHK, the URI may be
		373	abbreviated as just CHK@. In this case, the node will calculate the
		374	CHK. If the key is a private SSK key, the node will calculcate the public
		375	key and the resulting public URI.
		376
		377	C<$meta> can be a hash reference (same format as returned by
		378	C<Net::FCP::parse_metadata>) or a string.
		379
		380	The result is an arrayref with the keys C<uri>, C<public_key> and C<private_key>.
		381
		382	=cut
		383
		384	$txn->(client_put => sub {
		385	my ($self, $uri, $metadata, $data, $htl, $removelocal) = @_;
		386
		387	$metadata = Net::FCP::Metadata::build_metadata $metadata;
		388	$uri =~ s/^freenet://; $uri = "freenet:$uri";
		389
		390	$self->txn (client_put => URI => $uri,
		391	hops_to_live => xeh (defined $htl ? $htl : 15),
		392	remove_local_key => $removelocal ? "true" : "false",
		393	data => "$metadata$data", metadata_length => xeh length $metadata);
		394	});
		395
		396	} # transactions
347		397
348	=back	398	=back
349		399
350	=head2 THE Net::FCP::Txn CLASS	400	=head2 THE Net::FCP::Txn CLASS
351		401
352	All requests (or transactions) are executed in a asynchroneous way (LIE:	402	All requests (or transactions) are executed in a asynchronous way. For
353	uploads are blocking). For each request, a C<Net::FCP::Txn> object is	403	each request, a C<Net::FCP::Txn> object is created (worse: a tcp
354	created (worse: a tcp connection is created, too).	404	connection is created, too).
355		405
356	For each request there is actually a different subclass (and it's possible	406	For each request there is actually a different subclass (and it's possible
357	to subclass these, although of course not documented).	407	to subclass these, although of course not documented).
358		408
359	The most interesting method is C<result>.	409	The most interesting method is C<result>.
…		…
361	=over 4	411	=over 4
362		412
363	=cut	413	=cut
364		414
365	package Net::FCP::Txn;	415	package Net::FCP::Txn;
		416
		417	use Fcntl;
		418	use Socket;
366		419
367	=item new arg => val,...	420	=item new arg => val,...
368		421
369	Creates a new C<Net::FCP::Txn> object. Not normally used.	422	Creates a new C<Net::FCP::Txn> object. Not normally used.
370		423
…		…
372		425
373	sub new {	426	sub new {
374	my $class = shift;	427	my $class = shift;
375	my $self = bless { @_ }, $class;	428	my $self = bless { @_ }, $class;
376		429
		430	$self->{signal} = $EVENT->new_signal;
		431
		432	$self->{fcp}{txn}{$self} = $self;
		433
377	my $attr = "";	434	my $attr = "";
378	my $data = delete $self->{attr}{data};	435	my $data = delete $self->{attr}{data};
379		436
380	while (my ($k, $v) = each %{$self->{attr}}) {	437	while (my ($k, $v) = each %{$self->{attr}}) {
381	$attr .= (Net::FCP::touc $k) . "=$v\012"	438	$attr .= (Net::FCP::touc $k) . "=$v\012"
382	}	439	}
383		440
384	if (defined $data) {	441	if (defined $data) {
385	$attr .= "DataLength=" . (length $data) . "\012";	442	$attr .= sprintf "DataLength=%x\012", length $data;
386	$data = "Data\012$data";	443	$data = "Data\012$data";
387	} else {	444	} else {
388	$data = "EndMessage\012";	445	$data = "EndMessage\012";
389	}	446	}
390		447
391	my $fh = new IO::Socket::INET	448	socket my $fh, PF_INET, SOCK_STREAM, 0
392	PeerHost => $self->{fcp}{host},	449	or Carp::croak "unable to create new tcp socket: $!";
393	PeerPort => $self->{fcp}{port}
394	or Carp::croak "FCP::txn: unable to connect to $self->{fcp}{host}:$self->{fcp}{port}: $!\n";
395
396	binmode $fh, ":raw";	450	binmode $fh, ":raw";
		451	fcntl $fh, F_SETFL, O_NONBLOCK;
		452	connect $fh, (sockaddr_in $self->{fcp}{port}, inet_aton $self->{fcp}{host})
		453	and !$!{EWOULDBLOCK}
		454	and !$!{EINPROGRESS}
		455	and Carp::croak "FCP::txn: unable to connect to $self->{fcp}{host}:$self->{fcp}{port}: $!\n";
397		456
398	if (0) {	457	$self->{sbuf} =
399	print	458	"\x00\x00\x00\x02"
400	Net::FCP::touc $self->{type}, "\012",
401	$attr,
402	$data, "\012";
403	}
404
405	print $fh
406	"\x00\x00", "\x00\x02", # SESSID, PRESID
407	Net::FCP::touc $self->{type}, "\012",	459	. (Net::FCP::touc $self->{type})
408	$attr,	460	. "\012$attr$data";
409	$data;
410		461
411	#$fh->shutdown (1); # freenet buggy?, well, it's java...	462	#shutdown $fh, 1; # freenet buggy?, well, it's java...
412		463
413	$self->{fh} = $fh;	464	$self->{fh} = $fh;
414		465
415	$EVENT->reg_r_cb ($self);	466	$self->{w} = $EVENT->new_from_fh ($fh)->cb(sub { $self->fh_ready_w })->poll(0, 1, 1);
416		467
417	$self;	468	$self;
418	}	469	}
419		470
		471	=item $txn = $txn->cb ($coderef)
		472
		473	Sets a callback to be called when the request is finished. The coderef
		474	will be called with the txn as it's sole argument, so it has to call
		475	C<result> itself.
		476
		477	Returns the txn object, useful for chaining.
		478
		479	Example:
		480
		481	$fcp->txn_client_get ("freenet:CHK....")
		482	->userdata ("ehrm")
		483	->cb(sub {
		484	my $data = shift->result;
		485	});
		486
		487	=cut
		488
		489	sub cb($$) {
		490	my ($self, $cb) = @_;
		491	$self->{cb} = $cb;
		492	$self;
		493	}
		494
420	=item $userdata = $txn->userdata ([$userdata])	495	=item $txn = $txn->userdata ([$userdata])
421		496
422	Get and/or set user-specific data. This is useful in progress callbacks.	497	Set user-specific data. This is useful in progress callbacks. The data can be accessed
		498	using C<< $txn->{userdata} >>.
423		499
424	=cut	500	Returns the txn object, useful for chaining.
425		501
		502	=cut
		503
426	sub userdata($;$) {	504	sub userdata($$) {
427	my ($self, $data) = @_;	505	my ($self, $data) = @_;
428	$self->{userdata} = $data if @_ >= 2;	506	$self->{userdata} = $data;
429	$self->{userdata};	507	$self;
430	}	508	}
431		509
		510	=item $txn->cancel (%attr)
		511
		512	Cancels the operation with a C<cancel> exception anf the given attributes
		513	(consider at least giving the attribute C<reason>).
		514
		515	UNTESTED.
		516
		517	=cut
		518
		519	sub cancel {
		520	my ($self, %attr) = @_;
		521	$self->throw (Net::FCP::Exception->new (cancel => { %attr }));
		522	$self->set_result;
		523	$self->eof;
		524	}
		525
432	sub fh_ready {	526	sub fh_ready_w {
		527	my ($self) = @_;
		528
		529	my $len = syswrite $self->{fh}, $self->{sbuf};
		530
		531	if ($len > 0) {
		532	substr $self->{sbuf}, 0, $len, "";
		533	unless (length $self->{sbuf}) {
		534	fcntl $self->{fh}, F_SETFL, 0;
		535	$self->{w}->cb(sub { $self->fh_ready_r })->poll (1, 0, 1);
		536	}
		537	} elsif (defined $len) {
		538	$self->throw (Net::FCP::Exception->new (network_error => { reason => "unexpected end of file while writing" }));
		539	} else {
		540	$self->throw (Net::FCP::Exception->new (network_error => { reason => "$!" }));
		541	}
		542	}
		543
		544	sub fh_ready_r {
433	my ($self) = @_;	545	my ($self) = @_;
434		546
435	if (sysread $self->{fh}, $self->{buf}, 65536, length $self->{buf}) {	547	if (sysread $self->{fh}, $self->{buf}, 65536, length $self->{buf}) {
436	for (;;) {	548	for (;;) {
437	if ($self->{datalen}) {	549	if ($self->{datalen}) {
		550	#warn "expecting new datachunk $self->{datalen}, got ".(length $self->{buf})."\n";#d#
438	if (length $self->{buf} >= $self->{datalen}) {	551	if (length $self->{buf} >= $self->{datalen}) {
439	$self->rcv_data (substr $self->{buf}, 0, $self->{datalen}, "");	552	$self->rcv_data (substr $self->{buf}, 0, delete $self->{datalen}, "");
440	} else {	553	} else {
441	last;	554	last;
442	}	555	}
443	} elsif ($self->{buf} =~ s/^DataChunk\015?\012Length=([0-9a-fA-F]+)\015?\012Data\015?\012//) {	556	} elsif ($self->{buf} =~ s/^DataChunk\015?\012Length=([0-9a-fA-F]+)\015?\012Data\015?\012//) {
444	$self->{datalen} = hex $1;	557	$self->{datalen} = hex $1;
		558	#warn "expecting new datachunk $self->{datalen}\n";#d#
445	} elsif ($self->{buf} =~ s/^([a-zA-Z]+)\015?\012(?:(.+?)\015?\012)?EndMessage\015?\012//s) {	559	} elsif ($self->{buf} =~ s/^([a-zA-Z]+)\015?\012(?:(.+?)\015?\012)?EndMessage\015?\012//s) {
446	$self->rcv ($1, {	560	$self->rcv ($1, {
447	map { my ($a, $b) = split /=/, $_, 2; ((Net::FCP::tolc $a), $b) }	561	map { my ($a, $b) = split /=/, $_, 2; ((Net::FCP::tolc $a), $b) }
448	split /\015?\012/, $2	562	split /\015?\012/, $2
449	});	563	});
450	} else {	564	} else {
451	last;	565	last;
452	}	566	}
453	}	567	}
454	} else {	568	} else {
455	$EVENT->unreg_r_cb ($self);
456	delete $self->{fh};
457	$self->eof;	569	$self->eof;
458	}	570	}
459	}
460
461	sub rcv_data {
462	my ($self, $chunk) = @_;
463
464	$self->{data} .= $chunk;
465
466	$self->progress ("data", { chunk => length $chunk, total => length $self->{data}, end => $self->{datalength} });
467	}	571	}
468		572
469	sub rcv {	573	sub rcv {
470	my ($self, $type, $attr) = @_;	574	my ($self, $type, $attr) = @_;
471		575
…		…
478	} else {	582	} else {
479	warn "received unexpected reply type '$type' for '$self->{type}', ignoring\n";	583	warn "received unexpected reply type '$type' for '$self->{type}', ignoring\n";
480	}	584	}
481	}	585	}
482		586
		587	# used as a default exception thrower
		588	sub rcv_throw_exception {
		589	my ($self, $attr, $type) = @_;
		590	$self->throw (Net::FCP::Exception->new ($type, $attr));
		591	}
		592
		593	*rcv_failed = \&Net::FCP::Txn::rcv_throw_exception;
		594	*rcv_format_error = \&Net::FCP::Txn::rcv_throw_exception;
		595
483	sub throw {	596	sub throw {
484	my ($self, $exc) = @_;	597	my ($self, $exc) = @_;
485		598
486	$self->{exception} = $exc;	599	$self->{exception} = $exc;
487	$self->set_result (1);	600	$self->set_result;
		601	$self->eof; # must be last to avoid loops
488	}	602	}
489		603
490	sub set_result {	604	sub set_result {
491	my ($self, $result) = @_;	605	my ($self, $result) = @_;
492		606
493	$self->{result} = $result unless exists $self->{result};	607	unless (exists $self->{result}) {
		608	$self->{result} = $result;
		609	$self->{cb}->($self) if exists $self->{cb};
		610	$self->{signal}->send;
		611	}
494	}	612	}
495		613
496	sub eof {	614	sub eof {
497	my ($self) = @_;	615	my ($self) = @_;
498	$self->set_result;	616
		617	delete $self->{w};
		618	delete $self->{fh};
		619
		620	delete $self->{fcp}{txn}{$self};
		621
		622	unless (exists $self->{result}) {
		623	$self->throw (Net::FCP::Exception->new (short_data => {
		624	reason => "unexpected eof or internal node error",
		625	}));
		626	}
499	}	627	}
500		628
501	sub progress {	629	sub progress {
502	my ($self, $type, $attr) = @_;	630	my ($self, $type, $attr) = @_;
		631
503	$self->{fcp}->progress ($self, $type, $attr);	632	$self->{fcp}->progress ($self, $type, $attr);
504	}	633	}
505		634
506	=item $result = $txn->result	635	=item $result = $txn->result
507		636
508	Waits until a result is available and then returns it.	637	Waits until a result is available and then returns it.
509		638
510	This waiting is (depending on your event model) not very efficient, as it	639	This waiting is (depending on your event model) not very efficient, as it
511	is done outside the "mainloop".	640	is done outside the "mainloop". The biggest problem, however, is that it's
		641	blocking one thread of execution. Try to use the callback mechanism, if
		642	possible, and call result from within the callback (or after is has been
		643	run), as then no waiting is necessary.
512		644
513	=cut	645	=cut
514		646
515	sub result {	647	sub result {
516	my ($self) = @_;	648	my ($self) = @_;
517		649
518	$EVENT->wait_event while !exists $self->{result};	650	$self->{signal}->wait while !exists $self->{result};
519		651
520	die $self->{exception} if $self->{exception};	652	die $self->{exception} if $self->{exception};
521		653
522	return $self->{result};	654	return $self->{result};
523	}
524
525	sub DESTROY {
526	$EVENT->unreg_r_cb ($_[0]);
527	#$EVENT->unreg_w_cb ($_[0]);
528	}	655	}
529		656
530	package Net::FCP::Txn::ClientHello;	657	package Net::FCP::Txn::ClientHello;
531		658
532	use base Net::FCP::Txn;	659	use base Net::FCP::Txn;
…		…
552	use base Net::FCP::Txn;	679	use base Net::FCP::Txn;
553		680
554	sub rcv_success {	681	sub rcv_success {
555	my ($self, $attr) = @_;	682	my ($self, $attr) = @_;
556		683
557	$self->set_result ($attr);	684	$self->set_result ($attr->{uri});
558	}	685	}
559		686
560	package Net::FCP::Txn::GenerateSVKPair;	687	package Net::FCP::Txn::GenerateSVKPair;
561		688
562	use base Net::FCP::Txn;	689	use base Net::FCP::Txn;
563		690
564	sub rcv_success {	691	sub rcv_success {
565	my ($self, $attr) = @_;	692	my ($self, $attr) = @_;
566
567	$self->set_result ([$attr->{PublicKey}, $attr->{PrivateKey}]);	693	$self->set_result ([$attr->{public_key}, $attr->{private_key}, $attr->{crypto_key}]);
568	}	694	}
569		695
570	package Net::FCP::Txn::InvertPrivateKey;	696	package Net::FCP::Txn::InvertPrivateKey;
571		697
572	use base Net::FCP::Txn;	698	use base Net::FCP::Txn;
573		699
574	sub rcv_success {	700	sub rcv_success {
575	my ($self, $attr) = @_;	701	my ($self, $attr) = @_;
576
577	$self->set_result ($attr->{PublicKey});	702	$self->set_result ($attr->{public_key});
578	}	703	}
579		704
580	package Net::FCP::Txn::GetSize;	705	package Net::FCP::Txn::GetSize;
581		706
582	use base Net::FCP::Txn;	707	use base Net::FCP::Txn;
583		708
584	sub rcv_success {	709	sub rcv_success {
585	my ($self, $attr) = @_;	710	my ($self, $attr) = @_;
586
587	$self->set_result ($attr->{Length});	711	$self->set_result (hex $attr->{length});
		712	}
		713
		714	package Net::FCP::Txn::GetPut;
		715
		716	# base class for get and put
		717
		718	use base Net::FCP::Txn;
		719
		720	*rcv_uri_error = \&Net::FCP::Txn::rcv_throw_exception;
		721	*rcv_route_not_found = \&Net::FCP::Txn::rcv_throw_exception;
		722
		723	sub rcv_restarted {
		724	my ($self, $attr, $type) = @_;
		725
		726	delete $self->{datalength};
		727	delete $self->{metalength};
		728	delete $self->{data};
		729
		730	$self->progress ($type, $attr);
588	}	731	}
589		732
590	package Net::FCP::Txn::ClientGet;	733	package Net::FCP::Txn::ClientGet;
591		734
592	use base Net::FCP::Txn;	735	use base Net::FCP::Txn::GetPut;
		736
		737	*rcv_data_not_found = \&Net::FCP::Txn::rcv_throw_exception;
		738
		739	sub rcv_data {
		740	my ($self, $chunk) = @_;
		741
		742	$self->{data} .= $chunk;
		743
		744	$self->progress ("data", { chunk => length $chunk, received => length $self->{data}, total => $self->{datalength} });
		745
		746	if ($self->{datalength} == length $self->{data}) {
		747	my $data = delete $self->{data};
		748	my $meta = new Net::FCP::Metadata (substr $data, 0, $self->{metalength}, "");
		749
		750	$self->set_result ([$meta, $data]);
		751	$self->eof;
		752	}
		753	}
593		754
594	sub rcv_data_found {	755	sub rcv_data_found {
595	my ($self, $attr, $type) = @_;	756	my ($self, $attr, $type) = @_;
596		757
597	$self->progress ($type, $attr);	758	$self->progress ($type, $attr);
598		759
599	$self->{datalength} = hex $attr->{data_length};	760	$self->{datalength} = hex $attr->{data_length};
600	$self->{metalength} = hex $attr->{metadata_length};	761	$self->{metalength} = hex $attr->{metadata_length};
601	}	762	}
602		763
603	sub rcv_route_not_found {	764	package Net::FCP::Txn::ClientPut;
604	my ($self, $attr, $type) = @_;
605		765
606	$self->throw (new Net::FCP::Exception $type, $attr);	766	use base Net::FCP::Txn::GetPut;
607	}
608		767
609	sub rcv_data_not_found {	768	*rcv_size_error = \&Net::FCP::Txn::rcv_throw_exception;
610	my ($self, $attr, $type) = @_;
611		769
612	$self->throw (new Net::FCP::Exception $type, $attr);	770	sub rcv_pending {
613	}
614
615	sub rcv_format_error {
616	my ($self, $attr, $type) = @_;
617
618	$self->throw (new Net::FCP::Exception $type, $attr);
619	}
620
621	sub rcv_restarted {
622	my ($self, $attr, $type) = @_;	771	my ($self, $attr, $type) = @_;
623	$self->progress ($type, $attr);	772	$self->progress ($type, $attr);
624	}	773	}
625		774
626	sub eof {	775	sub rcv_success {
627	my ($self) = @_;	776	my ($self, $attr, $type) = @_;
628
629	my $data = delete $self->{data};
630	my $meta = Net::FCP::parse_metadata substr $data, 0, $self->{metalength}, "";
631
632	$self->set_result ([$meta, $data]);	777	$self->set_result ($attr);
633	}	778	}
		779
		780	sub rcv_key_collision {
		781	my ($self, $attr, $type) = @_;
		782	$self->set_result ({ key_collision => 1, %$attr });
		783	}
		784
		785	=back
		786
		787	=head2 The Net::FCP::Exception CLASS
		788
		789	Any unexpected (non-standard) responses that make it impossible to return
		790	the advertised result will result in an exception being thrown when the
		791	C<result> method is called.
		792
		793	These exceptions are represented by objects of this class.
		794
		795	=over 4
		796
		797	=cut
634		798
635	package Net::FCP::Exception;	799	package Net::FCP::Exception;
636		800
637	use overload	801	use overload
638	'""' => sub {	802	'""' => sub {
639	"Net::FCP::Exception<<$_[0][0]," . (join ":", %{$_[0][1]}) . ">>\n";	803	"Net::FCP::Exception<<$_[0][0]," . (join ":", %{$_[0][1]}) . ">>";
640	};	804	};
		805
		806	=item $exc = new Net::FCP::Exception $type, \%attr
		807
		808	Create a new exception object of the given type (a string like
		809	C<route_not_found>), and a hashref containing additional attributes
		810	(usually the attributes of the message causing the exception).
		811
		812	=cut
641		813
642	sub new {	814	sub new {
643	my ($class, $type, $attr) = @_;	815	my ($class, $type, $attr) = @_;
644		816
645	bless [$type, { %$attr }], $class;	817	bless [Net::FCP::tolc $type, { %$attr }], $class;
		818	}
		819
		820	=item $exc->type([$type])
		821
		822	With no arguments, returns the exception type. Otherwise a boolean
		823	indicating wether the exception is of the given type is returned.
		824
		825	=cut
		826
		827	sub type {
		828	my ($self, $type) = @_;
		829
		830	@_ >= 2
		831	? $self->[0] eq $type
		832	: $self->[0];
		833	}
		834
		835	=item $exc->attr([$attr])
		836
		837	With no arguments, returns the attributes. Otherwise the named attribute
		838	value is returned.
		839
		840	=cut
		841
		842	sub attr {
		843	my ($self, $attr) = @_;
		844
		845	@_ >= 2
		846	? $self->[1]{$attr}
		847	: $self->[1];
646	}	848	}
647		849
648	=back	850	=back
649		851
650	=head1 SEE ALSO	852	=head1 SEE ALSO
…		…
658	Marc Lehmann <pcg@goof.com>	860	Marc Lehmann <pcg@goof.com>
659	http://www.goof.com/pcg/marc/	861	http://www.goof.com/pcg/marc/
660		862
661	=cut	863	=cut
662		864
		865	package Net::FCP::Event::Auto;
		866
		867	my @models = (
		868	[Coro => Coro::Event::],
		869	[Event => Event::],
		870	[Glib => Glib::],
		871	[Tk => Tk::],
		872	);
		873
		874	sub AUTOLOAD {
		875	$AUTOLOAD =~ s/.*://;
		876
		877	for (@models) {
		878	my ($model, $package) = @$_;
		879	if (defined ${"$package\::VERSION"}) {
		880	$EVENT = "Net::FCP::Event::$model";
		881	eval "require $EVENT"; die if $@;
		882	goto &{"$EVENT\::$AUTOLOAD"};
		883	}
		884	}
		885
		886	for (@models) {
		887	my ($model, $package) = @$_;
		888	$EVENT = "Net::FCP::Event::$model";
		889	if (eval "require $EVENT") {
		890	goto &{"$EVENT\::$AUTOLOAD"};
		891	}
		892	}
		893
		894	die "No event module selected for Net::FCP and autodetect failed. Install any of these: Coro, Event, Glib or Tk.";
		895	}
		896
663	1;	897	1;
664		898

Diff Legend

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

Comparing cvsroot/Net-FCP/FCP.pm (file contents): Revision 1.9 by root, Tue Sep 9 06:13:18 2003 UTC vs. Revision 1.30 by root, Fri May 14 16:12:26 2004 UTC

Diff Legend

Comparing cvsroot/Net-FCP/FCP.pm (file contents):
Revision 1.9 by root, Tue Sep 9 06:13:18 2003 UTC vs.
Revision 1.30 by root, Fri May 14 16:12:26 2004 UTC