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

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

Diff Legend

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

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