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

Comparing Net-FCP/FCP.pm (file contents):
Revision 1.2 by root, Sun Sep 7 23:20:20 2003 UTC vs.
Revision 1.17 by root, Fri Sep 12 03:28:45 2003 UTC

…		…
17	of what the messages do. I am too lazy to document all this here.	17	of what the messages do. I am too lazy to document all this here.
18		18
19	=head1 WARNING	19	=head1 WARNING
20		20
21	This module is alpha. While it probably won't destroy (much :) of your	21	This module is alpha. While it probably won't destroy (much :) of your
22	data, it currently works only with the Event module (alkthough the event	22	data, it currently falls short of what it should provide (intelligent uri
23	mechanism is fully pluggable).	23	following, splitfile downloads, healing...)
		24
		25	=head2 IMPORT TAGS
		26
		27	Nothing much can be "imported" from this module right now. There are,
		28	however, certain "import tags" that can be used to select the event model
		29	to be used.
		30
		31	Event models are implemented as modules under the C<Net::FCP::Event::xyz>
		32	class, where C<xyz> is the event model to use. The default is C<Event> (or
		33	later C<Auto>).
		34
		35	The import tag to use is named C<event=xyz>, e.g. C<event=Event>,
		36	C<event=Glib> etc.
		37
		38	You should specify the event module to use only in the main program.
		39
		40	=head2 FREENET BASICS
		41
		42	Ok, this section will not explain any freenet basics to you, just some
		43	problems I found that you might want to avoid:
		44
		45	=over 4
		46
		47	=item freenet URIs are _NOT_ URIs
		48
		49	Whenever a "uri" is required by the protocol, freenet expects a kind of
		50	URI prefixed with the "freenet:" scheme, e.g. "freenet:CHK...". However,
		51	these are not URIs, as freeent fails to parse them correctly, that is, you
		52	must unescape an escaped characters ("%2c" => ",") yourself. Maybe in the
		53	future this library will do it for you, so watch out for this incompatible
		54	change.
		55
		56	=item Numbers are in HEX
		57
		58	Virtually every number in the FCP protocol is in hex. Be sure to use
		59	C<hex()> on all such numbers, as the module (currently) does nothing to
		60	convert these for you.
		61
		62	=back
