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

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

Diff Legend

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

Comparing cvsroot/Net-FCP/FCP.pm (file contents): Revision 1.9 by root, Tue Sep 9 06:13:18 2003 UTC vs. Revision 1.26 by root, Wed Dec 10 02:36:37 2003 UTC

Diff Legend

Comparing cvsroot/Net-FCP/FCP.pm (file contents):
Revision 1.9 by root, Tue Sep 9 06:13:18 2003 UTC vs.
Revision 1.26 by root, Wed Dec 10 02:36:37 2003 UTC