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

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.22 by root, Wed Sep 17 05:05:33 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.22 by root, Wed Sep 17 05:05:33 2003 UTC