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

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

Diff Legend

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

Comparing Net-FCP/FCP.pm (file contents): Revision 1.1 by root, Sun Sep 7 22:57:40 2003 UTC vs. Revision 1.23 by root, Wed Sep 17 08:57:32 2003 UTC

Diff Legend

Comparing Net-FCP/FCP.pm (file contents):
Revision 1.1 by root, Sun Sep 7 22:57:40 2003 UTC vs.
Revision 1.23 by root, Wed Sep 17 08:57:32 2003 UTC