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

Comparing Net-FCP/FCP.pm (file contents):
Revision 1.10 by root, Tue Sep 9 06:22:58 2003 UTC vs.
Revision 1.23 by root, Wed Sep 17 08:57:32 2003 UTC

…		…
35	The import tag to use is named C<event=xyz>, e.g. C<event=Event>,	35	The import tag to use is named C<event=xyz>, e.g. C<event=Event>,
36	C<event=Glib> etc.	36	C<event=Glib> etc.
37		37
38	You should specify the event module to use only in the main program.	38	You should specify the event module to use only in the main program.
39		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
		66
40	=head2 THE Net::FCP CLASS	67	=head2 THE Net::FCP CLASS
41		68
42	=over 4	69	=over 4
43		70
44	=cut	71	=cut
45		72
46	package Net::FCP;	73	package Net::FCP;
47		74
48	use Carp;	75	use Carp;
49	use IO::Socket::INET;
50		76
51	$VERSION = 0.05;	77	$VERSION = 0.5;
52		78
53	no warnings;	79	no warnings;
54		80
55	our $EVENT = Net::FCP::Event::Auto::;	81	our $EVENT = Net::FCP::Event::Auto::;
56	$EVENT = Net::FCP::Event::Event;#d#
57		82
58	sub import {	83	sub import {
59	shift;	84	shift;
60		85
61	for (@_) {	86	for (@_) {
62	if (/^event=(\w+)$/) {	87	if (/^event=(\w+)$/) {
63	$EVENT = "Net::FCP::Event::$1";	88	$EVENT = "Net::FCP::Event::$1";
		89	eval "require $EVENT";
64	}	90	}
65	}	91	}
66	eval "require $EVENT";	92	die $@ if $@;
67	}	93	}
68		94
69	sub touc($) {	95	sub touc($) {
70	local $_ = shift;	96	local $_ = shift;
71	1 while s/((?:^\|_)(?:svk\|chk\|uri)(?:_\|$))/\U$1/;	97	1 while s/((?:^\|_)(?:svk\|chk\|uri)(?:_\|$))/\U$1/;
…		…
77	local $_ = shift;	103	local $_ = shift;
78	s/(?<=[a-z])(?=[A-Z])/_/g;	104	s/(?<=[a-z])(?=[A-Z])/_/g;
79	lc $_;	105	lc $_;
80	}	106	}
81		107
		108	# the opposite of hex
		109	sub xeh($) {
		110	sprintf "%x", $_[0];
		111	}
		112
82	=item $meta = Net::FCP::parse_metadata $string	113	=item $meta = Net::FCP::parse_metadata $string
83		114
84	Parse a metadata string and return it.	115	Parse a metadata string and return it.
85		116
86	The metadata will be a hashref with key C<version> (containing	117	The metadata will be a hashref with key C<version> (containing the
87	the mandatory version header entries).	118	mandatory version header entries) and key C<raw> containing the original
		119	metadata string.
