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

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

Diff Legend

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

Comparing Net-FCP/FCP.pm (file contents): Revision 1.2 by root, Sun Sep 7 23:20:20 2003 UTC vs. Revision 1.27 by root, Thu May 13 15:41:01 2004 UTC

Diff Legend

Comparing Net-FCP/FCP.pm (file contents):
Revision 1.2 by root, Sun Sep 7 23:20:20 2003 UTC vs.
Revision 1.27 by root, Thu May 13 15:41:01 2004 UTC