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

Comparing Net-FCP/FCP.pm (file contents):
Revision 1.13 by root, Wed Sep 10 05:06:16 2003 UTC vs.
Revision 1.29 by root, Thu May 13 21:43:16 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		76
50	$VERSION = 0.05;	77	$VERSION = 0.6;
51		78
52	no warnings;	79	no warnings;
53		80
54	our $EVENT = Net::FCP::Event::Auto::;	81	our $EVENT = Net::FCP::Event::Auto::;
55	$EVENT = Net::FCP::Event::Event;#d#
56		82
57	sub import {	83	sub import {
58	shift;	84	shift;
59		85
60	for (@_) {	86	for (@_) {
61	if (/^event=(\w+)$/) {	87	if (/^event=(\w+)$/) {
62	$EVENT = "Net::FCP::Event::$1";	88	$EVENT = "Net::FCP::Event::$1";
		89	eval "require $EVENT";
63	}	90	}
64	}	91	}
65	eval "require $EVENT";
66	die $@ if $@;	92	die $@ if $@;
67	}	93	}
68		94
69	sub touc($) {	95	sub touc($) {
70	local $_ = shift;	96	local $_ = shift;
…		…
73	$_;	99	$_;
74	}	100	}
75		101
76	sub tolc($) {	102	sub tolc($) {
77	local $_ = shift;	103	local $_ = shift;
		104	1 while s/(SVK\|CHK\|URI)([^_])/$1\_$2/i;
		105	1 while s/([^_])(SVK\|CHK\|URI)/$1\_$2/i;
78	s/(?<=[a-z])(?=[A-Z])/_/g;	106	s/(?<=[a-z])(?=[A-Z])/_/g;
79	lc $_;	107	lc $_;
80	}	108	}
81		109
		110	# the opposite of hex
		111	sub xeh($) {
		112	sprintf "%x", $_[0];
		113	}
		114
82	=item $meta = Net::FCP::parse_metadata $string	115	=item $meta = Net::FCP::parse_metadata $string
83		116
84	Parse a metadata string and return it.	117	Parse a metadata string and return it.
85		118
86	The metadata will be a hashref with key C<version> (containing	119	The metadata will be a hashref with key C<version> (containing the
87	the mandatory version header entries).	120	mandatory version header entries) and key C<raw> containing the original
		121	metadata string.