88		120
89	All other headers are represented by arrayrefs (they can be repeated).	121	All other headers are represented by arrayrefs (they can be repeated).
90		122
91	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
92	manifest:	124	parsed manifest:
93		125
94	(	126	(
		127	raw => "Version...",
95	version => { revision => 1 },	128	version => { revision => 1 },
96	document => [	129	document => [
97	{	130	{
98	"info.format" => "image/jpeg",	131	info => { format" => "image/jpeg" },
99	name => "background.jpg",	132	name => "background.jpg",
100	"redirect.target" => "freenet:CHK\@ZcagI,ra726bSw"	133	redirect => { target => "freenet:CHK\@ZcagI,ra726bSw" },
101	},	134	},
102	{	135	{
103	"info.format" => "text/html",	136	info => { format" => "text/html" },
104	name => ".next",	137	name => ".next",
105	"redirect.target" => "freenet:SSK\@ilUPAgM/TFEE/3"	138	redirect => { target => "freenet:SSK\@ilUPAgM/TFEE/3" },
106	},	139	},
107	{	140	{
108	"info.format" => "text/html",	141	info => { format" => "text/html" },
109	"redirect.target" => "freenet:CHK\@8M8Po8ucwI,8xA"	142	redirect => { target => "freenet:CHK\@8M8Po8ucwI,8xA" },
110	}	143	}
111	]	144	]
112	)	145	)
113		146
114	=cut	147	=cut
115		148
116	sub parse_metadata {	149	sub parse_metadata {
117	my $meta;
118
119	my $data = shift;	150	my $data = shift;
		151	my $meta = { raw => $data };
		152
120	if ($data =~ /^Version\015?\012/gc) {	153	if ($data =~ /^Version\015?\012/gc) {
121	my $hdr = $meta->{version} = {};	154	my $hdr = $meta->{version} = {};
122		155
123	for (;;) {	156	for (;;) {
124	while ($data =~ /\G([^=\015\012]+)=([^\015\012]*)\015?\012/gc) {	157	while ($data =~ /\G([^=\015\012]+)=([^\015\012]*)\015?\012/gc) {
125	my ($k, $v) = ($1, $2);	158	my ($k, $v) = ($1, $2);
126	$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;
127	}	165	}
128		166
129	if ($data =~ /\GEndPart\015?\012/gc) {	167	if ($data =~ /\GEndPart\015?\012/gc) {
		168	# nop
130	} elsif ($data =~ /\GEnd\015?\012/gc) {	169	} elsif ($data =~ /\GEnd(\015?\012\|$)/gc) {
131	last;	170	last;
132	} elsif ($data =~ /\G([A-Za-z0-9.\-]+)\015?\012/gcs) {	171	} elsif ($data =~ /\G([A-Za-z0-9.\-]+)\015?\012/gcs) {
133	push @{$meta->{tolc $1}}, $hdr = {};	172	push @{$meta->{tolc $1}}, $hdr = {};
134	} elsif ($data =~ /\G(.*)/gcs) {	173	} elsif ($data =~ /\G(.*)/gcs) {
		174	print STDERR "metadata format error ($1), please report this string: <<$data>>";
135	die "metadata format error ($1)";	175	die "metadata format error";
136	}	176	}
137	}	177	}
138	}	178	}
139		179
140	#$meta->{tail} = substr $data, pos $data;	180	#$meta->{tail} = substr $data, pos $data;
…		…
146		186
147	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
148	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>).
149		189
150	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
151	established. However, the existance of the node is checked by executing a	195	However, the existance of the node is checked by executing a
152	C<ClientHello> transaction.	196	C<ClientHello> transaction.
		197
		198	=end
153		199
154	=cut	200	=cut
155		201
156	sub new {	202	sub new {
157	my $class = shift;	203	my $class = shift;
158	my $self = bless { @_ }, $class;	204	my $self = bless { @_ }, $class;
159		205
160	$self->{host} \|\|= $ENV{FREDHOST} \|\| "127.0.0.1";	206	$self->{host} \|\|= $ENV{FREDHOST} \|\| "127.0.0.1";
161	$self->{port} \|\|= $ENV{FREDPORt} \|\| 8481;	207	$self->{port} \|\|= $ENV{FREDPORT} \|\| 8481;
162		208
163	$self->{nodehello} = $self->client_hello	209	#$self->{nodehello} = $self->client_hello
164	or croak "unable to get nodehello from node\n";	210	# or croak "unable to get nodehello from node\n";
165		211
166	$self;	212	$self;
167	}	213	}
168		214
169	sub progress {	215	sub progress {
170	my ($self, $txn, $type, $attr) = @_;	216	my ($self, $txn, $type, $attr) = @_;
171	warn "progress<$txn,$type," . (join ":", %$attr) . ">\n";	217	#warn "progress<$txn,$type," . (join ":", %$attr) . ">\n";
172	}	218	}
173		219
174	=item $txn = $fcp->txn(type => attr => val,...)	220	=item $txn = $fcp->txn(type => attr => val,...)
175		221
176	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	);
177		245
178	=cut	246	=cut
179		247
180	sub txn {	248	sub txn {
181	my ($self, $type, %attr) = @_;	249	my ($self, $type, %attr) = @_;
…		…
185	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);
186		254
187	$txn;	255	$txn;
188	}	256	}
189		257
190	sub _txn($&) {	258	{ # transactions
		259
		260	my $txn = sub {
191	my ($name, $sub) = @_;	261	my ($name, $sub) = @_;
192	*{"$name\_txn"} = $sub;	262	*{"txn_$name"} = $sub;
193	*{$name} = sub { $sub->(@_)->result };	263	*{$name} = sub { $sub->(@_)->result };
194	}	264	};
195		265
196	=item $txn = $fcp->txn_client_hello	266	=item $txn = $fcp->txn_client_hello
197		267
198	=item $nodehello = $fcp->client_hello	268	=item $nodehello = $fcp->client_hello
199		269
…		…
205	protocol => "1.2",	275	protocol => "1.2",
206	}	276	}
207		277
208	=cut	278	=cut
209		279
210	_txn client_hello => sub {	280	$txn->(client_hello => sub {
211	my ($self) = @_;	281	my ($self) = @_;
212		282
213	$self->txn ("client_hello");	283	$self->txn ("client_hello");
214	};	284	});
215		285
216	=item $txn = $fcp->txn_client_info	286	=item $txn = $fcp->txn_client_info
217		287
218	=item $nodeinfo = $fcp->client_info	288	=item $nodeinfo = $fcp->client_info
219		289
…		…
243	routing_time => "a5",	313	routing_time => "a5",
244	}	314	}
245		315
246	=cut	316	=cut
247		317
248	_txn client_info => sub {	318	$txn->(client_info => sub {
249	my ($self) = @_;	319	my ($self) = @_;
250		320
251	$self->txn ("client_info");	321	$self->txn ("client_info");
252	};	322	});
253		323
254	=item $txn = $fcp->txn_generate_chk ($metadata, $data)	324	=item $txn = $fcp->txn_generate_chk ($metadata, $data[, $cipher])
255		325
256	=item $uri = $fcp->generate_chk ($metadata, $data)	326	=item $uri = $fcp->generate_chk ($metadata, $data[, $cipher])
257		327
258	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.
259		330
260	=cut	331	=cut
261		332
262	_txn generate_chk => sub {	333	$txn->(generate_chk => sub {
263	my ($self, $metadata, $data) = @_;	334	my ($self, $metadata, $data, $cipher) = @_;
264		335
265	$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");
266	};	340	});
267		341
268	=item $txn = $fcp->txn_generate_svk_pair	342	=item $txn = $fcp->txn_generate_svk_pair
269		343
270	=item ($public, $private) = @{ $fcp->generate_svk_pair }	344	=item ($public, $private) = @{ $fcp->generate_svk_pair }
271		345
…		…
276	"ZnmvMITaTXBMFGl4~jrjuyWxOWg"	350	"ZnmvMITaTXBMFGl4~jrjuyWxOWg"
277	]	351	]
278		352
279	=cut	353	=cut
280		354
281	_txn generate_svk_pair => sub {	355	$txn->(generate_svk_pair => sub {
282	my ($self) = @_;	356	my ($self) = @_;
283		357
284	$self->txn ("generate_svk_pair");	358	$self->txn ("generate_svk_pair");
285	};	359	});
286		360
287	=item $txn = $fcp->txn_insert_private_key ($private)	361	=item $txn = $fcp->txn_insert_private_key ($private)
288		362
289	=item $uri = $fcp->insert_private_key ($private)	363	=item $public = $fcp->insert_private_key ($private)
290		364
291	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
292	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
293	from C<generate_svk_pair>).	367	back from C<generate_svk_pair>).
294		368
295	Returns the public key.	369	Returns the public key.
296		370
297	UNTESTED.	371	UNTESTED.
298		372
299	=cut	373	=cut
300		374
301	_txn insert_private_key => sub {	375	$txn->(insert_private_key => sub {
302	my ($self, $privkey) = @_;	376	my ($self, $privkey) = @_;
303		377
304	$self->txn (invert_private_key => private => $privkey);	378	$self->txn (invert_private_key => private => $privkey);
305	};	379	});
306		380
307	=item $txn = $fcp->txn_get_size ($uri)	381	=item $txn = $fcp->txn_get_size ($uri)
308		382
309	=item $length = $fcp->get_size ($uri)	383	=item $length = $fcp->get_size ($uri)
310		384
…		…
313		387
314	UNTESTED.	388	UNTESTED.
315		389
316	=cut	390	=cut
317		391
318	_txn get_size => sub {	392	$txn->(get_size => sub {
319	my ($self, $uri) = @_;	393	my ($self, $uri) = @_;
320		394
321	$self->txn (get_size => URI => $uri);	395	$self->txn (get_size => URI => $uri);
322	};	396	});
323		397
324	=item $txn = $fcp->txn_client_get ($uri [, $htl = 15 [, $removelocal = 0]])	398	=item $txn = $fcp->txn_client_get ($uri [, $htl = 15 [, $removelocal = 0]])
325		399
326	=item ($metadata, $data) = @{ $fcp->client_get ($uri, $htl, $removelocal)	400	=item ($metadata, $data) = @{ $fcp->client_get ($uri, $htl, $removelocal)
327		401
…		…
337	)	411	)
338	};	412	};
339		413
340	=cut	414	=cut
341		415
342	_txn client_get => sub {	416	$txn->(client_get => sub {
343	my ($self, $uri, $htl, $removelocal) = @_;	417	my ($self, $uri, $htl, $removelocal) = @_;
344		418
345	$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");
346	};	421	});
347		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
348	=item MISSING: ClientPut	447	=item MISSING: (ClientPut), InsertKey
349		448
350	=back	449	=back
351		450
352	=head2 THE Net::FCP::Txn CLASS	451	=head2 THE Net::FCP::Txn CLASS
353		452
354	All requests (or transactions) are executed in a asynchroneous way (LIE:	453	All requests (or transactions) are executed in a asynchronous way. For
355	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
356	created (worse: a tcp connection is created, too).	455	connection is created, too).
357		456
358	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
359	to subclass these, although of course not documented).	458	to subclass these, although of course not documented).
360		459
361	The most interesting method is C<result>.	460	The most interesting method is C<result>.
…		…
363	=over 4	462	=over 4
364		463
365	=cut	464	=cut
366		465
367	package Net::FCP::Txn;	466	package Net::FCP::Txn;
		467
		468	use Fcntl;
		469	use Socket;
