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

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.23 by root, Wed Sep 17 08:57:32 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.23 by root, Wed Sep 17 08:57:32 2003 UTC