88		122
89	All other headers are represented by arrayrefs (they can be repeated).	123	All other headers are represented by arrayrefs (they can be repeated).
90		124
91	Since this is confusing, here is a rather verbose example of a parsed	125	Since this description is confusing, here is a rather verbose example of a
92	manifest:	126	parsed manifest:
93		127
94	(	128	(
		129	raw => "Version...",
95	version => { revision => 1 },	130	version => { revision => 1 },
96	document => [	131	document => [
97	{	132	{
98	"info.format" => "image/jpeg",	133	info => { format" => "image/jpeg" },
99	name => "background.jpg",	134	name => "background.jpg",
100	"redirect.target" => "freenet:CHK\@ZcagI,ra726bSw"	135	redirect => { target => "freenet:CHK\@ZcagI,ra726bSw" },
101	},	136	},
102	{	137	{
103	"info.format" => "text/html",	138	info => { format" => "text/html" },
104	name => ".next",	139	name => ".next",
105	"redirect.target" => "freenet:SSK\@ilUPAgM/TFEE/3"	140	redirect => { target => "freenet:SSK\@ilUPAgM/TFEE/3" },
106	},	141	},
107	{	142	{
108	"info.format" => "text/html",	143	info => { format" => "text/html" },
109	"redirect.target" => "freenet:CHK\@8M8Po8ucwI,8xA"	144	redirect => { target => "freenet:CHK\@8M8Po8ucwI,8xA" },
110	}	145	}
111	]	146	]
112	)	147	)
113		148
114	=cut	149	=cut
115		150
116	sub parse_metadata {	151	sub parse_metadata {
117	my $meta;
118
119	my $data = shift;	152	my $data = shift;
		153	my $meta = { raw => $data };
		154
120	if ($data =~ /^Version\015?\012/gc) {	155	if ($data =~ /^Version\015?\012/gc) {
121	my $hdr = $meta->{version} = {};	156	my $hdr = $meta->{version} = {};
122		157
123	for (;;) {	158	for (;;) {
124	while ($data =~ /\G([^=\015\012]+)=([^\015\012]*)\015?\012/gc) {	159	while ($data =~ /\G([^=\015\012]+)=([^\015\012]*)\015?\012/gc) {
125	my ($k, $v) = ($1, $2);	160	my ($k, $v) = ($1, $2);
126	my @p = split /\./, tolc $k, 3;	161	my @p = split /\./, tolc $k, 3;
127		162
128	$hdr->{$p[0]} = $v if @p == 1; # lamest code I ever wrote	163	$hdr->{$p[0]} = $v if @p == 1; # lamest code I ever wrote
129	$hdr->{$p[0]}{$p[1]} = $v if @p == 2;	164	$hdr->{$p[0]}{$p[1]} = $v if @p == 2;
130	$hdr->{$p[0]}{$p[1]}{$p[3]} = $v if @p == 3;	165	$hdr->{$p[0]}{$p[1]}{$p[2]} = $v if @p == 3;
131	die "FATAL: 4+ dot metadata" if @p >= 4;	166	die "FATAL: 4+ dot metadata" if @p >= 4;
132	}	167	}
133		168
134	if ($data =~ /\GEndPart\015?\012/gc) {	169	if ($data =~ /\GEndPart\015?\012/gc) {
135	# nop	170	# nop
136	} elsif ($data =~ /\GEnd\015?\012/gc) {	171	} elsif ($data =~ /\GEnd(\015?\012\|$)/gc) {
137	last;	172	last;
138	} elsif ($data =~ /\G([A-Za-z0-9.\-]+)\015?\012/gcs) {	173	} elsif ($data =~ /\G([A-Za-z0-9.\-]+)\015?\012/gcs) {
139	push @{$meta->{tolc $1}}, $hdr = {};	174	push @{$meta->{tolc $1}}, $hdr = {};
140	} elsif ($data =~ /\G(.*)/gcs) {	175	} elsif ($data =~ /\G(.*)/gcs) {
		176	print STDERR "metadata format error ($1), please report this string: <<$data>>";
141	die "metadata format error ($1)";	177	die "metadata format error";
142	}	178	}
143	}	179	}
144	}	180	}
145		181
146	#$meta->{tail} = substr $data, pos $data;	182	#$meta->{tail} = substr $data, pos $data;
147		183
148	$meta;	184	$meta;
149	}	185	}
150		186
		187	=item $string = Net::FCP::build_metadata $meta
		188
		189	Takes a hash reference as returned by C<Net::FCP::parse_metadata> and
		190	returns the corresponding string form. If a string is given, it's returned
		191	as is.
		192
		193	=cut
		194
		195	sub build_metadata_subhash($$$) {
		196	my ($prefix, $level, $hash) = @_;
		197
		198	join "",
		199	map
		200	ref $hash->{$_} ? build_metadata_subhash ($prefix . (Net::FCP::touc $_) . ".", $level + 1, $hash->{$_})
		201	: $prefix . ($level > 1 ? $_ : Net::FCP::touc $_) . "=" . $hash->{$_} . "\n",
		202	keys %$hash;
		203	}
		204
		205	sub build_metadata_hash($$) {
		206	my ($header, $hash) = @_;
		207
		208	if (ref $hash eq ARRAY::) {
		209	join "", map build_metadata_hash ($header, $_), @$hash
		210	} else {
		211	(Net::FCP::touc $header) . "\n"
		212	. (build_metadata_subhash "", 0, $hash)
		213	. "EndPart\n";
		214	}
		215	}
		216
		217	sub build_metadata($) {
		218	my ($meta) = @_;
		219
		220	return $meta unless ref $meta;
		221
		222	$meta = { %$meta };
		223
		224	delete $meta->{raw};
		225
		226	my $res =
		227	(build_metadata_hash version => delete $meta->{version})
		228	. (join "", map +(build_metadata_hash $_, $meta->{$_}), keys %$meta);
		229
		230	substr $res, 0, -5; # get rid of "Part". Broken Syntax....
		231	}
		232
		233
151	=item $fcp = new Net::FCP [host => $host][, port => $port]	234	=item $fcp = new Net::FCP [host => $host][, port => $port][, progress => \&cb]
152		235
153	Create a new virtual FCP connection to the given host and port (default	236	Create a new virtual FCP connection to the given host and port (default
154	127.0.0.1:8481, or the environment variables C<FREDHOST> and C<FREDPORT>).	237	127.0.0.1:8481, or the environment variables C<FREDHOST> and C<FREDPORT>).
155		238
156	Connections are virtual because no persistent physical connection is	239	Connections are virtual because no persistent physical connection is
		240	established.
		241
		242	You can install a progress callback that is being called with the Net::FCP
		243	object, a txn object, the type of the transaction and the attributes. Use
		244	it like this:
		245
		246	sub progress_cb {
		247	my ($self, $txn, $type, $attr) = @_;
		248
		249	warn "progress<$txn,$type," . (join ":", %$attr) . ">\n";
		250	}
		251
		252	=begin comment
		253
157	established. However, the existance of the node is checked by executing a	254	However, the existance of the node is checked by executing a
158	C<ClientHello> transaction.	255	C<ClientHello> transaction.
		256
		257	=end
159		258
160	=cut	259	=cut
161		260
162	sub new {	261	sub new {
163	my $class = shift;	262	my $class = shift;
…		…
172	$self;	271	$self;
173	}	272	}
174		273
175	sub progress {	274	sub progress {
176	my ($self, $txn, $type, $attr) = @_;	275	my ($self, $txn, $type, $attr) = @_;
177	warn "progress<$txn,$type," . (join ":", %$attr) . ">\n";	276
		277	$self->{progress}->($self, $txn, $type, $attr)
		278	if $self->{progress};
178	}	279	}
179		280
180	=item $txn = $fcp->txn(type => attr => val,...)	281	=item $txn = $fcp->txn(type => attr => val,...)
181		282
182	The low-level interface to transactions. Don't use it.	283	The low-level interface to transactions. Don't use it.
…		…
208	sub txn {	309	sub txn {
209	my ($self, $type, %attr) = @_;	310	my ($self, $type, %attr) = @_;
210		311
211	$type = touc $type;	312	$type = touc $type;
212		313
213	my $txn = "Net::FCP::Txn::$type"->new(fcp => $self, type => tolc $type, attr => \%attr);	314	my $txn = "Net::FCP::Txn::$type"->new (fcp => $self, type => tolc $type, attr => \%attr);
214		315
215	$txn;	316	$txn;
216	}	317	}
217		318
218	sub _txn($&) {	319	{ # transactions
		320
		321	my $txn = sub {
219	my ($name, $sub) = @_;	322	my ($name, $sub) = @_;
220	*{"$name\_txn"} = $sub;	323	*{"txn_$name"} = $sub;
221	*{$name} = sub { $sub->(@_)->result };	324	*{$name} = sub { $sub->(@_)->result };
222	}	325	};
223		326
224	=item $txn = $fcp->txn_client_hello	327	=item $txn = $fcp->txn_client_hello
225		328
226	=item $nodehello = $fcp->client_hello	329	=item $nodehello = $fcp->client_hello
227		330
…		…
233	protocol => "1.2",	336	protocol => "1.2",
234	}	337	}
235		338
236	=cut	339	=cut
237		340
238	_txn client_hello => sub {	341	$txn->(client_hello => sub {
239	my ($self) = @_;	342	my ($self) = @_;
240		343
241	$self->txn ("client_hello");	344	$self->txn ("client_hello");
242	};	345	});
243		346
244	=item $txn = $fcp->txn_client_info	347	=item $txn = $fcp->txn_client_info
245		348
246	=item $nodeinfo = $fcp->client_info	349	=item $nodeinfo = $fcp->client_info
247		350
…		…
271	routing_time => "a5",	374	routing_time => "a5",
272	}	375	}
273		376
274	=cut	377	=cut
275		378
276	_txn client_info => sub {	379	$txn->(client_info => sub {
277	my ($self) = @_;	380	my ($self) = @_;
278		381
279	$self->txn ("client_info");	382	$self->txn ("client_info");
280	};	383	});
281		384
282	=item $txn = $fcp->txn_generate_chk ($metadata, $data)	385	=item $txn = $fcp->txn_generate_chk ($metadata, $data[, $cipher])
283		386
284	=item $uri = $fcp->generate_chk ($metadata, $data)	387	=item $uri = $fcp->generate_chk ($metadata, $data[, $cipher])
285		388
286	Creates a new CHK, given the metadata and data. UNTESTED.	389	Calculates a CHK, given the metadata and data. C<$cipher> is either
		390	C<Rijndael> or C<Twofish>, with the latter being the default.