368		470
369	=item new arg => val,...	471	=item new arg => val,...
370		472
371	Creates a new C<Net::FCP::Txn> object. Not normally used.	473	Creates a new C<Net::FCP::Txn> object. Not normally used.
372		474
…		…
374		476
375	sub new {	477	sub new {
376	my $class = shift;	478	my $class = shift;
377	my $self = bless { @_ }, $class;	479	my $self = bless { @_ }, $class;
378		480
		481	$self->{signal} = $EVENT->new_signal;
		482
		483	$self->{fcp}{txn}{$self} = $self;
		484
379	my $attr = "";	485	my $attr = "";
380	my $data = delete $self->{attr}{data};	486	my $data = delete $self->{attr}{data};
381		487
382	while (my ($k, $v) = each %{$self->{attr}}) {	488	while (my ($k, $v) = each %{$self->{attr}}) {
383	$attr .= (Net::FCP::touc $k) . "=$v\012"	489	$attr .= (Net::FCP::touc $k) . "=$v\012"
384	}	490	}
385		491
386	if (defined $data) {	492	if (defined $data) {
387	$attr .= "DataLength=" . (length $data) . "\012";	493	$attr .= sprintf "DataLength=%x\012", length $data;
388	$data = "Data\012$data";	494	$data = "Data\012$data";
389	} else {	495	} else {
390	$data = "EndMessage\012";	496	$data = "EndMessage\012";
391	}	497	}
392		498
393	my $fh = new IO::Socket::INET	499	socket my $fh, PF_INET, SOCK_STREAM, 0
394	PeerHost => $self->{fcp}{host},	500	or Carp::croak "unable to create new tcp socket: $!";
395	PeerPort => $self->{fcp}{port}
396	or Carp::croak "FCP::txn: unable to connect to $self->{fcp}{host}:$self->{fcp}{port}: $!\n";
397
398	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";
399		507
400	if (0) {	508	$self->{sbuf} =
401	print	509	"\x00\x00\x00\x02"
402	Net::FCP::touc $self->{type}, "\012",
403	$attr,
404	$data, "\012";
405	}
406
407	print $fh
408	"\x00\x00", "\x00\x02", # SESSID, PRESID
409	Net::FCP::touc $self->{type}, "\012",	510	. (Net::FCP::touc $self->{type})
410	$attr,	511	. "\012$attr$data";
411	$data;
412		512
413	#$fh->shutdown (1); # freenet buggy?, well, it's java...	513	#shutdown $fh, 1; # freenet buggy?, well, it's java...
414		514
415	$self->{fh} = $fh;	515	$self->{fh} = $fh;
416		516
417	$EVENT->reg_r_cb ($self);	517	$self->{w} = $EVENT->new_from_fh ($fh)->cb(sub { $self->fh_ready_w })->poll(0, 1, 1);
418		518
419	$self;	519	$self;
420	}	520	}
421		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
422	=item $userdata = $txn->userdata ([$userdata])	546	=item $txn = $txn->userdata ([$userdata])
423		547
424	Get and/or set user-specific data. This is useful in progress callbacks.	548	Set user-specific data. This is useful in progress callbacks. The data can be accessed
		549	using C<< $txn->{userdata} >>.