24		63
25	=head2 THE Net::FCP CLASS	64	=head2 THE Net::FCP CLASS
26		65
27	=over 4	66	=over 4
28		67
29	=cut	68	=cut
30		69
31	package Net::FCP;	70	package Net::FCP;
32		71
33	use Carp;	72	use Carp;
34	use IO::Socket::INET;
35		73
36	$VERSION = 0.01;	74	$VERSION = 0.07;
37		75
38	sub event_reg_cb {	76	no warnings;
39	my ($obj) = @_;
40	require Event;
41		77
42	$obj->{eventdata} = Event->io (	78	our $EVENT = Net::FCP::Event::Auto::;
43	fd => $obj->{fh},	79	$EVENT = Net::FCP::Event::Event;#d#
44	poll => 'r',	80
45	cb => sub {	81	sub import {
46	$obj->fh_ready;	82	shift;
		83
		84	for (@_) {
		85	if (/^event=(\w+)$/) {
		86	$EVENT = "Net::FCP::Event::$1";
47	},	87	}
48	);	88	}
		89	eval "require $EVENT";
		90	die $@ if $@;
49	}	91	}
50
51	sub event_unreg_cb {
52	$_[0]{eventdata}
53	and (delete $_[0]{eventdata})->cancel;
54	}
55
56	sub event_wait_cb {
57	Event::one_event();
58	}
59
60	$regcb = \&event_reg_cb;
61	$unregcb = \&event_unreg_cb;
62	$waitcb = \&event_wait_cb;
63		92
64	sub touc($) {	93	sub touc($) {
65	local $_ = shift;	94	local $_ = shift;
66	1 while s/((?:^\|_)(?:svk\|chk\|uri)(?:_\|$))/\U$1/;	95	1 while s/((?:^\|_)(?:svk\|chk\|uri)(?:_\|$))/\U$1/;
67	s/(?:^\|_)(.)/\U$1/g;	96	s/(?:^\|_)(.)/\U$1/g;
…		…
72	local $_ = shift;	101	local $_ = shift;
73	s/(?<=[a-z])(?=[A-Z])/_/g;	102	s/(?<=[a-z])(?=[A-Z])/_/g;
74	lc $_;	103	lc $_;
75	}	104	}
76		105
		106	=item $meta = Net::FCP::parse_metadata $string
		107
		108	Parse a metadata string and return it.
		109
		110	The metadata will be a hashref with key C<version> (containing
		111	the mandatory version header entries).
		112
		113	All other headers are represented by arrayrefs (they can be repeated).
		114
		115	Since this is confusing, here is a rather verbose example of a parsed
		116	manifest:
		117
		118	(
		119	version => { revision => 1 },
		120	document => [
		121	{
		122	info => { format" => "image/jpeg" },
		123	name => "background.jpg",
		124	redirect => { target => "freenet:CHK\@ZcagI,ra726bSw" },
		125	},
		126	{
		127	info => { format" => "text/html" },
		128	name => ".next",
		129	redirect => { target => "freenet:SSK\@ilUPAgM/TFEE/3" },
		130	},
		131	{
		132	info => { format" => "text/html" },
		133	redirect => { target => "freenet:CHK\@8M8Po8ucwI,8xA" },
		134	}
		135	]
		136	)
		137
		138	=cut
		139
		140	sub parse_metadata {
		141	my $meta;
		142
		143	my $data = shift;
		144	if ($data =~ /^Version\015?\012/gc) {
		145	my $hdr = $meta->{version} = {};
		146
		147	for (;;) {
		148	while ($data =~ /\G([^=\015\012]+)=([^\015\012]*)\015?\012/gc) {
		149	my ($k, $v) = ($1, $2);
		150	my @p = split /\./, tolc $k, 3;
		151
		152	$hdr->{$p[0]} = $v if @p == 1; # lamest code I ever wrote
		153	$hdr->{$p[0]}{$p[1]} = $v if @p == 2;
		154	$hdr->{$p[0]}{$p[1]}{$p[2]} = $v if @p == 3;
		155	die "FATAL: 4+ dot metadata" if @p >= 4;
		156	}
		157
		158	if ($data =~ /\GEndPart\015?\012/gc) {
		159	# nop
		160	} elsif ($data =~ /\GEnd(\015?\012\|$)/gc) {
		161	last;
		162	} elsif ($data =~ /\G([A-Za-z0-9.\-]+)\015?\012/gcs) {
		163	push @{$meta->{tolc $1}}, $hdr = {};
		164	} elsif ($data =~ /\G(.*)/gcs) {
		165	die "metadata format error ($1), please report this string: <<$data>>";
		166	}
		167	}
		168	}
		169
		170	#$meta->{tail} = substr $data, pos $data;
		171
		172	$meta;
		173	}
		174
77	=item $fcp = new Net::FCP [host => $host][, port => $port]	175	=item $fcp = new Net::FCP [host => $host][, port => $port]
78		176
79	Create a new virtual FCP connection to the given host and port (default	177	Create a new virtual FCP connection to the given host and port (default
80	127.0.0.1:8481).	178	127.0.0.1:8481, or the environment variables C<FREDHOST> and C<FREDPORT>).
81		179
82	Connections are virtual because no persistent physical connection is	180	Connections are virtual because no persistent physical connection is
		181	established.
		182
		183	=begin comment
		184
83	established. However, the existance of the node is checked by executing a	185	However, the existance of the node is checked by executing a
84	C<ClientHello> transaction.	186	C<ClientHello> transaction.
		187
		188	=end
85		189
86	=cut	190	=cut
87		191
88	sub new {	192	sub new {
89	my $class = shift;	193	my $class = shift;
90	my $self = bless { @_ }, $class;	194	my $self = bless { @_ }, $class;
91		195
92	$self->{host} \|\|= "127.0.0.1";	196	$self->{host} \|\|= $ENV{FREDHOST} \|\| "127.0.0.1";
93	$self->{port} \|\|= 8481;	197	$self->{port} \|\|= $ENV{FREDPORT} \|\| 8481;
94		198
95	$self->{nodehello} = $self->txn("ClientHello")->result	199	#$self->{nodehello} = $self->client_hello
96	or croak "unable to get nodehello from node\n";	200	# or croak "unable to get nodehello from node\n";
97		201
98	$self;	202	$self;
99	}	203	}
100		204
		205	sub progress {
		206	my ($self, $txn, $type, $attr) = @_;
		207	warn "progress<$txn,$type," . (join ":", %$attr) . ">\n";
		208	}
		209
101	=item $txn = $fcp->txn(type => attr => val,...)	210	=item $txn = $fcp->txn(type => attr => val,...)
102		211
103	The low-level interface to transactions. Don't use it.	212	The low-level interface to transactions. Don't use it.
		213
		214	Here are some examples of using transactions:
		215
		216	The blocking case, no (visible) transactions involved:
		217
		218	my $nodehello = $fcp->client_hello;
		219
		220	A transaction used in a blocking fashion:
		221
		222	my $txn = $fcp->txn_client_hello;
		223	...
		224	my $nodehello = $txn->result;
		225
		226	Or shorter:
		227
		228	my $nodehello = $fcp->txn_client_hello->result;
		229
		230	Setting callbacks:
		231
		232	$fcp->txn_client_hello->cb(
		233	sub { my $nodehello => $_[0]->result }
		234	);
104		235
105	=cut	236	=cut
106		237
107	sub txn {	238	sub txn {
108	my ($self, $type, %attr) = @_;	239	my ($self, $type, %attr) = @_;
…		…
112	my $txn = "Net::FCP::Txn::$type"->new(fcp => $self, type => tolc $type, attr => \%attr);	243	my $txn = "Net::FCP::Txn::$type"->new(fcp => $self, type => tolc $type, attr => \%attr);
113		244
114	$txn;	245	$txn;
115	}	246	}
116		247
117	sub _txn($&) {	248	{ # transactions
		249
		250	my $txn = sub {
118	my ($name, $sub) = @_;	251	my ($name, $sub) = @_;
119	*{"$name\_txn"} = $sub;	252	*{"txn_$name"} = $sub;
120	*{$name} = sub { $sub->(@_)->result };	253	*{$name} = sub { $sub->(@_)->result };
121	}	254	};
122		255
123	=item $txn = $fcp->txn_client_hello	256	=item $txn = $fcp->txn_client_hello
124		257
125	=item $nodehello = $fcp->client_hello	258	=item $nodehello = $fcp->client_hello
126		259
127	Executes a ClientHello request and returns it's results.	260	Executes a ClientHello request and returns it's results.
128		261
129	{	262	{
130	max_file_size => "5f5e100",	263	max_file_size => "5f5e100",
		264	node => "Fred,0.6,1.46,7050"
131	protocol => "1.2",	265	protocol => "1.2",
132	node => "Fred,0.6,1.46,7050"
133	}	266	}
134		267
135	=cut	268	=cut
136		269
137	_txn client_hello => sub {	270	$txn->(client_hello => sub {
138	my ($self) = @_;	271	my ($self) = @_;
139		272
140	$self->txn ("client_hello");	273	$self->txn ("client_hello");
141	};	274	});
142		275
143	=item $txn = $fcp->txn_client_info	276	=item $txn = $fcp->txn_client_info
144		277
145	=item $nodeinfo = $fcp->client_info	278	=item $nodeinfo = $fcp->client_info
146		279
147	Executes a ClientInfo request and returns it's results.	280	Executes a ClientInfo request and returns it's results.
148		281
149	{	282	{
150	max_file_size => "5f5e100",
151	datastore_max => "2540be400",
152	node_port => 369,
153	java_name => "Java HotSpot(_T_M) Server VM",
154	operating_system_version => "2.4.20",
155	estimated_load => 52,
156	free_memory => "5cc0148",
157	datastore_free => "5ce03400",
158	node_address => "1.2.3.4",
159	active_jobs => "1f",	283	active_jobs => "1f",
160	allocated_memory => "bde0000",	284	allocated_memory => "bde0000",
161	architecture => "i386",	285	architecture => "i386",
		286	available_threads => 17,
		287	datastore_free => "5ce03400",
		288	datastore_max => "2540be400",
		289	datastore_used => "1f72bb000",
		290	estimated_load => 52,
		291	free_memory => "5cc0148",
		292	is_transient => "false",
		293	java_name => "Java HotSpot(_T_M) Server VM",
		294	java_vendor => "http://www.blackdown.org/",
		295	java_version => "Blackdown-1.4.1-01",
		296	least_recent_timestamp => "f41538b878",
		297	max_file_size => "5f5e100",
		298	most_recent_timestamp => "f77e2cc520"
		299	node_address => "1.2.3.4",
		300	node_port => 369,
		301	operating_system => "Linux",
		302	operating_system_version => "2.4.20",
162	routing_time => "a5",	303	routing_time => "a5",
163	least_recent_timestamp => "f41538b878",
164	available_threads => 17,
165	datastore_used => "1f72bb000",
166	java_version => "Blackdown-1.4.1-01",
167	is_transient => "false",
168	operating_system => "Linux",
169	java_vendor => "http://www.blackdown.org/",
170	most_recent_timestamp => "f77e2cc520"
171	}	304	}
172		305
173	=cut	306	=cut
174		307
175	_txn client_info => sub {	308	$txn->(client_info => sub {
176	my ($self) = @_;	309	my ($self) = @_;
177		310
178	$self->txn ("client_info");	311	$self->txn ("client_info");
179	};	312	});
180		313
181	=item $txn = $fcp->txn_generate_chk ($metadata, $data)	314	=item $txn = $fcp->txn_generate_chk ($metadata, $data)
182		315
183	=item $uri = $fcp->generate_chk ($metadata, $data)	316	=item $uri = $fcp->generate_chk ($metadata, $data)
184		317
185	Creates a new CHK, given the metadata and data. UNTESTED.	318	Creates a new CHK, given the metadata and data. UNTESTED.
186		319
187	=cut	320	=cut
188		321
189	_txn generate_chk => sub {	322	$txn->(generate_chk => sub {
190	my ($self, $metadata, $data) = @_;	323	my ($self, $metadata, $data) = @_;
191		324
192	$self->txn (generate_chk => data => "$data$metadata", meta_data_length => length $metadata);	325	$self->txn (generate_chk => data => "$metadata$data", metadata_length => length $metadata);
193	};	326	});
194		327
195	=item $txn = $fcp->txn_generate_svk_pair	328	=item $txn = $fcp->txn_generate_svk_pair
196		329
197	=item ($public, $private) = @{ $fcp->generate_svk_pair }	330	=item ($public, $private) = @{ $fcp->generate_svk_pair }
198		331
…		…
203	"ZnmvMITaTXBMFGl4~jrjuyWxOWg"	336	"ZnmvMITaTXBMFGl4~jrjuyWxOWg"
204	]	337	]
205		338
206	=cut	339	=cut
207		340
208	_txn generate_svk_pair => sub {	341	$txn->(generate_svk_pair => sub {
209	my ($self) = @_;	342	my ($self) = @_;
210		343
211	$self->txn ("generate_svk_pair");	344	$self->txn ("generate_svk_pair");
212	};	345	});
213		346
214	=item $txn = $fcp->txn_insert_private_key ($private)	347	=item $txn = $fcp->txn_insert_private_key ($private)
215		348
216	=item $uri = $fcp->insert_private_key ($private)	349	=item $public = $fcp->insert_private_key ($private)
217		350
218	Inserts a private key. $private can be either an insert URI (must start	351	Inserts a private key. $private can be either an insert URI (must start
219	with freenet:SSK@) or a raw private key (i.e. the private value you get back	352	with C<freenet:SSK@>) or a raw private key (i.e. the private value you get
220	from C<generate_svk_pair>).	353	back from C<generate_svk_pair>).
221		354
222	Returns the public key.	355	Returns the public key.
223		356
224	UNTESTED.	357	UNTESTED.
225		358
226	=cut	359	=cut
227		360
228	_txn insert_private_key => sub {	361	$txn->(insert_private_key => sub {
229	my ($self, $privkey) = @_;	362	my ($self, $privkey) = @_;
230		363
231	$self->txn (invert_private_key => private => $privkey);	364	$self->txn (invert_private_key => private => $privkey);
232	};	365	});
233		366
234	=item $txn = $fcp->txn_get_size ($uri)	367	=item $txn = $fcp->txn_get_size ($uri)
235		368
236	=item $length = $fcp->get_size ($uri)	369	=item $length = $fcp->get_size ($uri)
237		370
…		…
240		373
241	UNTESTED.	374	UNTESTED.
242		375
243	=cut	376	=cut
244		377
245	_txn get_size => sub {	378	$txn->(get_size => sub {
246	my ($self, $uri) = @_;	379	my ($self, $uri) = @_;
247		380
248	$self->txn (get_size => URI => $uri);	381	$self->txn (get_size => URI => $uri);
249	};	382	});
250		383
251	=item MISSING: ClientGet, ClientPut	384	=item $txn = $fcp->txn_client_get ($uri [, $htl = 15 [, $removelocal = 0]])
		385
		386	=item ($metadata, $data) = @{ $fcp->client_get ($uri, $htl, $removelocal)
		387
		388	Fetches a (small, as it should fit into memory) file from
		389	freenet. C<$meta> is the metadata (as returned by C<parse_metadata> or
		390	C<undef>).
		391
		392	Due to the overhead, a better method to download big files should be used.
		393
		394	my ($meta, $data) = @{
		395	$fcp->client_get (
		396	"freenet:CHK@hdXaxkwZ9rA8-SidT0AN-bniQlgPAwI,XdCDmBuGsd-ulqbLnZ8v~w"
		397	)
		398	};
		399
		400	=cut
		401
		402	$txn->(client_get => sub {
		403	my ($self, $uri, $htl, $removelocal) = @_;
		404
		405	$self->txn (client_get => URI => $uri, hops_to_live => (defined $htl ? $htl :15),
		406	remove_local_key => $removelocal ? "true" : "false");
		407	});
		408
		409	=item $txn = $fcp->txn_client_put ($uri, $metadata, $data, $htl, $removelocal)
		410
		411	=item my $uri = $fcp->client_put ($uri, $metadata, $data, $htl, $removelocal);
		412
		413	Insert a new key. If the client is inserting a CHK, the URI may be
		414	abbreviated as just CHK@. In this case, the node will calculate the
		415	CHK.
		416
		417	C<$meta> can be a reference or a string (ONLY THE STRING CASE IS IMPLEMENTED!).
		418
		419	THIS INTERFACE IS UNTESTED AND SUBJECT TO CHANGE.
		420
		421	=cut
		422
		423	$txn->(client_put => sub {
		424	my ($self, $uri, $meta, $data, $htl, $removelocal) = @_;
		425
		426	$self->txn (client_put => URI => $uri, hops_to_live => (defined $htl ? $htl :15),
		427	remove_local_key => $removelocal ? "true" : "false",
		428	data => "$meta$data", metadata_length => length $meta);
		429	});
		430
		431	} # transactions
		432
		433	=item MISSING: (ClientPut), InsretKey
252		434
253	=back	435	=back
254		436
255	=head2 THE Net::FCP::Txn CLASS	437	=head2 THE Net::FCP::Txn CLASS
256		438
…		…
267		449
268	=cut	450	=cut
269		451
270	package Net::FCP::Txn;	452	package Net::FCP::Txn;
271		453
		454	use Fcntl;
		455	use Socket;
		456
272	=item new arg => val,...	457	=item new arg => val,...
273		458
274	Creates a new C<Net::FCP::Txn> object. Not normally used.	459	Creates a new C<Net::FCP::Txn> object. Not normally used.
275		460
276	=cut	461	=cut
277		462
278	sub new {	463	sub new {
279	my $class = shift;	464	my $class = shift;
280	my $self = bless { @_ }, $class;	465	my $self = bless { @_ }, $class;
		466
		467	$self->{signal} = $EVENT->new_signal;
		468
		469	$self->{fcp}{txn}{$self} = $self;
281		470
282	my $attr = "";	471	my $attr = "";
283	my $data = delete $self->{attr}{data};	472	my $data = delete $self->{attr}{data};
284		473
285	while (my ($k, $v) = each %{$self->{attr}}) {	474	while (my ($k, $v) = each %{$self->{attr}}) {
…		…
291	$data = "Data\012$data";	480	$data = "Data\012$data";
292	} else {	481	} else {
293	$data = "EndMessage\012";	482	$data = "EndMessage\012";
294	}	483	}
295		484
296	my $fh = new IO::Socket::INET	485	socket my $fh, PF_INET, SOCK_STREAM, 0
297	PeerHost => $self->{fcp}{host},	486	or Carp::croak "unable to create new tcp socket: $!";
298	PeerPort => $self->{fcp}{port}
299	or Carp::croak "FCP::txn: unable to connect to $self->{fcp}{host}:$self->{fcp}{port}: $!\n";
300
301	binmode $fh, ":raw";	487	binmode $fh, ":raw";
		488	fcntl $fh, F_SETFL, O_NONBLOCK;
		489	connect $fh, (sockaddr_in $self->{fcp}{port}, inet_aton $self->{fcp}{host})
		490	and !$!{EWOULDBLOCK}
		491	and !$!{EINPROGRESS}
		492	and Carp::croak "FCP::txn: unable to connect to $self->{fcp}{host}:$self->{fcp}{port}: $!\n";
302		493
303	if (0) {	494	$self->{sbuf} =
304	print	495	"\x00\x00\x00\x02"
305	Net::FCP::touc $self->{type}, "\012",
306	$attr,
307	$data, "\012";
308	}
309
310	print $fh
311	"\x00\x00", "\x00\x02", # SESSID, PRESID
312	Net::FCP::touc $self->{type}, "\012",	496	. Net::FCP::touc $self->{type}
313	$attr,	497	. "\012$attr$data";
314	$data;
315		498
316	#$fh->shutdown (1); # freenet buggy?, well, it's java...	499	#$fh->shutdown (1); # freenet buggy?, well, it's java...
317		500
318	$self->{fh} = $fh;	501	$self->{fh} = $fh;
319		502
320	$Net::FCP::regcb->($self);	503	$self->{w} = $EVENT->new_from_fh ($fh)->cb(sub { $self->fh_ready_w })->poll(0, 1, 1);
321		504
322	$self;	505	$self;
323	}	506	}
324		507
		508	=item $txn = $txn->cb ($coderef)
		509
		510	Sets a callback to be called when the request is finished. The coderef
		511	will be called with the txn as it's sole argument, so it has to call
		512	C<result> itself.
		513
		514	Returns the txn object, useful for chaining.
		515
		516	Example:
		517
		518	$fcp->txn_client_get ("freenet:CHK....")
		519	->userdata ("ehrm")
		520	->cb(sub {
		521	my $data = shift->result;
		522	});
		523
		524	=cut
		525
		526	sub cb($$) {
		527	my ($self, $cb) = @_;
		528	$self->{cb} = $cb;
		529	$self;
		530	}
		531
		532	=item $txn = $txn->userdata ([$userdata])
		533
		534	Set user-specific data. This is useful in progress callbacks. The data can be accessed
		535	using C<< $txn->{userdata} >>.
		536
		537	Returns the txn object, useful for chaining.
		538
		539	=cut
		540
		541	sub userdata($$) {
		542	my ($self, $data) = @_;
		543	$self->{userdata} = $data;
		544	$self;
		545	}
		546
		547	=item $txn->cancel (%attr)
		548
		549	Cancels the operation with a C<cancel> exception anf the given attributes
		550	(consider at least giving the attribute C<reason>).
		551
		552	UNTESTED.
		553
		554	=cut
		555
		556	sub cancel {
		557	my ($self, %attr) = @_;
		558	$self->throw (Net::FCP::Exception->new (cancel => { %attr }));
		559	$self->set_result;
		560	$self->eof;
		561	}
		562
325	sub fh_ready {	563	sub fh_ready_w {
		564	my ($self) = @_;
		565
		566	my $len = syswrite $self->{fh}, $self->{sbuf};
		567
		568	if ($len > 0) {
		569	substr $self->{sbuf}, 0, $len, "";
		570	unless (length $self->{sbuf}) {
		571	fcntl $self->{fh}, F_SETFL, 0;
		572	$self->{w}->cb(sub { $self->fh_ready_r })->poll (1, 0, 1);
		573	}
		574	} elsif (defined $len) {
		575	$self->throw (Net::FCP::Exception->new (network_error => { reason => "unexpected end of file while writing" }));
		576	} else {
		577	$self->throw (Net::FCP::Exception->new (network_error => { reason => "$!" }));
		578	}
		579	}
		580
		581	sub fh_ready_r {
326	my ($self) = @_;	582	my ($self) = @_;
327		583
328	if (sysread $self->{fh}, $self->{buf}, 65536, length $self->{buf}) {	584	if (sysread $self->{fh}, $self->{buf}, 65536, length $self->{buf}) {
329	for (;;) {	585	for (;;) {
330	if ($self->{datalen}) {	586	if ($self->{datalen}) {
		587	#warn "expecting new datachunk $self->{datalen}, got ".(length $self->{buf})."\n";#d#
331	if (length $self->{buf} >= $self->{datalen}) {	588	if (length $self->{buf} >= $self->{datalen}) {
332	$self->recv_data (substr $self->{buf}, 0, $self->{datalen}, "");	589	$self->rcv_data (substr $self->{buf}, 0, delete $self->{datalen}, "");
333	} else {	590	} else {
334	last;	591	last;
335	}	592	}
336	} elsif ($self->{buf} =~ s/^DataChunk\015?\012Length=(\d+)\015?\012Data\015?\012//) {	593	} elsif ($self->{buf} =~ s/^DataChunk\015?\012Length=([0-9a-fA-F]+)\015?\012Data\015?\012//) {
337	$self->{datalen} = $1;	594	$self->{datalen} = hex $1;
		595	#warn "expecting new datachunk $self->{datalen}\n";#d#
338	} elsif ($self->{buf} =~ s/^([a-zA-Z]+)\015?\012(.*?)\015?\012EndMessage\015?\012//s) {	596	} elsif ($self->{buf} =~ s/^([a-zA-Z]+)\015?\012(?:(.+?)\015?\012)?EndMessage\015?\012//s) {
339	$self->rcv ($1, {	597	$self->rcv ($1, {
340	map { my ($a, $b) = split /=/, $_, 2; ((Net::FCP::tolc $a), $b) }	598	map { my ($a, $b) = split /=/, $_, 2; ((Net::FCP::tolc $a), $b) }
341	split /\015?\012/, $2	599	split /\015?\012/, $2
342	});	600	});
343	} else {	601	} else {
344	last;	602	last;
345	}	603	}
346	}	604	}
347	} else {	605	} else {
348	$Net::FCP::unregcb->($self);
349	delete $self->{fh};
350	$self->eof;	606	$self->eof;
351	}	607	}
352	}
353
354	sub rcv_data {
355	my ($self, $chunk) = @_;
356	}	608	}
357		609
358	sub rcv {	610	sub rcv {
359	my ($self, $type, $attr) = @_;	611	my ($self, $type, $attr) = @_;
360		612
361	$type = Net::FCP::tolc $type;	613	$type = Net::FCP::tolc $type;
		614
		615	#use PApp::Util; warn PApp::Util::dumpval [$type, $attr];
362		616
363	if (my $method = $self->can("rcv_$type")) {	617	if (my $method = $self->can("rcv_$type")) {
364	$method->($self, $attr, $type);	618	$method->($self, $attr, $type);
365	} else {	619	} else {
366	warn "received unexpected reply type '$type' for '$self->{type}', ignoring\n";	620	warn "received unexpected reply type '$type' for '$self->{type}', ignoring\n";
367	$self->eof;	621	}
		622	}
		623
		624	# used as a default exception thrower
		625	sub rcv_throw_exception {
		626	my ($self, $attr, $type) = @_;
		627	$self->throw (Net::FCP::Exception->new ($type, $attr));
		628	}
		629
		630	*rcv_failed = \&Net::FCP::Txn::rcv_throw_exception;
		631	*rcv_format_error = \&Net::FCP::Txn::rcv_throw_exception;
		632
		633	sub throw {
		634	my ($self, $exc) = @_;
		635
		636	$self->{exception} = $exc;
		637	$self->set_result;
		638	$self->eof; # must be last to avoid loops
		639	}
		640
		641	sub set_result {
		642	my ($self, $result) = @_;
		643
		644	unless (exists $self->{result}) {
		645	$self->{result} = $result;
		646	$self->{cb}->($self) if exists $self->{cb};
		647	$self->{signal}->send;
368	}	648	}
369	}	649	}
370		650
371	sub eof {	651	sub eof {
372	my ($self, $result) = @_;	652	my ($self) = @_;
373		653
374	$self->{result} = $result unless exists $self->{result};	654	delete $self->{w};
		655	delete $self->{fh};
		656
		657	delete $self->{fcp}{txn}{$self};
		658
		659	unless (exists $self->{result}) {
		660	$self->throw (Net::FCP::Exception->new (short_data => {
		661	reason => "unexpected eof or internal node error",
		662	}));
		663	}
		664	}
		665
		666	sub progress {
		667	my ($self, $type, $attr) = @_;
		668	$self->{fcp}->progress ($self, $type, $attr);
375	}	669	}
376		670
377	=item $result = $txn->result	671	=item $result = $txn->result
378		672
379	Waits until a result is available and then returns it.	673	Waits until a result is available and then returns it.
380		674
381	This waiting is (depending on your event modul) not very efficient, as it	675	This waiting is (depending on your event model) not very efficient, as it
382	is done outside the "mainloop".	676	is done outside the "mainloop".
383		677
384	=cut	678	=cut
385		679
386	sub result {	680	sub result {
387	my ($self) = @_;	681	my ($self) = @_;
388		682
389	$Net::FCP::waitcb->() while !exists $self->{result};	683	$self->{signal}->wait while !exists $self->{result};
		684
		685	die $self->{exception} if $self->{exception};
390		686
391	return $self->{result};	687	return $self->{result};
392	}
393
394	sub DESTROY {
395	$Net::FCP::unregcb->($_[0]);
396	}	688	}
397		689
398	package Net::FCP::Txn::ClientHello;	690	package Net::FCP::Txn::ClientHello;
399		691
400	use base Net::FCP::Txn;	692	use base Net::FCP::Txn;
401		693
402	sub rcv_node_hello {	694	sub rcv_node_hello {
403	my ($self, $attr) = @_;	695	my ($self, $attr) = @_;
404		696
405	$self->eof ($attr);	697	$self->set_result ($attr);
406	}	698	}
407		699
408	package Net::FCP::Txn::ClientInfo;	700	package Net::FCP::Txn::ClientInfo;
409		701
410	use base Net::FCP::Txn;	702	use base Net::FCP::Txn;
411		703
412	sub rcv_node_info {	704	sub rcv_node_info {
413	my ($self, $attr) = @_;	705	my ($self, $attr) = @_;
414		706
415	$self->eof ($attr);	707	$self->set_result ($attr);
416	}	708	}
417		709
418	package Net::FCP::Txn::GenerateCHK;	710	package Net::FCP::Txn::GenerateCHK;
419		711
420	use base Net::FCP::Txn;	712	use base Net::FCP::Txn;
421		713
422	sub rcv_success {	714	sub rcv_success {
423	my ($self, $attr) = @_;	715	my ($self, $attr) = @_;
424		716
425	$self->eof ($attr);	717	$self->set_result ($attr);
426	}	718	}
427		719
428	package Net::FCP::Txn::GenerateSVKPair;	720	package Net::FCP::Txn::GenerateSVKPair;
429		721
430	use base Net::FCP::Txn;	722	use base Net::FCP::Txn;
431		723
432	sub rcv_success {	724	sub rcv_success {
433	my ($self, $attr) = @_;	725	my ($self, $attr) = @_;
434
435	$self->eof ([$attr->{PublicKey}, $attr->{PrivateKey}]);	726	$self->set_result ([$attr->{PublicKey}, $attr->{PrivateKey}]);
436	}	727	}
437		728
438	package Net::FCP::Txn::InvertPrivateKey;	729	package Net::FCP::Txn::InsertPrivateKey;
439		730
440	use base Net::FCP::Txn;	731	use base Net::FCP::Txn;
441		732
442	sub rcv_success {	733	sub rcv_success {
443	my ($self, $attr) = @_;	734	my ($self, $attr) = @_;
444
445	$self->eof ($attr->{PublicKey});	735	$self->set_result ($attr->{PublicKey});
446	}	736	}
447		737
448	package Net::FCP::Txn::GetSize;	738	package Net::FCP::Txn::GetSize;
449		739
450	use base Net::FCP::Txn;	740	use base Net::FCP::Txn;
451		741
452	sub rcv_success {	742	sub rcv_success {
453	my ($self, $attr) = @_;	743	my ($self, $attr) = @_;
454
455	$self->eof ($attr->{Length});	744	$self->set_result ($attr->{Length});
		745	}
		746
		747	package Net::FCP::Txn::GetPut;
		748
		749	# base class for get and put
		750
		751	use base Net::FCP::Txn;
		752
		753	*rcv_uri_error = \&Net::FCP::Txn::rcv_throw_exception;
		754	*rcv_route_not_found = \&Net::FCP::Txn::rcv_throw_exception;
		755
		756	sub rcv_restarted {
		757	my ($self, $attr, $type) = @_;
		758
		759	delete $self->{datalength};
		760	delete $self->{metalength};
		761	delete $self->{data};
		762
		763	$self->progress ($type, $attr);
		764	}
		765
		766	package Net::FCP::Txn::ClientGet;
		767
		768	use base Net::FCP::Txn::GetPut;
		769
		770	*rcv_data_not_found = \&Net::FCP::Txn::rcv_throw_exception;
		771
		772	sub rcv_data {
		773	my ($self, $chunk) = @_;
		774
		775	$self->{data} .= $chunk;
		776
		777	$self->progress ("data", { chunk => length $chunk, total => length $self->{data}, end => $self->{datalength} });
		778
		779	if ($self->{datalength} == length $self->{data}) {
		780	my $data = delete $self->{data};
		781	my $meta = Net::FCP::parse_metadata substr $data, 0, $self->{metalength}, "";
		782
		783	$self->set_result ([$meta, $data]);
		784	}
		785	}
		786
		787	sub rcv_data_found {
		788	my ($self, $attr, $type) = @_;
		789
		790	$self->progress ($type, $attr);
		791
		792	$self->{datalength} = hex $attr->{data_length};
		793	$self->{metalength} = hex $attr->{metadata_length};
		794	}
		795
		796	package Net::FCP::Txn::ClientPut;
		797
		798	use base Net::FCP::Txn::GetPut;
		799
		800	*rcv_size_error = \&Net::FCP::Txn::rcv_throw_exception;
		801	*rcv_key_collision = \&Net::FCP::Txn::rcv_throw_exception;
		802
		803	sub rcv_pending {
		804	my ($self, $attr, $type) = @_;
		805	$self->progress ($type, $attr);
		806	}
		807
		808	sub rcv_success {
		809	my ($self, $attr, $type) = @_;
		810	$self->set_result ($attr);
		811	}
		812
		813	=back
		814
		815	=head2 The Net::FCP::Exception CLASS
		816
		817	Any unexpected (non-standard) responses that make it impossible to return
		818	the advertised result will result in an exception being thrown when the
		819	C<result> method is called.
		820
		821	These exceptions are represented by objects of this class.
		822
		823	=over 4
		824
		825	=cut
		826
		827	package Net::FCP::Exception;
		828
		829	use overload
		830	'""' => sub {
		831	"Net::FCP::Exception<<$_[0][0]," . (join ":", %{$_[0][1]}) . ">>\n";
		832	};
		833
		834	=item $exc = new Net::FCP::Exception $type, \%attr
		835
		836	Create a new exception object of the given type (a string like
		837	C<route_not_found>), and a hashref containing additional attributes
		838	(usually the attributes of the message causing the exception).
		839
		840	=cut
		841
		842	sub new {
		843	my ($class, $type, $attr) = @_;
		844
		845	bless [Net::FCP::tolc $type, { %$attr }], $class;
		846	}
		847
		848	=item $exc->type([$type])
		849
		850	With no arguments, returns the exception type. Otherwise a boolean
		851	indicating wether the exception is of the given type is returned.
		852
		853	=cut
		854
		855	sub type {
		856	my ($self, $type) = @_;
		857
		858	@_ >= 2
		859	? $self->[0] eq $type
		860	: $self->[0];
		861	}
		862
		863	=item $exc->attr([$attr])
		864
		865	With no arguments, returns the attributes. Otherwise the named attribute
		866	value is returned.
		867
		868	=cut
		869
		870	sub attr {
		871	my ($self, $attr) = @_;
		872
		873	@_ >= 2
		874	? $self->[1]{$attr}
		875	: $self->[1];
456	}	876	}
457		877
458	=back	878	=back
459		879
460	=head1 SEE ALSO	880	=head1 SEE ALSO

Diff Legend

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

Comparing Net-FCP/FCP.pm (file contents): Revision 1.2 by root, Sun Sep 7 23:20:20 2003 UTC vs. Revision 1.17 by root, Fri Sep 12 03:28:45 2003 UTC

Diff Legend

Comparing Net-FCP/FCP.pm (file contents):
Revision 1.2 by root, Sun Sep 7 23:20:20 2003 UTC vs.
Revision 1.17 by root, Fri Sep 12 03:28:45 2003 UTC