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

Comparing Net-FCP/FCP.pm (file contents):
Revision 1.6 by root, Mon Sep 8 00:36:44 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.03;	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
		113	=item $meta = Net::FCP::parse_metadata $string
		114
		115	Parse a metadata string and return it.
		116
		117	The metadata will be a hashref with key C<version> (containing the
		118	mandatory version header entries) and key C<raw> containing the original
		119	metadata string.
		120
		121	All other headers are represented by arrayrefs (they can be repeated).
		122
		123	Since this description is confusing, here is a rather verbose example of a
		124	parsed manifest:
		125
		126	(
		127	raw => "Version...",
		128	version => { revision => 1 },
		129	document => [
		130	{
		131	info => { format" => "image/jpeg" },
		132	name => "background.jpg",
		133	redirect => { target => "freenet:CHK\@ZcagI,ra726bSw" },
		134	},
		135	{
		136	info => { format" => "text/html" },
		137	name => ".next",
		138	redirect => { target => "freenet:SSK\@ilUPAgM/TFEE/3" },
		139	},
		140	{
		141	info => { format" => "text/html" },
		142	redirect => { target => "freenet:CHK\@8M8Po8ucwI,8xA" },
		143	}
		144	]
		145	)
		146
		147	=cut
		148
		149	sub parse_metadata {
		150	my $data = shift;
		151	my $meta = { raw => $data };
		152
		153	if ($data =~ /^Version\015?\012/gc) {
		154	my $hdr = $meta->{version} = {};
		155
		156	for (;;) {
		157	while ($data =~ /\G([^=\015\012]+)=([^\015\012]*)\015?\012/gc) {
		158	my ($k, $v) = ($1, $2);
		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;
		165	}
		166
		167	if ($data =~ /\GEndPart\015?\012/gc) {
		168	# nop
		169	} elsif ($data =~ /\GEnd(\015?\012\|$)/gc) {
		170	last;
		171	} elsif ($data =~ /\G([A-Za-z0-9.\-]+)\015?\012/gcs) {
		172	push @{$meta->{tolc $1}}, $hdr = {};
		173	} elsif ($data =~ /\G(.*)/gcs) {
		174	print STDERR "metadata format error ($1), please report this string: <<$data>>";
		175	die "metadata format error";
		176	}
		177	}
		178	}
		179
		180	#$meta->{tail} = substr $data, pos $data;
		181
		182	$meta;
		183	}
		184
77	=item $fcp = new Net::FCP [host => $host][, port => $port]	185	=item $fcp = new Net::FCP [host => $host][, port => $port]
78		186
79	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
80	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>).
81		189
82	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
83	established. However, the existance of the node is checked by executing a	195	However, the existance of the node is checked by executing a
84	C<ClientHello> transaction.	196	C<ClientHello> transaction.
		197
		198	=end
85		199
86	=cut	200	=cut
87		201
88	sub new {	202	sub new {
89	my $class = shift;	203	my $class = shift;
90	my $self = bless { @_ }, $class;	204	my $self = bless { @_ }, $class;
91		205
92	$self->{host} \|\|= $ENV{FREDHOST} \|\| "127.0.0.1";	206	$self->{host} \|\|= $ENV{FREDHOST} \|\| "127.0.0.1";
93	$self->{port} \|\|= $ENV{FREDPORt} \|\| 8481;	207	$self->{port} \|\|= $ENV{FREDPORT} \|\| 8481;
94		208
95	$self->{nodehello} = $self->client_hello	209	#$self->{nodehello} = $self->client_hello
96	or croak "unable to get nodehello from node\n";	210	# or croak "unable to get nodehello from node\n";
97		211
98	$self;	212	$self;
99	}	213	}
100		214
		215	sub progress {
		216	my ($self, $txn, $type, $attr) = @_;
		217	#warn "progress<$txn,$type," . (join ":", %$attr) . ">\n";
		218	}
		219
101	=item $txn = $fcp->txn(type => attr => val,...)	220	=item $txn = $fcp->txn(type => attr => val,...)
102		221
103	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	);
104		245
105	=cut	246	=cut
106		247
107	sub txn {	248	sub txn {
108	my ($self, $type, %attr) = @_;	249	my ($self, $type, %attr) = @_;
…		…
112	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);
113		254
114	$txn;	255	$txn;
115	}	256	}
116		257
117	sub _txn($&) {	258	{ # transactions
		259
		260	my $txn = sub {
118	my ($name, $sub) = @_;	261	my ($name, $sub) = @_;
119	*{"$name\_txn"} = $sub;	262	*{"txn_$name"} = $sub;
120	*{$name} = sub { $sub->(@_)->result };	263	*{$name} = sub { $sub->(@_)->result };
121	}	264	};
122		265
123	=item $txn = $fcp->txn_client_hello	266	=item $txn = $fcp->txn_client_hello
124		267
125	=item $nodehello = $fcp->client_hello	268	=item $nodehello = $fcp->client_hello
126		269
…		…
132	protocol => "1.2",	275	protocol => "1.2",
133	}	276	}
134		277
135	=cut	278	=cut
136		279
137	_txn client_hello => sub {	280	$txn->(client_hello => sub {
138	my ($self) = @_;	281	my ($self) = @_;
139		282
140	$self->txn ("client_hello");	283	$self->txn ("client_hello");
141	};	284	});
142		285
143	=item $txn = $fcp->txn_client_info	286	=item $txn = $fcp->txn_client_info
144		287
145	=item $nodeinfo = $fcp->client_info	288	=item $nodeinfo = $fcp->client_info
146		289
…		…
170	routing_time => "a5",	313	routing_time => "a5",
171	}	314	}
172		315
173	=cut	316	=cut
174		317
175	_txn client_info => sub {	318	$txn->(client_info => sub {
176	my ($self) = @_;	319	my ($self) = @_;
177		320
178	$self->txn ("client_info");	321	$self->txn ("client_info");
179	};	322	});
180		323
181	=item $txn = $fcp->txn_generate_chk ($metadata, $data)	324	=item $txn = $fcp->txn_generate_chk ($metadata, $data[, $cipher])
182		325
183	=item $uri = $fcp->generate_chk ($metadata, $data)	326	=item $uri = $fcp->generate_chk ($metadata, $data[, $cipher])
184		327
185	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.
186		330
187	=cut	331	=cut
188		332
189	_txn generate_chk => sub {	333	$txn->(generate_chk => sub {
190	my ($self, $metadata, $data) = @_;	334	my ($self, $metadata, $data, $cipher) = @_;
191		335
192	$self->txn (generate_chk => data => "$data$metadata", meta_data_length => length $metadata);	336	$self->txn (generate_chk =>
		337	data => "$metadata$data",
		338	metadata_length => xeh length $metadata,
		339	cipher => $cipher \|\| "Twofish");
193	};	340	});
194		341
195	=item $txn = $fcp->txn_generate_svk_pair	342	=item $txn = $fcp->txn_generate_svk_pair
196		343
197	=item ($public, $private) = @{ $fcp->generate_svk_pair }	344	=item ($public, $private) = @{ $fcp->generate_svk_pair }
198		345
…		…
203	"ZnmvMITaTXBMFGl4~jrjuyWxOWg"	350	"ZnmvMITaTXBMFGl4~jrjuyWxOWg"
204	]	351	]
205		352
206	=cut	353	=cut
207		354
208	_txn generate_svk_pair => sub {	355	$txn->(generate_svk_pair => sub {
209	my ($self) = @_;	356	my ($self) = @_;
210		357
211	$self->txn ("generate_svk_pair");	358	$self->txn ("generate_svk_pair");
212	};	359	});
213		360
214	=item $txn = $fcp->txn_insert_private_key ($private)	361	=item $txn = $fcp->txn_insert_private_key ($private)
215		362
216	=item $uri = $fcp->insert_private_key ($private)	363	=item $public = $fcp->insert_private_key ($private)
217		364
218	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
219	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
220	from C<generate_svk_pair>).	367	back from C<generate_svk_pair>).
221		368
222	Returns the public key.	369	Returns the public key.
223		370
224	UNTESTED.	371	UNTESTED.
225		372
226	=cut	373	=cut
227		374
228	_txn insert_private_key => sub {	375	$txn->(insert_private_key => sub {
229	my ($self, $privkey) = @_;	376	my ($self, $privkey) = @_;
230		377
231	$self->txn (invert_private_key => private => $privkey);	378	$self->txn (invert_private_key => private => $privkey);
232	};	379	});
233		380
234	=item $txn = $fcp->txn_get_size ($uri)	381	=item $txn = $fcp->txn_get_size ($uri)
235		382
236	=item $length = $fcp->get_size ($uri)	383	=item $length = $fcp->get_size ($uri)
237		384
…		…
240		387
241	UNTESTED.	388	UNTESTED.
242		389
243	=cut	390	=cut
244		391
245	_txn get_size => sub {	392	$txn->(get_size => sub {
246	my ($self, $uri) = @_;	393	my ($self, $uri) = @_;
247		394
248	$self->txn (get_size => URI => $uri);	395	$self->txn (get_size => URI => $uri);
249	};	396	});
250		397
251	=item $txn = $fcp->txn_client_get ($uri [, $htl = 15 [, $removelocal = 0]])	398	=item $txn = $fcp->txn_client_get ($uri [, $htl = 15 [, $removelocal = 0]])
252		399
253	=item ($data, $metadata) = @{ $fcp->client_get ($uri, $htl, $removelocal)	400	=item ($metadata, $data) = @{ $fcp->client_get ($uri, $htl, $removelocal)
254		401
255	Fetches a (small, as it should fit into memory) file from freenet.	402	Fetches a (small, as it should fit into memory) file from
		403	freenet. C<$meta> is the metadata (as returned by C<parse_metadata> or
		404	C<undef>).
256		405
257	Due to the overhead, a better method to download big fiels should be used.	406	Due to the overhead, a better method to download big files should be used.
258		407
259	my ($data, $meta) = @{	408	my ($meta, $data) = @{
260	$fcp->client_get (	409	$fcp->client_get (
261	"freenet:CHK@hdXaxkwZ9rA8-SidT0AN-bniQlgPAwI,XdCDmBuGsd-ulqbLnZ8v~w"	410	"freenet:CHK@hdXaxkwZ9rA8-SidT0AN-bniQlgPAwI,XdCDmBuGsd-ulqbLnZ8v~w"
262	)	411	)
263	};	412	};
264		413
265	=cut	414	=cut
266		415
267	_txn client_get => sub {	416	$txn->(client_get => sub {
268	my ($self, $uri, $htl, $removelocal) = @_;	417	my ($self, $uri, $htl, $removelocal) = @_;
269		418
270	$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");
271	};	421	});
272		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
273	=item MISSING: ClientPut	447	=item MISSING: (ClientPut), InsertKey
274		448
275	=back	449	=back
276		450
277	=head2 THE Net::FCP::Txn CLASS	451	=head2 THE Net::FCP::Txn CLASS
278		452
279	All requests (or transactions) are executed in a asynchroneous way (LIE:	453	All requests (or transactions) are executed in a asynchronous way. For
280	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
281	created (worse: a tcp connection is created, too).	455	connection is created, too).
282		456
283	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
284	to subclass these, although of course not documented).	458	to subclass these, although of course not documented).
285		459
286	The most interesting method is C<result>.	460	The most interesting method is C<result>.
…		…
288	=over 4	462	=over 4
289		463
290	=cut	464	=cut
291		465
292	package Net::FCP::Txn;	466	package Net::FCP::Txn;
		467
		468	use Fcntl;
		469	use Socket;
