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

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.28 by root, Thu May 13 16:13:42 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.28 by root, Thu May 13 16:13:42 2004 UTC