287		391
288	=cut	392	=cut
289		393
290	_txn generate_chk => sub {	394	$txn->(generate_chk => sub {
291	my ($self, $metadata, $data) = @_;	395	my ($self, $metadata, $data, $cipher) = @_;
292		396
293	$self->txn (generate_chk => data => "$data$metadata", metadata_length => length $metadata);	397	$self->txn (generate_chk =>
		398	data => "$metadata$data",
		399	metadata_length => xeh length $metadata,
		400	cipher => $cipher \|\| "Twofish");
294	};	401	});
295		402
296	=item $txn = $fcp->txn_generate_svk_pair	403	=item $txn = $fcp->txn_generate_svk_pair
297		404
298	=item ($public, $private) = @{ $fcp->generate_svk_pair }	405	=item ($public, $private) = @{ $fcp->generate_svk_pair }
299		406
300	Creates a new SVK pair. Returns an arrayref.	407	Creates a new SVK pair. Returns an arrayref with the public key, the
		408	private key and a crypto key, which is just additional entropy.
301		409
302	[	410	[
303	"hKs0-WDQA4pVZyMPKNFsK1zapWY",	411	"acLx4dux9fvvABH15Gk6~d3I-yw",
304	"ZnmvMITaTXBMFGl4~jrjuyWxOWg"	412	"cPoDkDMXDGSMM32plaPZDhJDxSs",
		413	"BH7LXCov0w51-y9i~BoB3g",
305	]	414	]
306		415
307	=cut	416	A private key (for inserting) can be constructed like this:
308		417
		418	SSK@<private_key>,<crypto_key>/<name>
		419
		420	It can be used to insert data. The corresponding public key looks like this:
		421
		422	SSK@<public_key>PAgM,<crypto_key>/<name>
		423
		424	Watch out for the C<PAgM>-part!
		425
		426	=cut
		427