293		470
294	=item new arg => val,...	471	=item new arg => val,...
295		472
296	Creates a new C<Net::FCP::Txn> object. Not normally used.	473	Creates a new C<Net::FCP::Txn> object. Not normally used.
297		474
…		…
299		476
300	sub new {	477	sub new {
301	my $class = shift;	478	my $class = shift;
302	my $self = bless { @_ }, $class;	479	my $self = bless { @_ }, $class;
303		480
		481	$self->{signal} = $EVENT->new_signal;
		482
		483	$self->{fcp}{txn}{$self} = $self;
		484
304	my $attr = "";	485	my $attr = "";
305	my $data = delete $self->{attr}{data};	486	my $data = delete $self->{attr}{data};
306		487
307	while (my ($k, $v) = each %{$self->{attr}}) {	488	while (my ($k, $v) = each %{$self->{attr}}) {
308	$attr .= (Net::FCP::touc $k) . "=$v\012"	489	$attr .= (Net::FCP::touc $k) . "=$v\012"
309	}	490	}
310		491
311	if (defined $data) {	492	if (defined $data) {
312	$attr .= "DataLength=" . (length $data) . "\012";	493	$attr .= sprintf "DataLength=%x\012", length $data;
313	$data = "Data\012$data";	494	$data = "Data\012$data";
314	} else {	495	} else {
315	$data = "EndMessage\012";	496	$data = "EndMessage\012";
316	}	497	}
317		498
318	my $fh = new IO::Socket::INET	499	socket my $fh, PF_INET, SOCK_STREAM, 0
319	PeerHost => $self->{fcp}{host},	500	or Carp::croak "unable to create new tcp socket: $!";
320	PeerPort => $self->{fcp}{port}
321	or Carp::croak "FCP::txn: unable to connect to $self->{fcp}{host}:$self->{fcp}{port}: $!\n";
322
323	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";
324		507
325	if (0) {	508	$self->{sbuf} =
326	print	509	"\x00\x00\x00\x02"
327	Net::FCP::touc $self->{type}, "\012",
328	$attr,
329	$data, "\012";
330	}
331
332	print $fh
333	"\x00\x00", "\x00\x02", # SESSID, PRESID
334	Net::FCP::touc $self->{type}, "\012",	510	. (Net::FCP::touc $self->{type})
335	$attr,	511	. "\012$attr$data";
336	$data;
337		512
338	#$fh->shutdown (1); # freenet buggy?, well, it's java...	513	#shutdown $fh, 1; # freenet buggy?, well, it's java...
339		514
340	$self->{fh} = $fh;	515	$self->{fh} = $fh;
341		516
342	$Net::FCP::regcb->($self);	517	$self->{w} = $EVENT->new_from_fh ($fh)->cb(sub { $self->fh_ready_w })->poll(0, 1, 1);
343		518
344	$self;	519	$self;
345	}	520	}
346		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
347	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 {
348	my ($self) = @_;	596	my ($self) = @_;
349		597
350	if (sysread $self->{fh}, $self->{buf}, 65536, length $self->{buf}) {	598	if (sysread $self->{fh}, $self->{buf}, 65536, length $self->{buf}) {
351	for (;;) {	599	for (;;) {
352	if ($self->{datalen}) {	600	if ($self->{datalen}) {
		601	#warn "expecting new datachunk $self->{datalen}, got ".(length $self->{buf})."\n";#d#
353	if (length $self->{buf} >= $self->{datalen}) {	602	if (length $self->{buf} >= $self->{datalen}) {
354	$self->rcv_data (substr $self->{buf}, 0, $self->{datalen}, "");	603	$self->rcv_data (substr $self->{buf}, 0, delete $self->{datalen}, "");
355	} else {	604	} else {
356	last;	605	last;
357	}	606	}
358	} 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//) {
359	$self->{datalen} = hex $1;	608	$self->{datalen} = hex $1;
		609	#warn "expecting new datachunk $self->{datalen}\n";#d#
360	} elsif ($self->{buf} =~ s/^([a-zA-Z]+)\015?\012(.*?)\015?\012EndMessage\015?\012//s) {	610	} elsif ($self->{buf} =~ s/^([a-zA-Z]+)\015?\012(?:(.+?)\015?\012)?EndMessage\015?\012//s) {
361	$self->rcv ($1, {	611	$self->rcv ($1, {
362	map { my ($a, $b) = split /=/, $_, 2; ((Net::FCP::tolc $a), $b) }	612	map { my ($a, $b) = split /=/, $_, 2; ((Net::FCP::tolc $a), $b) }
363	split /\015?\012/, $2	613	split /\015?\012/, $2
364	});	614	});
365	} else {	615	} else {
366	last;	616	last;
367	}	617	}
368	}	618	}
369	} else {	619	} else {
370	$Net::FCP::unregcb->($self);
371	delete $self->{fh};
372	$self->eof;	620	$self->eof;
373	}	621	}
374	}
375
376	sub rcv_data {
377	my ($self, $chunk) = @_;
378
379	$self->{data} .= $chunk;
380	}	622	}
381		623
382	sub rcv {	624	sub rcv {
383	my ($self, $type, $attr) = @_;	625	my ($self, $type, $attr) = @_;
384		626
…		…
391	} else {	633	} else {
392	warn "received unexpected reply type '$type' for '$self->{type}', ignoring\n";	634	warn "received unexpected reply type '$type' for '$self->{type}', ignoring\n";
393	}	635	}
394	}	636	}
395		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
396	sub set_result {	655	sub set_result {
397	my ($self, $result) = @_;	656	my ($self, $result) = @_;
398		657
399	$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	}
400	}	663	}
401		664
402	sub eof {	665	sub eof {
403	my ($self) = @_;	666	my ($self) = @_;
404	$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);
405	}	683	}
406		684
407	=item $result = $txn->result	685	=item $result = $txn->result
408		686
409	Waits until a result is available and then returns it.	687	Waits until a result is available and then returns it.
410		688
411	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
412	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.
413		694
414	=cut	695	=cut
415		696
416	sub result {	697	sub result {
417	my ($self) = @_;	698	my ($self) = @_;
418		699
419	$Net::FCP::waitcb->() while !exists $self->{result};	700	$self->{signal}->wait while !exists $self->{result};
		701
		702	die $self->{exception} if $self->{exception};
420		703
421	return $self->{result};	704	return $self->{result};
422	}
423
424	sub DESTROY {
425	$Net::FCP::unregcb->($_[0]);
426	}	705	}
427		706
428	package Net::FCP::Txn::ClientHello;	707	package Net::FCP::Txn::ClientHello;
429		708
430	use base Net::FCP::Txn;	709	use base Net::FCP::Txn;
…		…
450	use base Net::FCP::Txn;	729	use base Net::FCP::Txn;
451		730
452	sub rcv_success {	731	sub rcv_success {
453	my ($self, $attr) = @_;	732	my ($self, $attr) = @_;
454		733
455	$self->set_result ($attr);	734	$self->set_result ($attr->{uri});
456	}	735	}
457		736
458	package Net::FCP::Txn::GenerateSVKPair;	737	package Net::FCP::Txn::GenerateSVKPair;
459		738
460	use base Net::FCP::Txn;	739	use base Net::FCP::Txn;
461		740
462	sub rcv_success {	741	sub rcv_success {
463	my ($self, $attr) = @_;	742	my ($self, $attr) = @_;
464
465	$self->set_result ([$attr->{PublicKey}, $attr->{PrivateKey}]);	743	$self->set_result ([$attr->{PublicKey}, $attr->{PrivateKey}]);
466	}	744	}
467		745
468	package Net::FCP::Txn::InvertPrivateKey;	746	package Net::FCP::Txn::InsertPrivateKey;
469		747
470	use base Net::FCP::Txn;	748	use base Net::FCP::Txn;
471		749
472	sub rcv_success {	750	sub rcv_success {
473	my ($self, $attr) = @_;	751	my ($self, $attr) = @_;
474
475	$self->set_result ($attr->{PublicKey});	752	$self->set_result ($attr->{PublicKey});
476	}	753	}
477		754
478	package Net::FCP::Txn::GetSize;	755	package Net::FCP::Txn::GetSize;
479		756
480	use base Net::FCP::Txn;	757	use base Net::FCP::Txn;
481		758
482	sub rcv_success {	759	sub rcv_success {
483	my ($self, $attr) = @_;	760	my ($self, $attr) = @_;
484
485	$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);
486	}	781	}
487		782
488	package Net::FCP::Txn::ClientGet;	783	package Net::FCP::Txn::ClientGet;
489		784
490	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	}
491		804
492	sub rcv_data_found {	805	sub rcv_data_found {
		806	my ($self, $attr, $type) = @_;
		807
		808	$self->progress ($type, $attr);
		809
		810	$self->{datalength} = hex $attr->{data_length};
		811	$self->{metalength} = hex $attr->{metadata_length};
		812	}
		813
		814	package Net::FCP::Txn::ClientPut;
		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
		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 {
		874	my ($self, $type) = @_;
		875
		876	@_ >= 2
		877	? $self->[0] eq $type
		878	: $self->[0];
		879	}
		880
		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 {
493	my ($self, $attr) = @_;	889	my ($self, $attr) = @_;
494		890
495	$self->{datalength} = hex $attr->{data_length};	891	@_ >= 2
496	$self->{metalength} = hex $attr->{meta_data_length};	892	? $self->[1]{$attr}
497	}	893	: $self->[1];
498
499	sub eof {
500	my ($self) = @_;
501	#use PApp::Util; warn PApp::Util::dumpval $self;
502	my $data = delete $self->{data};
503	$self->set_result ([
504	(substr $data, 0, $self->{datalength}-$self->{metalength}),
505	(substr $data, $self->{datalength}-$self->{metalength}),
506	]);
507	}	894	}
508		895
509	=back	896	=back
510		897
511	=head1 SEE ALSO	898	=head1 SEE ALSO
…		…
519	Marc Lehmann <pcg@goof.com>	906	Marc Lehmann <pcg@goof.com>
520	http://www.goof.com/pcg/marc/	907	http://www.goof.com/pcg/marc/
521		908
522	=cut	909	=cut
523		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
524	1;	943	1;
525		944

Diff Legend

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

Comparing Net-FCP/FCP.pm (file contents): Revision 1.6 by root, Mon Sep 8 00:36:44 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.6 by root, Mon Sep 8 00:36:44 2003 UTC vs.
Revision 1.23 by root, Wed Sep 17 08:57:32 2003 UTC