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