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

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.29 by root, Thu May 13 21:43:16 2004 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.29 by root, Thu May 13 21:43:16 2004 UTC