309	_txn generate_svk_pair => sub {	428	$txn->(generate_svk_pair => sub {
310	my ($self) = @_;	429	my ($self) = @_;
311		430
312	$self->txn ("generate_svk_pair");	431	$self->txn ("generate_svk_pair");
313	};	432	});
314		433
315	=item $txn = $fcp->txn_insert_private_key ($private)	434	=item $txn = $fcp->txn_invert_private_key ($private)
316		435
317	=item $uri = $fcp->insert_private_key ($private)	436	=item $public = $fcp->invert_private_key ($private)
318		437
319	Inserts a private key. $private can be either an insert URI (must start	438	Inverts a private key (returns the public key). C<$private> can be either
320	with freenet:SSK@) or a raw private key (i.e. the private value you get back	439	an insert URI (must start with C<freenet:SSK@>) or a raw private key (i.e.
321	from C<generate_svk_pair>).	440	the private value you get back from C<generate_svk_pair>).
322		441
323	Returns the public key.	442	Returns the public key.
324		443
325	UNTESTED.
326
327	=cut	444	=cut
328		445
329	_txn insert_private_key => sub {	446	$txn->(invert_private_key => sub {
330	my ($self, $privkey) = @_;	447	my ($self, $privkey) = @_;
331		448
332	$self->txn (invert_private_key => private => $privkey);	449	$self->txn (invert_private_key => private => $privkey);
333	};	450	});
334		451
335	=item $txn = $fcp->txn_get_size ($uri)	452	=item $txn = $fcp->txn_get_size ($uri)
336		453
337	=item $length = $fcp->get_size ($uri)	454	=item $length = $fcp->get_size ($uri)
338		455
339	Finds and returns the size (rounded up to the nearest power of two) of the	456	Finds and returns the size (rounded up to the nearest power of two) of the
340	given document.	457	given document.
341		458
342	UNTESTED.
343
344	=cut	459	=cut
345		460
346	_txn get_size => sub {	461	$txn->(get_size => sub {
347	my ($self, $uri) = @_;	462	my ($self, $uri) = @_;
348		463
349	$self->txn (get_size => URI => $uri);	464	$self->txn (get_size => URI => $uri);
350	};	465	});
351		466
352	=item $txn = $fcp->txn_client_get ($uri [, $htl = 15 [, $removelocal = 0]])	467	=item $txn = $fcp->txn_client_get ($uri [, $htl = 15 [, $removelocal = 0]])
353		468
354	=item ($metadata, $data) = @{ $fcp->client_get ($uri, $htl, $removelocal)	469	=item ($metadata, $data) = @{ $fcp->client_get ($uri, $htl, $removelocal)
355		470
356	Fetches a (small, as it should fit into memory) file from	471	Fetches a (small, as it should fit into memory) file from
357	freenet. C<$meta> is the metadata (as returned by C<parse_metadata> or	472	freenet. C<$meta> is the metadata (as returned by C<parse_metadata> or
358	C<undef>).	473	C<undef>).
		474
		475	The C<$uri> should begin with C<freenet:>, but the scheme is currently
		476	added, if missing.
359		477
360	Due to the overhead, a better method to download big files should be used.	478	Due to the overhead, a better method to download big files should be used.
361		479
362	my ($meta, $data) = @{	480	my ($meta, $data) = @{
363	$fcp->client_get (	481	$fcp->client_get (
…		…
365	)	483	)
366	};	484	};
367		485
368	=cut	486	=cut
369		487
370	_txn client_get => sub {	488	$txn->(client_get => sub {
371	my ($self, $uri, $htl, $removelocal) = @_;	489	my ($self, $uri, $htl, $removelocal) = @_;
372		490
373	$self->txn (client_get => URI => $uri, hops_to_live => ($htl \|\| 15), remove_local_key => $removelocal ? "true" : "false");	491	$uri =~ s/^freenet://;
		492	$uri = "freenet:$uri";
		493
		494	$self->txn (client_get => URI => $uri, hops_to_live => xeh (defined $htl ? $htl : 15),
		495	remove_local_key => $removelocal ? "true" : "false");
374	};	496	});
375		497
376	=item MISSING: ClientPut	498	=item $txn = $fcp->txn_client_put ($uri, $metadata, $data, $htl, $removelocal)
		499
		500	=item my $uri = $fcp->client_put ($uri, $metadata, $data, $htl, $removelocal);
		501
		502	Insert a new key. If the client is inserting a CHK, the URI may be
		503	abbreviated as just CHK@. In this case, the node will calculate the
		504	CHK. If the key is a private SSK key, the node will calculcate the public
		505	key and the resulting public URI.
		506
		507	C<$meta> can be a hash reference (same format as returned by
		508	C<Net::FCP::parse_metadata>) or a string.
		509
		510	The result is an arrayref with the keys C<uri>, C<public_key> and C<private_key>.
		511
		512	=cut
		513
		514	$txn->(client_put => sub {
		515	my ($self, $uri, $meta, $data, $htl, $removelocal) = @_;
		516
		517	$meta = build_metadata $meta;
		518
		519	$self->txn (client_put => URI => $uri,
		520	hops_to_live => xeh (defined $htl ? $htl : 15),
		521	remove_local_key => $removelocal ? "true" : "false",
		522	data => "$meta$data", metadata_length => xeh length $meta);
		523	});
		524
		525	} # transactions
377		526
378	=back	527	=back
379		528
380	=head2 THE Net::FCP::Txn CLASS	529	=head2 THE Net::FCP::Txn CLASS
381		530
382	All requests (or transactions) are executed in a asynchroneous way (LIE:	531	All requests (or transactions) are executed in a asynchronous way. For
383	uploads are blocking). For each request, a C<Net::FCP::Txn> object is	532	each request, a C<Net::FCP::Txn> object is created (worse: a tcp
384	created (worse: a tcp connection is created, too).	533	connection is created, too).
385		534
386	For each request there is actually a different subclass (and it's possible	535	For each request there is actually a different subclass (and it's possible
387	to subclass these, although of course not documented).	536	to subclass these, although of course not documented).
388		537
389	The most interesting method is C<result>.	538	The most interesting method is C<result>.
…		…
417	while (my ($k, $v) = each %{$self->{attr}}) {	566	while (my ($k, $v) = each %{$self->{attr}}) {
418	$attr .= (Net::FCP::touc $k) . "=$v\012"	567	$attr .= (Net::FCP::touc $k) . "=$v\012"
419	}	568	}
420		569
421	if (defined $data) {	570	if (defined $data) {
422	$attr .= "DataLength=" . (length $data) . "\012";	571	$attr .= sprintf "DataLength=%x\012", length $data;
423	$data = "Data\012$data";	572	$data = "Data\012$data";
424	} else {	573	} else {
425	$data = "EndMessage\012";	574	$data = "EndMessage\012";
426	}	575	}
427		576
…		…
434	and !$!{EINPROGRESS}	583	and !$!{EINPROGRESS}
435	and Carp::croak "FCP::txn: unable to connect to $self->{fcp}{host}:$self->{fcp}{port}: $!\n";	584	and Carp::croak "FCP::txn: unable to connect to $self->{fcp}{host}:$self->{fcp}{port}: $!\n";
436		585
437	$self->{sbuf} =	586	$self->{sbuf} =
438	"\x00\x00\x00\x02"	587	"\x00\x00\x00\x02"
439	. Net::FCP::touc $self->{type}	588	. (Net::FCP::touc $self->{type})
440	. "\012$attr$data";	589	. "\012$attr$data";
441		590
442	#$fh->shutdown (1); # freenet buggy?, well, it's java...	591	#shutdown $fh, 1; # freenet buggy?, well, it's java...
443		592
444	$self->{fh} = $fh;	593	$self->{fh} = $fh;
445		594
446	$self->{w} = $EVENT->new_from_fh ($fh)->cb(sub { $self->fh_ready_w })->poll(0, 1, 1);	595	$self->{w} = $EVENT->new_from_fh ($fh)->cb(sub { $self->fh_ready_w })->poll(0, 1, 1);
447		596
…		…
483		632
484	sub userdata($$) {	633	sub userdata($$) {
485	my ($self, $data) = @_;	634	my ($self, $data) = @_;
486	$self->{userdata} = $data;	635	$self->{userdata} = $data;
487	$self;	636	$self;
		637	}
		638
		639	=item $txn->cancel (%attr)
		640
		641	Cancels the operation with a C<cancel> exception anf the given attributes
		642	(consider at least giving the attribute C<reason>).
		643
		644	UNTESTED.
		645
		646	=cut
		647
		648	sub cancel {
		649	my ($self, %attr) = @_;
		650	$self->throw (Net::FCP::Exception->new (cancel => { %attr }));
		651	$self->set_result;
		652	$self->eof;
488	}	653	}
489		654
490	sub fh_ready_w {	655	sub fh_ready_w {
491	my ($self) = @_;	656	my ($self) = @_;
492		657
…		…
532	} else {	697	} else {
533	$self->eof;	698	$self->eof;
534	}	699	}
535	}	700	}
536		701
537	sub rcv_data {
538	my ($self, $chunk) = @_;
539
540	$self->{data} .= $chunk;
541
542	$self->progress ("data", { chunk => length $chunk, total => length $self->{data}, end => $self->{datalength} });
543	}
544
545	sub rcv {	702	sub rcv {
546	my ($self, $type, $attr) = @_;	703	my ($self, $type, $attr) = @_;
547		704
548	$type = Net::FCP::tolc $type;	705	$type = Net::FCP::tolc $type;
549		706
…		…
557	}	714	}
558		715
559	# used as a default exception thrower	716	# used as a default exception thrower
560	sub rcv_throw_exception {	717	sub rcv_throw_exception {
561	my ($self, $attr, $type) = @_;	718	my ($self, $attr, $type) = @_;
562	$self->throw (new Net::FCP::Exception $type, $attr);	719	$self->throw (Net::FCP::Exception->new ($type, $attr));
563	}	720	}
564		721
565	*rcv_failed = \&Net::FCP::Txn::rcv_throw_exception;	722	*rcv_failed = \&Net::FCP::Txn::rcv_throw_exception;
566	*rcv_format_error = \&Net::FCP::Txn::rcv_throw_exception;	723	*rcv_format_error = \&Net::FCP::Txn::rcv_throw_exception;
567		724
568	sub throw {	725	sub throw {
569	my ($self, $exc) = @_;	726	my ($self, $exc) = @_;
570		727
571	$self->{exception} = $exc;	728	$self->{exception} = $exc;
572	$self->set_result (1);	729	$self->set_result;
573	$self->eof; # must be last to avoid loops	730	$self->eof; # must be last to avoid loops
574	}	731	}
575		732
576	sub set_result {	733	sub set_result {
577	my ($self, $result) = @_;	734	my ($self, $result) = @_;
…		…
589	delete $self->{w};	746	delete $self->{w};
590	delete $self->{fh};	747	delete $self->{fh};
591		748
592	delete $self->{fcp}{txn}{$self};	749	delete $self->{fcp}{txn}{$self};
593		750
594	$self->set_result; # just in case	751	unless (exists $self->{result}) {
		752	$self->throw (Net::FCP::Exception->new (short_data => {
		753	reason => "unexpected eof or internal node error",
		754	}));
		755	}
595	}	756	}
596		757
597	sub progress {	758	sub progress {
598	my ($self, $type, $attr) = @_;	759	my ($self, $type, $attr) = @_;
		760
599	$self->{fcp}->progress ($self, $type, $attr);	761	$self->{fcp}->progress ($self, $type, $attr);
600	}	762	}
601		763
602	=item $result = $txn->result	764	=item $result = $txn->result
603		765
604	Waits until a result is available and then returns it.	766	Waits until a result is available and then returns it.
605		767
606	This waiting is (depending on your event model) not very efficient, as it	768	This waiting is (depending on your event model) not very efficient, as it
607	is done outside the "mainloop".	769	is done outside the "mainloop". The biggest problem, however, is that it's
		770	blocking one thread of execution. Try to use the callback mechanism, if
		771	possible, and call result from within the callback (or after is has been
		772	run), as then no waiting is necessary.