425		550
426	=cut	551	Returns the txn object, useful for chaining.
427		552
		553	=cut
		554
428	sub userdata($;$) {	555	sub userdata($$) {
429	my ($self, $data) = @_;	556	my ($self, $data) = @_;
430	$self->{userdata} = $data if @_ >= 2;	557	$self->{userdata} = $data;
431	$self->{userdata};	558	$self;
432	}	559	}
433		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
434	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 {
435	my ($self) = @_;	596	my ($self) = @_;
436		597
437	if (sysread $self->{fh}, $self->{buf}, 65536, length $self->{buf}) {	598	if (sysread $self->{fh}, $self->{buf}, 65536, length $self->{buf}) {
438	for (;;) {	599	for (;;) {
439	if ($self->{datalen}) {	600	if ($self->{datalen}) {
		601	#warn "expecting new datachunk $self->{datalen}, got ".(length $self->{buf})."\n";#d#
440	if (length $self->{buf} >= $self->{datalen}) {	602	if (length $self->{buf} >= $self->{datalen}) {
441	$self->rcv_data (substr $self->{buf}, 0, $self->{datalen}, "");	603	$self->rcv_data (substr $self->{buf}, 0, delete $self->{datalen}, "");
442	} else {	604	} else {
443	last;	605	last;
444	}	606	}
445	} 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//) {
446	$self->{datalen} = hex $1;	608	$self->{datalen} = hex $1;
		609	#warn "expecting new datachunk $self->{datalen}\n";#d#
447	} 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) {
448	$self->rcv ($1, {	611	$self->rcv ($1, {
449	map { my ($a, $b) = split /=/, $_, 2; ((Net::FCP::tolc $a), $b) }	612	map { my ($a, $b) = split /=/, $_, 2; ((Net::FCP::tolc $a), $b) }
450	split /\015?\012/, $2	613	split /\015?\012/, $2
451	});	614	});
452	} else {	615	} else {
453	last;	616	last;
454	}	617	}
455	}	618	}
456	} else {	619	} else {
457	$EVENT->unreg_r_cb ($self);
458	delete $self->{fh};
459	$self->eof;	620	$self->eof;
460	}	621	}
461	}
462
463	sub rcv_data {
464	my ($self, $chunk) = @_;
465
466	$self->{data} .= $chunk;
467
468	$self->progress ("data", { chunk => length $chunk, total => length $self->{data}, end => $self->{datalength} });
469	}	622	}
470		623
471	sub rcv {	624	sub rcv {
472	my ($self, $type, $attr) = @_;	625	my ($self, $type, $attr) = @_;
473		626
…		…
480	} else {	633	} else {
481	warn "received unexpected reply type '$type' for '$self->{type}', ignoring\n";	634	warn "received unexpected reply type '$type' for '$self->{type}', ignoring\n";
482	}	635	}
483	}	636	}
484		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
485	sub throw {	647	sub throw {
486	my ($self, $exc) = @_;	648	my ($self, $exc) = @_;
487		649
488	$self->{exception} = $exc;	650	$self->{exception} = $exc;
489	$self->set_result (1);	651	$self->set_result;
		652	$self->eof; # must be last to avoid loops
490	}	653	}
491		654
492	sub set_result {	655	sub set_result {
493	my ($self, $result) = @_;	656	my ($self, $result) = @_;
494		657
495	$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	}
496	}	663	}
497		664
498	sub eof {	665	sub eof {
499	my ($self) = @_;	666	my ($self) = @_;
500	$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	}
501	}	678	}
502		679
503	sub progress {	680	sub progress {
504	my ($self, $type, $attr) = @_;	681	my ($self, $type, $attr) = @_;
505	$self->{fcp}->progress ($self, $type, $attr);	682	$self->{fcp}->progress ($self, $type, $attr);
…		…
508	=item $result = $txn->result	685	=item $result = $txn->result
509		686
510	Waits until a result is available and then returns it.	687	Waits until a result is available and then returns it.
511		688
512	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
513	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.
514		694
515	=cut	695	=cut
516		696
517	sub result {	697	sub result {
518	my ($self) = @_;	698	my ($self) = @_;
519		699
520	$EVENT->wait_event while !exists $self->{result};	700	$self->{signal}->wait while !exists $self->{result};
521		701
522	die $self->{exception} if $self->{exception};	702	die $self->{exception} if $self->{exception};
523		703
524	return $self->{result};	704	return $self->{result};
525	}
526
527	sub DESTROY {
528	$EVENT->unreg_r_cb ($_[0]);
529	#$EVENT->unreg_w_cb ($_[0]);
530	}	705	}
531		706
532	package Net::FCP::Txn::ClientHello;	707	package Net::FCP::Txn::ClientHello;
533		708
534	use base Net::FCP::Txn;	709	use base Net::FCP::Txn;
…		…
554	use base Net::FCP::Txn;	729	use base Net::FCP::Txn;
555		730
556	sub rcv_success {	731	sub rcv_success {
557	my ($self, $attr) = @_;	732	my ($self, $attr) = @_;
558		733
559	$self->set_result ($attr);	734	$self->set_result ($attr->{uri});
560	}	735	}
561		736
562	package Net::FCP::Txn::GenerateSVKPair;	737	package Net::FCP::Txn::GenerateSVKPair;
563		738
564	use base Net::FCP::Txn;	739	use base Net::FCP::Txn;
565		740
566	sub rcv_success {	741	sub rcv_success {
567	my ($self, $attr) = @_;	742	my ($self, $attr) = @_;
568
569	$self->set_result ([$attr->{PublicKey}, $attr->{PrivateKey}]);	743	$self->set_result ([$attr->{PublicKey}, $attr->{PrivateKey}]);
570	}	744	}
571		745
572	package Net::FCP::Txn::InvertPrivateKey;	746	package Net::FCP::Txn::InsertPrivateKey;
573		747
574	use base Net::FCP::Txn;	748	use base Net::FCP::Txn;
575		749
576	sub rcv_success {	750	sub rcv_success {
577	my ($self, $attr) = @_;	751	my ($self, $attr) = @_;
578
579	$self->set_result ($attr->{PublicKey});	752	$self->set_result ($attr->{PublicKey});
580	}	753	}
581		754
582	package Net::FCP::Txn::GetSize;	755	package Net::FCP::Txn::GetSize;
583		756
584	use base Net::FCP::Txn;	757	use base Net::FCP::Txn;
585		758
586	sub rcv_success {	759	sub rcv_success {
587	my ($self, $attr) = @_;	760	my ($self, $attr) = @_;
588
589	$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);
590	}	781	}
591		782
592	package Net::FCP::Txn::ClientGet;	783	package Net::FCP::Txn::ClientGet;
593		784
594	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	}
595		804
596	sub rcv_data_found {	805	sub rcv_data_found {
597	my ($self, $attr, $type) = @_;	806	my ($self, $attr, $type) = @_;
598		807
599	$self->progress ($type, $attr);	808	$self->progress ($type, $attr);
600		809
601	$self->{datalength} = hex $attr->{data_length};	810	$self->{datalength} = hex $attr->{data_length};
602	$self->{metalength} = hex $attr->{metadata_length};	811	$self->{metalength} = hex $attr->{metadata_length};
603	}	812	}
604		813
605	sub rcv_route_not_found {	814	package Net::FCP::Txn::ClientPut;
606	my ($self, $attr, $type) = @_;
607		815
608	$self->throw (new Net::FCP::Exception $type, $attr);	816	use base Net::FCP::Txn::GetPut;
609	}
610		817
611	sub rcv_data_not_found {	818	*rcv_size_error = \&Net::FCP::Txn::rcv_throw_exception;
612	my ($self, $attr, $type) = @_;	819	*rcv_key_collision = \&Net::FCP::Txn::rcv_throw_exception;
613		820
614	$self->throw (new Net::FCP::Exception $type, $attr);	821	sub rcv_pending {
615	}
616
617	sub rcv_format_error {
618	my ($self, $attr, $type) = @_;
619
620	$self->throw (new Net::FCP::Exception $type, $attr);
621	}
622
623	sub rcv_restarted {
624	my ($self, $attr, $type) = @_;	822	my ($self, $attr, $type) = @_;
625	$self->progress ($type, $attr);	823	$self->progress ($type, $attr);
626	}	824	}
627		825
628	sub eof {	826	sub rcv_success {
629	my ($self) = @_;	827	my ($self, $attr, $type) = @_;
630
631	my $data = delete $self->{data};
632	my $meta = Net::FCP::parse_metadata substr $data, 0, $self->{metalength}, "";
633
634	$self->set_result ([$meta, $data]);	828	$self->set_result ($attr);
635	}	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
636		844
637	package Net::FCP::Exception;	845	package Net::FCP::Exception;
638		846
639	use overload	847	use overload
640	'""' => sub {	848	'""' => sub {
641	"Net::FCP::Exception<<$_[0][0]," . (join ":", %{$_[0][1]}) . ">>\n";	849	"Net::FCP::Exception<<$_[0][0]," . (join ":", %{$_[0][1]}) . ">>";
642	};	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
643		859
644	sub new {	860	sub new {
645	my ($class, $type, $attr) = @_;	861	my ($class, $type, $attr) = @_;
646		862
647	bless [$type, { %$attr }], $class;	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 {
		889	my ($self, $attr) = @_;
		890
		891	@_ >= 2
		892	? $self->[1]{$attr}
		893	: $self->[1];
648	}	894	}
649		895
650	=back	896	=back
651		897
652	=head1 SEE ALSO	898	=head1 SEE ALSO
…		…
660	Marc Lehmann <pcg@goof.com>	906	Marc Lehmann <pcg@goof.com>
661	http://www.goof.com/pcg/marc/	907	http://www.goof.com/pcg/marc/
662		908
663	=cut	909	=cut
664		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
665	1;	943	1;
666		944

Diff Legend

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

Comparing Net-FCP/FCP.pm (file contents): Revision 1.10 by root, Tue Sep 9 06:22:58 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.10 by root, Tue Sep 9 06:22:58 2003 UTC vs.
Revision 1.23 by root, Wed Sep 17 08:57:32 2003 UTC