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

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.20 by root, Mon Sep 15 00:05:32 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.20 by root, Mon Sep 15 00:05:32 2003 UTC