608		773
609	=cut	774	=cut
610		775
611	sub result {	776	sub result {
612	my ($self) = @_;	777	my ($self) = @_;
…		…
643	use base Net::FCP::Txn;	808	use base Net::FCP::Txn;
644		809
645	sub rcv_success {	810	sub rcv_success {
646	my ($self, $attr) = @_;	811	my ($self, $attr) = @_;
647		812
648	$self->set_result ($attr);	813	$self->set_result ($attr->{uri});
649	}	814	}
650		815
651	package Net::FCP::Txn::GenerateSVKPair;	816	package Net::FCP::Txn::GenerateSVKPair;
652		817
653	use base Net::FCP::Txn;	818	use base Net::FCP::Txn;
654		819
655	sub rcv_success {	820	sub rcv_success {
656	my ($self, $attr) = @_;	821	my ($self, $attr) = @_;
657
658	$self->set_result ([$attr->{PublicKey}, $attr->{PrivateKey}]);	822	$self->set_result ([$attr->{public_key}, $attr->{private_key}, $attr->{crypto_key}]);
659	}	823	}
660		824
661	package Net::FCP::Txn::InvertPrivateKey;	825	package Net::FCP::Txn::InvertPrivateKey;
662		826
663	use base Net::FCP::Txn;	827	use base Net::FCP::Txn;
664		828
665	sub rcv_success {	829	sub rcv_success {
666	my ($self, $attr) = @_;	830	my ($self, $attr) = @_;
667
668	$self->set_result ($attr->{PublicKey});	831	$self->set_result ($attr->{public_key});
669	}	832	}
670		833
671	package Net::FCP::Txn::GetSize;	834	package Net::FCP::Txn::GetSize;
672		835
673	use base Net::FCP::Txn;	836	use base Net::FCP::Txn;
674		837
675	sub rcv_success {	838	sub rcv_success {
676	my ($self, $attr) = @_;	839	my ($self, $attr) = @_;
677
678	$self->set_result ($attr->{Length});	840	$self->set_result (hex $attr->{length});
679	}	841	}
680		842
681	package Net::FCP::Txn::GetPut;	843	package Net::FCP::Txn::GetPut;
682		844
683	# base class for get and put	845	# base class for get and put
684		846
685	use base Net::FCP::Txn;	847	use base Net::FCP::Txn;
686		848
687	*rcv_uri_error = \&Net::FCP::Txn::rcv_throw_exception;	849	*rcv_uri_error = \&Net::FCP::Txn::rcv_throw_exception;
688	*rcv_route_not_found = \&Net::FCP::Txn::rcv_throw_exception;	850	*rcv_route_not_found = \&Net::FCP::Txn::rcv_throw_exception;
689		851
690	sub rcv_restarted {	852	sub rcv_restarted {
691	my ($self, $attr, $type) = @_;	853	my ($self, $attr, $type) = @_;
692		854
693	delete $self->{datalength};	855	delete $self->{datalength};
…		…
701		863
702	use base Net::FCP::Txn::GetPut;	864	use base Net::FCP::Txn::GetPut;
703		865
704	*rcv_data_not_found = \&Net::FCP::Txn::rcv_throw_exception;	866	*rcv_data_not_found = \&Net::FCP::Txn::rcv_throw_exception;
705		867
706	sub rcv_data_found {	868	sub rcv_data {
707	my ($self, $attr, $type) = @_;
708
709	$self->progress ($type, $attr);
710
711	$self->{datalength} = hex $attr->{data_length};
712	$self->{metalength} = hex $attr->{metadata_length};
713	}
714
715	sub eof {
716	my ($self) = @_;	869	my ($self, $chunk) = @_;
		870
		871	$self->{data} .= $chunk;
		872
		873	$self->progress ("data", { chunk => length $chunk, received => length $self->{data}, total => $self->{datalength} });
717		874
718	if ($self->{datalength} == length $self->{data}) {	875	if ($self->{datalength} == length $self->{data}) {
719	my $data = delete $self->{data};	876	my $data = delete $self->{data};
720	my $meta = Net::FCP::parse_metadata substr $data, 0, $self->{metalength}, "";	877	my $meta = Net::FCP::parse_metadata substr $data, 0, $self->{metalength}, "";
721		878
722	$self->set_result ([$meta, $data]);	879	$self->set_result ([$meta, $data]);
723	} elsif (!exists $self->{result}) {	880	$self->eof;
724	$self->throw (Net::FCP::Exception->new (short_data => {
725	reason => "unexpected eof or internal node error",
726	received => length $self->{data},
727	expected => $self->{datalength},
728	}));
729	}	881	}
		882	}
		883
		884	sub rcv_data_found {
		885	my ($self, $attr, $type) = @_;
		886
		887	$self->progress ($type, $attr);
		888
		889	$self->{datalength} = hex $attr->{data_length};
		890	$self->{metalength} = hex $attr->{metadata_length};
730	}	891	}
731		892
732	package Net::FCP::Txn::ClientPut;	893	package Net::FCP::Txn::ClientPut;
733		894
734	use base Net::FCP::Txn::GetPut;	895	use base Net::FCP::Txn::GetPut;
…		…
744	sub rcv_success {	905	sub rcv_success {
745	my ($self, $attr, $type) = @_;	906	my ($self, $attr, $type) = @_;
746	$self->set_result ($attr);	907	$self->set_result ($attr);
747	}	908	}
748		909
		910	=back
		911
		912	=head2 The Net::FCP::Exception CLASS
		913
		914	Any unexpected (non-standard) responses that make it impossible to return
		915	the advertised result will result in an exception being thrown when the
		916	C<result> method is called.
		917
		918	These exceptions are represented by objects of this class.
		919
		920	=over 4
		921
		922	=cut
		923
749	package Net::FCP::Exception;	924	package Net::FCP::Exception;
750		925
751	use overload	926	use overload
752	'""' => sub {	927	'""' => sub {
753	"Net::FCP::Exception<<$_[0][0]," . (join ":", %{$_[0][1]}) . ">>\n";	928	"Net::FCP::Exception<<$_[0][0]," . (join ":", %{$_[0][1]}) . ">>";
754	};	929	};
		930
		931	=item $exc = new Net::FCP::Exception $type, \%attr
		932
		933	Create a new exception object of the given type (a string like
		934	C<route_not_found>), and a hashref containing additional attributes
		935	(usually the attributes of the message causing the exception).
		936
		937	=cut
755		938
756	sub new {	939	sub new {
757	my ($class, $type, $attr) = @_;	940	my ($class, $type, $attr) = @_;
758		941
759	bless [Net::FCP::tolc $type, { %$attr }], $class;	942	bless [Net::FCP::tolc $type, { %$attr }], $class;
760	}	943	}
761		944
		945	=item $exc->type([$type])
		946
		947	With no arguments, returns the exception type. Otherwise a boolean
		948	indicating wether the exception is of the given type is returned.
		949
		950	=cut
		951
		952	sub type {
		953	my ($self, $type) = @_;
		954
		955	@_ >= 2
		956	? $self->[0] eq $type
		957	: $self->[0];
		958	}
		959
		960	=item $exc->attr([$attr])
		961
		962	With no arguments, returns the attributes. Otherwise the named attribute
		963	value is returned.
		964
		965	=cut
		966
		967	sub attr {
		968	my ($self, $attr) = @_;
		969
		970	@_ >= 2
		971	? $self->[1]{$attr}
		972	: $self->[1];
		973	}
		974
762	=back	975	=back
763		976
764	=head1 SEE ALSO	977	=head1 SEE ALSO
765		978
766	L<http://freenet.sf.net>.	979	L<http://freenet.sf.net>.
…		…
772	Marc Lehmann <pcg@goof.com>	985	Marc Lehmann <pcg@goof.com>
773	http://www.goof.com/pcg/marc/	986	http://www.goof.com/pcg/marc/
774		987
775	=cut	988	=cut
776		989
		990	package Net::FCP::Event::Auto;
		991
		992	my @models = (
		993	[Coro => Coro::Event::],
		994	[Event => Event::],
		995	[Glib => Glib::],
		996	[Tk => Tk::],
		997	);
		998
		999	sub AUTOLOAD {
		1000	$AUTOLOAD =~ s/.*://;
		1001
		1002	for (@models) {
		1003	my ($model, $package) = @$_;
		1004	if (defined ${"$package\::VERSION"}) {
		1005	$EVENT = "Net::FCP::Event::$model";
		1006	eval "require $EVENT"; die if $@;
		1007	goto &{"$EVENT\::$AUTOLOAD"};
		1008	}
		1009	}
		1010
		1011	for (@models) {
		1012	my ($model, $package) = @$_;
		1013	$EVENT = "Net::FCP::Event::$model";
		1014	if (eval "require $EVENT") {
		1015	goto &{"$EVENT\::$AUTOLOAD"};
		1016	}
		1017	}
		1018
		1019	die "No event module selected for Net::FCP and autodetect failed. Install any of these: Coro, Event, Glib or Tk.";
		1020	}
		1021
777	1;	1022	1;
778		1023

Diff Legend

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

Comparing Net-FCP/FCP.pm (file contents): Revision 1.13 by root, Wed Sep 10 05:06:16 2003 UTC vs. Revision 1.29 by root, Thu May 13 21:43:16 2004 UTC

Diff Legend

Comparing Net-FCP/FCP.pm (file contents):
Revision 1.13 by root, Wed Sep 10 05:06:16 2003 UTC vs.
Revision 1.29 by root, Thu May 13 21:43:16 2004 UTC