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

Comparing Net-FCP/FCP.pm (file contents):
Revision 1.8 by root, Mon Sep 8 01:47:31 2003 UTC vs.
Revision 1.26 by root, Wed Dec 10 02:36:37 2003 UTC

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

Diff Legend

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

Comparing Net-FCP/FCP.pm (file contents): Revision 1.8 by root, Mon Sep 8 01:47:31 2003 UTC vs. Revision 1.26 by root, Wed Dec 10 02:36:37 2003 UTC

Diff Legend

Comparing Net-FCP/FCP.pm (file contents):
Revision 1.8 by root, Mon Sep 8 01:47:31 2003 UTC vs.
Revision 1.26 by root, Wed Dec 10 02:36:37 2003 UTC