Commit upstream/0.29 - libipc-pubsub-perl

[svn-upgrade] Integrating new upstream version, libipc-pubsub-perl (0.29) Yves Agostini 15 years ago

16 changed file(s) with 627 addition(s) and 502 deletion(s). Raw diff Collapse all Expand all

+12

-0

Changes less more

	0	[Changes for 0.29 - 2008-12-13]
	1
	2	* Publisher and index fixes
	3
	4	* We don't need to force select_timeout anymore, and it causes
	5	explosions if called during global destruction, when $$self->[0]
	6	(_part_ of the pseudohash) may have gone missing already, but the
	7	object itself is still there. So $$self->{anything} explodes with
	8	"not a hash reference" _sometimes_, despite $$self always being an
	9	arrayref.
	10	..friends don't let friends use pseudohashes.
	11
0	12	[Changes for 0.28 - 2008-08-15]
1	13
2	14	* We now require DBM::Deep 1.00 or later.

-1

MANIFEST less more

22	22	MANIFEST This list of files
23	23	META.yml
24	24	README
	25	SIGNATURE Public-key signature (added by MakeMaker)
25	26	t/basic.t
26		SIGNATURE Public-key signature (added by MakeMaker)
	27	t/publisher.t

-2

META.yml less more

2	2	author:
3	3	- Audrey Tang <cpan@audreyt.org>
4	4	distribution_type: module
5		generated_by: Module::Install version 0.68
	5	generated_by: Module::Install version 0.70
6	6	license: MIT
7	7	meta-spec:
8	8	url: http://module-build.sourceforge.net/META-spec-v1.3.html

19	19	Storable: 0
20	20	Time::HiRes: 0
21	21	perl: 5.6.0
22		version: 0.28
	22	version: 0.29

+19

-18

SIGNATURE less more

13	13	-----BEGIN PGP SIGNED MESSAGE-----
14	14	Hash: SHA1
15	15
16		SHA1 8dab1d7a3df4b31edcb70b9c1f389e16694ad214 Changes
17		SHA1 86de90f247630310db0c9d7677f3dc7248400928 MANIFEST
18		SHA1 2be74a66af16824ef189ea5a4647ec8f96d475a7 META.yml
	16	SHA1 95bccc98dbd22f908804955ed1b93d1fd1307126 Changes
	17	SHA1 10db9ec4115d344c939604adb5622910dfa3103d MANIFEST
	18	SHA1 4bf7d07ec4a6c394c23e7d8bc33f266c5b2b0ba3 META.yml
19	19	SHA1 1efb0dda270171a9accec4db6643c6d9b81d6e78 Makefile.PL
20	20	SHA1 7edc5bba981fd5d734a9a095b3bddfed8d1acda0 README
21		SHA1 7e2cfa1b9efe0d502ee57717649c90ba4bd28ba9 inc/Module/Install.pm
22		SHA1 6e1392d80a0f239eecd5664f7f21f922cedb9329 inc/Module/Install/Base.pm
23		SHA1 f69417fe831d9cc22a78f00a617afadceade4d81 inc/Module/Install/Can.pm
24		SHA1 c61d02895330310048bf388881b5e2e064031561 inc/Module/Install/Fetch.pm
25		SHA1 54fcbed19232ec959bb17cfb4410599afc7f0779 inc/Module/Install/Makefile.pm
26		SHA1 7d3be9b158e37b2b2c22084740099955623b1d56 inc/Module/Install/Metadata.pm
27		SHA1 0a8b66180229ba2f9deaea1fedd0aacf7a7ace6b inc/Module/Install/Win32.pm
28		SHA1 d3352eb33fe43a5f3ead513f645224fe34d73bc9 inc/Module/Install/WriteAll.pm
29		SHA1 05f8adad5cad991d73499ee9dbcfba3fa59bbe56 lib/IPC/PubSub.pm
	21	SHA1 8b836389e4bc170eb8d19b7296b2f4978ac36136 inc/Module/Install.pm
	22	SHA1 85b32a1d5f215d99f411c3dd6113b537fcd5c57d inc/Module/Install/Base.pm
	23	SHA1 fde745e180861c7c0ba3ee5a767cafdbdb1d3ebd inc/Module/Install/Can.pm
	24	SHA1 e259400ceb54c34def9c994f52d7091108ce7ffc inc/Module/Install/Fetch.pm
	25	SHA1 da42b522e5a7ffbae0ceec900f3635ad9990c565 inc/Module/Install/Makefile.pm
	26	SHA1 ba005818ee9f97146bfa4e14e53c684e9e446902 inc/Module/Install/Metadata.pm
	27	SHA1 85e6b1cf5b7ca81bfb469a99389fa947d4b8a08e inc/Module/Install/Win32.pm
	28	SHA1 d32dff9f0d2f02023ca6d79a48d62fd855916351 inc/Module/Install/WriteAll.pm
	29	SHA1 51ee056caa49c8e736d5190566ccc00b6cb58fd0 lib/IPC/PubSub.pm
30	30	SHA1 0ed23d984f0dc09d76ed50c16a2b0aeaa71c8648 lib/IPC/PubSub/Cache.pm
31	31	SHA1 80b988a5d95ecb1689d58052cb139cf54ff482a4 lib/IPC/PubSub/Cache/DBM_Deep.pm
32	32	SHA1 4a865e5f6443b2fc2cd44e4b1e9aa9aba110b9c0 lib/IPC/PubSub/Cache/JiftyDBI.pm
33	33	SHA1 a6f3aee0362d3e8e9f7d063f5e40bbd8c6f0815e lib/IPC/PubSub/Cache/JiftyDBI/Stash.pm
34	34	SHA1 3b270ac2da87b439cde2a2755d1bea3b2a578a05 lib/IPC/PubSub/Cache/JiftyDBI/Stash/Item.pm
35	35	SHA1 84dd4abad24f85cc5a879dd2888134cc87351c7d lib/IPC/PubSub/Cache/JiftyDBI/Stash/Publisher.pm
36		SHA1 4a9a86a44e77a881e5121c18a04ba785a4d40355 lib/IPC/PubSub/Cache/Memcached.pm
	36	SHA1 78f87c95d2c66ffd9ed283cf84fff08298d3e6de lib/IPC/PubSub/Cache/Memcached.pm
37	37	SHA1 adaaa2bba258b95536c24d38ba3adc6ec5d8c9e4 lib/IPC/PubSub/Cache/PlainHash.pm
38	38	SHA1 5f34b5791db8193cc06fc25df2bfe33aa6cc0951 lib/IPC/PubSub/Cacheable.pm
39		SHA1 8ed88a7c02fe8146aa9255c8c48dec42142e0605 lib/IPC/PubSub/Publisher.pm
	39	SHA1 10cda8411ba967f8230c38056e6ccd984f06bc06 lib/IPC/PubSub/Publisher.pm
40	40	SHA1 33e500a83f8a7be3f1d5c9486a80a41566deac3b lib/IPC/PubSub/Subscriber.pm
41	41	SHA1 afc073bdc3a645a7a01646c0a08f575cc365f644 t/basic.t
	42	SHA1 140f4206abc483d51a64316123a73f0ccadb7e1b t/publisher.t
42	43	-----BEGIN PGP SIGNATURE-----
43		Version: GnuPG v1.4.3 (Darwin)
	44	Version: GnuPG v2.0.9 (GNU/Linux)
44	45
45		iD8DBQFIpGHStLPdNzw1AaARAmzGAJwJldKSqMxjF8efMJ1IevlLndtToQCbBCh4
46		tfkBv8DNKEVKzESDSzJJAcw=
47		=RTp8
	46	iEYEARECAAYFAklDVNIACgkQMflWJZZAbqAp+ACfS126BFH5oQX+brur3ylTs0Ei
	47	2C0AoLJX4i7F9IDUWSjn3zpXyxbiy154
	48	=m/eG
48	49	-----END PGP SIGNATURE-----

-1

inc/Module/Install/Base.pm less more

0	0	#line 1
1	1	package Module::Install::Base;
2	2
3		$VERSION = '0.68';
	3	$VERSION = '0.70';
4	4
5	5	# Suspend handler for "redefined" warnings
6	6	BEGIN {

-1

inc/Module/Install/Can.pm less more

10	10
11	11	use vars qw{$VERSION $ISCORE @ISA};
12	12	BEGIN {
13		$VERSION = '0.68';
	13	$VERSION = '0.70';
14	14	$ISCORE = 1;
15	15	@ISA = qw{Module::Install::Base};
16	16	}

-1

inc/Module/Install/Fetch.pm less more

5	5
6	6	use vars qw{$VERSION $ISCORE @ISA};
7	7	BEGIN {
8		$VERSION = '0.68';
	8	$VERSION = '0.70';
9	9	$ISCORE = 1;
10	10	@ISA = qw{Module::Install::Base};
11	11	}

+14

-6

inc/Module/Install/Makefile.pm less more

6	6
7	7	use vars qw{$VERSION $ISCORE @ISA};
8	8	BEGIN {
9		$VERSION = '0.68';
	9	$VERSION = '0.70';
10	10	$ISCORE = 1;
11	11	@ISA = qw{Module::Install::Base};
12	12	}

36	36	sub makemaker_args {
37	37	my $self = shift;
38	38	my $args = ($self->{makemaker_args} \|\|= {});
39		%$args = ( %$args, @_ ) if @_;
	39	%$args = ( %$args, @_ ) if @_;
40	40	$args;
41	41	}
42	42

103	103	unless ( -d $dir ) {
104	104	die "tests_recursive dir '$dir' does not exist";
105	105	}
	106	%test_dir = ();
106	107	require File::Find;
107		%test_dir = ();
108	108	File::Find::find( \&_wanted_t, $dir );
109	109	$self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
110	110	}

113	113	my $self = shift;
114	114	die "&Makefile->write() takes no arguments\n" if @_;
115	115
	116	# Make sure we have a new enough
	117	require ExtUtils::MakeMaker;
	118	$self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION );
	119
	120	# Generate the
116	121	my $args = $self->makemaker_args;
117	122	$args->{DISTNAME} = $self->name;
118	123	$args->{NAME} = $self->module_name \|\| $self->name \|\| $self->determine_NAME($args);

141	146	map { @$_ }
142	147	map { @$_ }
143	148	grep $_,
144		($self->build_requires, $self->requires)
	149	($self->configure_requires, $self->build_requires, $self->requires)
145	150	);
	151
	152	# Remove any reference to perl, PREREQ_PM doesn't support it
	153	delete $args->{PREREQ_PM}->{perl};
146	154
147	155	# merge both kinds of requires into prereq_pm
148	156	my $subdirs = ($args->{DIR} \|\|= []);

204	212	#$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m;
205	213
206	214	# Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well.
207		$makefile =~ s/("?)-I\$$PERL_LIB$\1//g;
	215	$makefile =~ s/(\"?)-I\$$PERL_LIB$\1//g;
208	216
209	217	# XXX - This is currently unused; not sure if it breaks other MM-users
210	218	# $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;

233	241
234	242	__END__
235	243
236		#line 363
	244	#line 371

+223

-241

inc/Module/Install/Metadata.pm less more

5	5
6	6	use vars qw{$VERSION $ISCORE @ISA};
7	7	BEGIN {
8		$VERSION = '0.68';
	8	$VERSION = '0.70';
9	9	$ISCORE = 1;
10	10	@ISA = qw{Module::Install::Base};
11	11	}
12	12
13	13	my @scalar_keys = qw{
14		name module_name abstract author version license
15		distribution_type perl_version tests installdirs
	14	name module_name abstract author version license
	15	distribution_type perl_version tests installdirs
16	16	};
17	17
18	18	my @tuple_keys = qw{
19		build_requires requires recommends bundles
	19	configure_requires build_requires requires recommends bundles
20	20	};
21	21
22	22	sub Meta { shift }

24	24	sub Meta_TupleKeys { @tuple_keys }
25	25
26	26	foreach my $key (@scalar_keys) {
27		*$key = sub {
28		my $self = shift;
29		return $self->{values}{$key} if defined wantarray and !@_;
30		$self->{values}{$key} = shift;
31		return $self;
32		};
	27	*$key = sub {
	28	my $self = shift;
	29	return $self->{values}{$key} if defined wantarray and !@_;
	30	$self->{values}{$key} = shift;
	31	return $self;
	32	};
33	33	}
34	34
35	35	foreach my $key (@tuple_keys) {
36		*$key = sub {
37		my $self = shift;
38		return $self->{values}{$key} unless @_;
39
40		my @rv;
41		while (@_) {
42		my $module = shift or last;
43		my $version = shift \|\| 0;
44		if ( $module eq 'perl' ) {
45		$version =~ s{^(\d+)\.(\d+)\.(\d+)}
46		{$1 + $2/1_000 + $3/1_000_000}e;
47		$self->perl_version($version);
48		next;
49		}
50		my $rv = [ $module, $version ];
51		push @rv, $rv;
52		}
53		push @{ $self->{values}{$key} }, @rv;
54		@rv;
55		};
56		}
57
58		# configure_requires is currently a null-op
59		sub configure_requires { 1 }
	36	*$key = sub {
	37	my $self = shift;
	38	return $self->{values}{$key} unless @_;
	39
	40	my @rv;
	41	while (@_) {
	42	my $module = shift or last;
	43	my $version = shift \|\| 0;
	44	if ( $module eq 'perl' ) {
	45	$version =~ s{^(\d+)\.(\d+)\.(\d+)}
	46	{$1 + $2/1_000 + $3/1_000_000}e;
	47	$self->perl_version($version);
	48	next;
	49	}
	50	my $rv = [ $module, $version ];
	51	push @rv, $rv;
	52	}
	53	push @{ $self->{values}{$key} }, @rv;
	54	@rv;
	55	};
	56	}
60	57
61	58	# Aliases for build_requires that will have alternative
62	59	# meanings in some future version of META.yml.

70	67	sub install_as_vendor { $_[0]->installdirs('vendor') }
71	68
72	69	sub sign {
73		my $self = shift;
74		return $self->{'values'}{'sign'} if defined wantarray and ! @_;
75		$self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 );
76		return $self;
	70	my $self = shift;
	71	return $self->{'values'}{'sign'} if defined wantarray and ! @_;
	72	$self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 );
	73	return $self;
77	74	}
78	75
79	76	sub dynamic_config {

87	84	}
88	85
89	86	sub all_from {
90		my ( $self, $file ) = @_;
91
92		unless ( defined($file) ) {
93		my $name = $self->name
94		or die "all_from called with no args without setting name() first";
95		$file = join('/', 'lib', split(/-/, $name)) . '.pm';
96		$file =~ s{.*/}{} unless -e $file;
97		die "all_from: cannot find $file from $name" unless -e $file;
98		}
99
100		$self->version_from($file) unless $self->version;
101		$self->perl_version_from($file) unless $self->perl_version;
102
103		# The remaining probes read from POD sections; if the file
104		# has an accompanying .pod, use that instead
105		my $pod = $file;
106		if ( $pod =~ s/\.pm$/.pod/i and -e $pod ) {
107		$file = $pod;
108		}
109
110		$self->author_from($file) unless $self->author;
111		$self->license_from($file) unless $self->license;
112		$self->abstract_from($file) unless $self->abstract;
	87	my ( $self, $file ) = @_;
	88
	89	unless ( defined($file) ) {
	90	my $name = $self->name
	91	or die "all_from called with no args without setting name() first";
	92	$file = join('/', 'lib', split(/-/, $name)) . '.pm';
	93	$file =~ s{.*/}{} unless -e $file;
	94	die "all_from: cannot find $file from $name" unless -e $file;
	95	}
	96
	97	$self->version_from($file) unless $self->version;
	98	$self->perl_version_from($file) unless $self->perl_version;
	99
	100	# The remaining probes read from POD sections; if the file
	101	# has an accompanying .pod, use that instead
	102	my $pod = $file;
	103	if ( $pod =~ s/\.pm$/.pod/i and -e $pod ) {
	104	$file = $pod;
	105	}
	106
	107	$self->author_from($file) unless $self->author;
	108	$self->license_from($file) unless $self->license;
	109	$self->abstract_from($file) unless $self->abstract;
113	110	}
114	111
115	112	sub provides {
116		my $self = shift;
117		my $provides = ( $self->{values}{provides} \|\|= {} );
118		%$provides = (%$provides, @_) if @_;
119		return $provides;
	113	my $self = shift;
	114	my $provides = ( $self->{values}{provides} \|\|= {} );
	115	%$provides = (%$provides, @_) if @_;
	116	return $provides;
120	117	}
121	118
122	119	sub auto_provides {
123		my $self = shift;
124		return $self unless $self->is_admin;
125
126		unless (-e 'MANIFEST') {
127		warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
128		return $self;
129		}
130
131		# Avoid spurious warnings as we are not checking manifest here.
132
133		local $SIG{__WARN__} = sub {1};
134		require ExtUtils::Manifest;
135		local *ExtUtils::Manifest::manicheck = sub { return };
136
137		require Module::Build;
138		my $build = Module::Build->new(
139		dist_name => $self->name,
140		dist_version => $self->version,
141		license => $self->license,
142		);
143		$self->provides(%{ $build->find_dist_packages \|\| {} });
	120	my $self = shift;
	121	return $self unless $self->is_admin;
	122	unless (-e 'MANIFEST') {
	123	warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
	124	return $self;
	125	}
	126	# Avoid spurious warnings as we are not checking manifest here.
	127	local $SIG{__WARN__} = sub {1};
	128	require ExtUtils::Manifest;
	129	local *ExtUtils::Manifest::manicheck = sub { return };
	130
	131	require Module::Build;
	132	my $build = Module::Build->new(
	133	dist_name => $self->name,
	134	dist_version => $self->version,
	135	license => $self->license,
	136	);
	137	$self->provides( %{ $build->find_dist_packages \|\| {} } );
144	138	}
145	139
146	140	sub feature {
147		my $self = shift;
148		my $name = shift;
149		my $features = ( $self->{values}{features} \|\|= [] );
150
151		my $mods;
152
153		if ( @_ == 1 and ref( $_[0] ) ) {
154		# The user used ->feature like ->features by passing in the second
155		# argument as a reference. Accomodate for that.
156		$mods = $_[0];
157		} else {
158		$mods = \@_;
159		}
160
161		my $count = 0;
162		push @$features, (
163		$name => [
164		map {
165		ref($_) ? ( ref($_) eq 'HASH' ) ? %$_
166		: @$_
167		: $_
168		} @$mods
169		]
170		);
171
172		return @$features;
	141	my $self = shift;
	142	my $name = shift;
	143	my $features = ( $self->{values}{features} \|\|= [] );
	144	my $mods;
	145
	146	if ( @_ == 1 and ref( $_[0] ) ) {
	147	# The user used ->feature like ->features by passing in the second
	148	# argument as a reference. Accomodate for that.
	149	$mods = $_[0];
	150	} else {
	151	$mods = \@_;
	152	}
	153
	154	my $count = 0;
	155	push @$features, (
	156	$name => [
	157	map {
	158	ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_
	159	} @$mods
	160	]
	161	);
	162
	163	return @$features;
173	164	}
174	165
175	166	sub features {
176		my $self = shift;
177		while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
178		$self->feature( $name, @$mods );
179		}
180		return $self->{values}->{features}
181		? @{ $self->{values}->{features} }
182		: ();
	167	my $self = shift;
	168	while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
	169	$self->feature( $name, @$mods );
	170	}
	171	return $self->{values}->{features}
	172	? @{ $self->{values}->{features} }
	173	: ();
183	174	}
184	175
185	176	sub no_index {
186		my $self = shift;
187		my $type = shift;
188		push @{ $self->{values}{no_index}{$type} }, @_ if $type;
189		return $self->{values}{no_index};
	177	my $self = shift;
	178	my $type = shift;
	179	push @{ $self->{values}{no_index}{$type} }, @_ if $type;
	180	return $self->{values}{no_index};
190	181	}
191	182
192	183	sub read {
193		my $self = shift;
194		$self->include_deps( 'YAML', 0 );
195
196		require YAML;
197		my $data = YAML::LoadFile('META.yml');
198
199		# Call methods explicitly in case user has already set some values.
200		while ( my ( $key, $value ) = each %$data ) {
201		next unless $self->can($key);
202		if ( ref $value eq 'HASH' ) {
203		while ( my ( $module, $version ) = each %$value ) {
204		$self->can($key)->($self, $module => $version );
205		}
206		}
207		else {
208		$self->can($key)->($self, $value);
209		}
210		}
211		return $self;
	184	my $self = shift;
	185	$self->include_deps( 'YAML', 0 );
	186
	187	require YAML;
	188	my $data = YAML::LoadFile('META.yml');
	189
	190	# Call methods explicitly in case user has already set some values.
	191	while ( my ( $key, $value ) = each %$data ) {
	192	next unless $self->can($key);
	193	if ( ref $value eq 'HASH' ) {
	194	while ( my ( $module, $version ) = each %$value ) {
	195	$self->can($key)->($self, $module => $version );
	196	}
	197	} else {
	198	$self->can($key)->($self, $value);
	199	}
	200	}
	201	return $self;
212	202	}
213	203
214	204	sub write {
215		my $self = shift;
216		return $self unless $self->is_admin;
217		$self->admin->write_meta;
218		return $self;
	205	my $self = shift;
	206	return $self unless $self->is_admin;
	207	$self->admin->write_meta;
	208	return $self;
219	209	}
220	210
221	211	sub version_from {
222		my ( $self, $file ) = @_;
223		require ExtUtils::MM_Unix;
224		$self->version( ExtUtils::MM_Unix->parse_version($file) );
	212	require ExtUtils::MM_Unix;
	213	my ( $self, $file ) = @_;
	214	$self->version( ExtUtils::MM_Unix->parse_version($file) );
225	215	}
226	216
227	217	sub abstract_from {
228		my ( $self, $file ) = @_;
229		require ExtUtils::MM_Unix;
230		$self->abstract(
231		bless(
232		{ DISTNAME => $self->name },
233		'ExtUtils::MM_Unix'
234		)->parse_abstract($file)
235		);
	218	require ExtUtils::MM_Unix;
	219	my ( $self, $file ) = @_;
	220	$self->abstract(
	221	bless(
	222	{ DISTNAME => $self->name },
	223	'ExtUtils::MM_Unix'
	224	)->parse_abstract($file)
	225	);
236	226	}
237	227
238	228	sub _slurp {
239		my ( $self, $file ) = @_;
240
241		local *FH;
242		open FH, "< $file" or die "Cannot open $file.pod: $!";
243		do { local $/; <FH> };
	229	local *FH;
	230	open FH, "< $_[1]" or die "Cannot open $_[1].pod: $!";
	231	do { local $/; <FH> };
244	232	}
245	233
246	234	sub perl_version_from {
247		my ( $self, $file ) = @_;
248
249		if (
250		$self->_slurp($file) =~ m/
251		^
252		use \s*
253		v?
254		([\d_\.]+)
255		\s* ;
256		/ixms
257		)
258		{
259		my $v = $1;
260		$v =~ s{_}{}g;
261		$self->perl_version($1);
262		}
263		else {
264		warn "Cannot determine perl version info from $file\n";
265		return;
266		}
	235	my ( $self, $file ) = @_;
	236	if (
	237	$self->_slurp($file) =~ m/
	238	^
	239	use \s*
	240	v?
	241	([\d_\.]+)
	242	\s* ;
	243	/ixms
	244	) {
	245	my $v = $1;
	246	$v =~ s{_}{}g;
	247	$self->perl_version($1);
	248	} else {
	249	warn "Cannot determine perl version info from $file\n";
	250	return;
	251	}
267	252	}
268	253
269	254	sub author_from {
270		my ( $self, $file ) = @_;
271		my $content = $self->_slurp($file);
272		if ($content =~ m/
273		=head \d \s+ (?:authors?)\b \s*
274		([^\n]*)
275		\|
276		=head \d \s+ (?:licen[cs]e\|licensing\|copyright\|legal)\b \s*
277		.? copyright .? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
278		([^\n]*)
279		/ixms) {
280		my $author = $1 \|\| $2;
281		$author =~ s{E<lt>}{<}g;
282		$author =~ s{E<gt>}{>}g;
283		$self->author($author);
284		}
285		else {
286		warn "Cannot determine author info from $file\n";
287		}
	255	my ( $self, $file ) = @_;
	256	my $content = $self->_slurp($file);
	257	if ($content =~ m/
	258	=head \d \s+ (?:authors?)\b \s*
	259	([^\n]*)
	260	\|
	261	=head \d \s+ (?:licen[cs]e\|licensing\|copyright\|legal)\b \s*
	262	.? copyright .? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
	263	([^\n]*)
	264	/ixms) {
	265	my $author = $1 \|\| $2;
	266	$author =~ s{E<lt>}{<}g;
	267	$author =~ s{E<gt>}{>}g;
	268	$self->author($author);
	269	} else {
	270	warn "Cannot determine author info from $file\n";
	271	}
288	272	}
289	273
290	274	sub license_from {
291		my ( $self, $file ) = @_;
292
293		if (
294		$self->_slurp($file) =~ m/
295		(
296		=head \d \s+
297		(?:licen[cs]e\|licensing\|copyright\|legal)\b
298		.*?
299		)
300		(=head\\d.\|=cut.\|)
301		\z
302		/ixms
303		)
304		{
305		my $license_text = $1;
306		my @phrases = (
307		'under the same (?:terms\|license) as perl itself' => 'perl', 1,
308		'GNU public license' => 'gpl', 1,
309		'GNU lesser public license' => 'gpl', 1,
310		'BSD license' => 'bsd', 1,
311		'Artistic license' => 'artistic', 1,
312		'GPL' => 'gpl', 1,
313		'LGPL' => 'lgpl', 1,
314		'BSD' => 'bsd', 1,
315		'Artistic' => 'artistic', 1,
316		'MIT' => 'mit', 1,
317		'proprietary' => 'proprietary', 0,
318		);
319		while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
320		$pattern =~ s{\s+}{\\s+}g;
321		if ( $license_text =~ /\b$pattern\b/i ) {
322		if ( $osi and $license_text =~ /All rights reserved/i ) {
323		warn "LEGAL WARNING: 'All rights reserved' may invalidate Open Source licenses. Consider removing it.";
	275	my ( $self, $file ) = @_;
	276
	277	if (
	278	$self->_slurp($file) =~ m/
	279	(
	280	=head \d \s+
	281	(?:licen[cs]e\|licensing\|copyright\|legal)\b
	282	.*?
	283	)
	284	(=head\\d.\|=cut.\|)
	285	\z
	286	/ixms ) {
	287	my $license_text = $1;
	288	my @phrases = (
	289	'under the same (?:terms\|license) as perl itself' => 'perl', 1,
	290	'GNU public license' => 'gpl', 1,
	291	'GNU lesser public license' => 'lgpl', 1,
	292	'BSD license' => 'bsd', 1,
	293	'Artistic license' => 'artistic', 1,
	294	'GPL' => 'gpl', 1,
	295	'LGPL' => 'lgpl', 1,
	296	'BSD' => 'bsd', 1,
	297	'Artistic' => 'artistic', 1,
	298	'MIT' => 'mit', 1,
	299	'proprietary' => 'proprietary', 0,
	300	);
	301	while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
	302	$pattern =~ s{\s+}{\\s+}g;
	303	if ( $license_text =~ /\b$pattern\b/i ) {
	304	if ( $osi and $license_text =~ /All rights reserved/i ) {
	305	warn "LEGAL WARNING: 'All rights reserved' may invalidate Open Source licenses. Consider removing it.";
	306	}
	307	$self->license($license);
	308	return 1;
	309	}
324	310	}
325		$self->license($license);
326		return 1;
327		}
328		}
329		}
330
331		warn "Cannot determine license info from $file\n";
332		return 'unknown';
	311	}
	312
	313	warn "Cannot determine license info from $file\n";
	314	return 'unknown';
333	315	}
334	316
335	317	1;

-7

inc/Module/Install/Win32.pm less more

3	3	use strict;
4	4	use Module::Install::Base;
5	5
6		use vars qw{$VERSION $ISCORE @ISA};
	6	use vars qw{$VERSION @ISA $ISCORE};
7	7	BEGIN {
8		$VERSION = '0.68';
	8	$VERSION = '0.70';
	9	@ISA = qw{Module::Install::Base};
9	10	$ISCORE = 1;
10		@ISA = qw{Module::Install::Base};
11	11	}
12	12
13	13	# determine if the user needs nmake, and download it if needed

15	15	my $self = shift;
16	16	$self->load('can_run');
17	17	$self->load('get_file');
18
	18
19	19	require Config;
20	20	return unless (
21	21	$^O eq 'MSWin32' and

37	37	remove => 1,
38	38	);
39	39
40		if (!$rv) {
41		die <<'END_MESSAGE';
	40	die <<'END_MESSAGE' unless $rv;
42	41
43	42	-------------------------------------------------------------------------------
44	43

58	57
59	58	-------------------------------------------------------------------------------
60	59	END_MESSAGE
61		}
	60
62	61	}
63	62
64	63	1;

+24

-27

inc/Module/Install/WriteAll.pm less more

3	3	use strict;
4	4	use Module::Install::Base;
5	5
6		use vars qw{$VERSION $ISCORE @ISA};
	6	use vars qw{$VERSION @ISA $ISCORE};
7	7	BEGIN {
8		$VERSION = '0.68';
	8	$VERSION = '0.70';
	9	@ISA = qw{Module::Install::Base};
9	10	$ISCORE = 1;
10		@ISA = qw{Module::Install::Base};
11	11	}
12	12
13	13	sub WriteAll {
14		my $self = shift;
15		my %args = (
16		meta => 1,
17		sign => 0,
18		inline => 0,
19		check_nmake => 1,
20		@_
21		);
	14	my $self = shift;
	15	my %args = (
	16	meta => 1,
	17	sign => 0,
	18	inline => 0,
	19	check_nmake => 1,
	20	@_,
	21	);
22	22
23		$self->sign(1) if $args{sign};
24		$self->Meta->write if $args{meta};
25		$self->admin->WriteAll(%args) if $self->is_admin;
	23	$self->sign(1) if $args{sign};
	24	$self->Meta->write if $args{meta};
	25	$self->admin->WriteAll(%args) if $self->is_admin;
26	26
27		if ( $0 =~ /Build.PL$/i ) {
28		$self->Build->write;
29		} else {
30		$self->check_nmake if $args{check_nmake};
31		unless ( $self->makemaker_args->{'PL_FILES'} ) {
32		$self->makemaker_args( PL_FILES => {} );
33		}
34		if ($args{inline}) {
35		$self->Inline->write;
36		} else {
37		$self->Makefile->write;
38		}
39		}
	27	$self->check_nmake if $args{check_nmake};
	28	unless ( $self->makemaker_args->{PL_FILES} ) {
	29	$self->makemaker_args( PL_FILES => {} );
	30	}
	31
	32	if ( $args{inline} ) {
	33	$self->Inline->write;
	34	} else {
	35	$self->Makefile->write;
	36	}
40	37	}
41	38
42	39	1;

+217

-185

inc/Module/Install.pm less more

16	16	# 3. The ./inc/ version of Module::Install loads
17	17	# }
18	18
19		use 5.004;
	19	BEGIN {
	20	require 5.004;
	21	}
20	22	use strict 'vars';
21	23
22	24	use vars qw{$VERSION};
23	25	BEGIN {
24		# All Module::Install core packages now require synchronised versions.
25		# This will be used to ensure we don't accidentally load old or
26		# different versions of modules.
27		# This is not enforced yet, but will be some time in the next few
28		# releases once we can make sure it won't clash with custom
29		# Module::Install extensions.
30		$VERSION = '0.68';
31		}
	26	# All Module::Install core packages now require synchronised versions.
	27	# This will be used to ensure we don't accidentally load old or
	28	# different versions of modules.
	29	# This is not enforced yet, but will be some time in the next few
	30	# releases once we can make sure it won't clash with custom
	31	# Module::Install extensions.
	32	$VERSION = '0.70';
	33	}
	34
	35
	36
	37
32	38
33	39	# Whether or not inc::Module::Install is actually loaded, the
34	40	# $INC{inc/Module/Install.pm} is what will still get set as long as

37	43	# they may not have a MI version that works with the Makefile.PL. This would
38	44	# result in false errors or unexpected behaviour. And we don't want that.
39	45	my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
40		unless ( $INC{$file} ) {
41		die <<"END_DIE";
	46	unless ( $INC{$file} ) { die <<"END_DIE" }
	47
42	48	Please invoke ${\__PACKAGE__} with:
43	49
44		use inc::${\__PACKAGE__};
	50	use inc::${\__PACKAGE__};
45	51
46	52	not:
47	53
48		use ${\__PACKAGE__};
	54	use ${\__PACKAGE__};
49	55
50	56	END_DIE
51		}
	57
	58
	59
	60
52	61
53	62	# If the script that is loading Module::Install is from the future,
54	63	# then make will detect this and cause it to re-run over and over
55	64	# again. This is bad. Rather than taking action to touch it (which
56	65	# is unreliable on some platforms and requires write permissions)
57	66	# for now we should catch this and refuse to run.
58		if ( -f $0 and (stat($0))[9] > time ) {
59		die << "END_DIE";
	67	if ( -f $0 and (stat($0))[9] > time ) { die <<"END_DIE" }
	68
60	69	Your installer $0 has a modification time in the future.
61	70
62	71	This is known to create infinite loops in make.

64	73	Please correct this, then run $0 again.
65	74
66	75	END_DIE
67		}
	76
	77
	78
	79
	80
	81	# Build.PL was formerly supported, but no longer is due to excessive
	82	# difficulty in implementing every single feature twice.
	83	if ( $0 =~ /Build.PL$/i or -f 'Build.PL' ) { die <<"END_DIE" }
	84
	85	Module::Install no longer supports Build.PL.
	86
	87	It was impossible to maintain duel backends, and has been deprecated.
	88
	89	Please remove all Build.PL files and only use the Makefile.PL installer.
	90
	91	END_DIE
	92
	93
	94
	95
68	96
69	97	use Cwd ();
70	98	use File::Find ();

75	103	@inc::Module::Install::ISA = __PACKAGE__;
76	104
77	105	sub autoload {
78		my $self = shift;
79		my $who = $self->_caller;
80		my $cwd = Cwd::cwd();
81		my $sym = "${who}::AUTOLOAD";
82		$sym->{$cwd} = sub {
83		my $pwd = Cwd::cwd();
84		if ( my $code = $sym->{$pwd} ) {
85		# delegate back to parent dirs
86		goto &$code unless $cwd eq $pwd;
87		}
88		$$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
89		unshift @_, ($self, $1);
90		goto &{$self->can('call')} unless uc($1) eq $1;
91		};
	106	my $self = shift;
	107	my $who = $self->_caller;
	108	my $cwd = Cwd::cwd();
	109	my $sym = "${who}::AUTOLOAD";
	110	$sym->{$cwd} = sub {
	111	my $pwd = Cwd::cwd();
	112	if ( my $code = $sym->{$pwd} ) {
	113	# delegate back to parent dirs
	114	goto &$code unless $cwd eq $pwd;
	115	}
	116	$$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
	117	unshift @_, ( $self, $1 );
	118	goto &{$self->can('call')} unless uc($1) eq $1;
	119	};
92	120	}
93	121
94	122	sub import {
95		my $class = shift;
96		my $self = $class->new(@_);
97		my $who = $self->_caller;
98
99		unless ( -f $self->{file} ) {
100		require "$self->{path}/$self->{dispatch}.pm";
101		File::Path::mkpath("$self->{prefix}/$self->{author}");
102		$self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
103		$self->{admin}->init;
104		@_ = ($class, _self => $self);
105		goto &{"$self->{name}::import"};
106		}
107
108		*{"${who}::AUTOLOAD"} = $self->autoload;
109		$self->preload;
110
111		# Unregister loader and worker packages so subdirs can use them again
112		delete $INC{"$self->{file}"};
113		delete $INC{"$self->{path}.pm"};
	123	my $class = shift;
	124	my $self = $class->new(@_);
	125	my $who = $self->_caller;
	126
	127	unless ( -f $self->{file} ) {
	128	require "$self->{path}/$self->{dispatch}.pm";
	129	File::Path::mkpath("$self->{prefix}/$self->{author}");
	130	$self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
	131	$self->{admin}->init;
	132	@_ = ($class, _self => $self);
	133	goto &{"$self->{name}::import"};
	134	}
	135
	136	*{"${who}::AUTOLOAD"} = $self->autoload;
	137	$self->preload;
	138
	139	# Unregister loader and worker packages so subdirs can use them again
	140	delete $INC{"$self->{file}"};
	141	delete $INC{"$self->{path}.pm"};
	142
	143	return 1;
114	144	}
115	145
116	146	sub preload {
117		my ($self) = @_;
118
119		unless ( $self->{extensions} ) {
120		$self->load_extensions(
121		"$self->{prefix}/$self->{path}", $self
122		);
123		}
124
125		my @exts = @{$self->{extensions}};
126		unless ( @exts ) {
127		my $admin = $self->{admin};
128		@exts = $admin->load_all_extensions;
129		}
130
131		my %seen;
132		foreach my $obj ( @exts ) {
133		while (my ($method, $glob) = each %{ref($obj) . '::'}) {
134		next unless $obj->can($method);
135		next if $method =~ /^_/;
136		next if $method eq uc($method);
137		$seen{$method}++;
138		}
139		}
140
141		my $who = $self->_caller;
142		foreach my $name ( sort keys %seen ) {
143		*{"${who}::$name"} = sub {
144		${"${who}::AUTOLOAD"} = "${who}::$name";
145		goto &{"${who}::AUTOLOAD"};
146		};
147		}
	147	my ($self) = @_;
	148
	149	unless ( $self->{extensions} ) {
	150	$self->load_extensions(
	151	"$self->{prefix}/$self->{path}", $self
	152	);
	153	}
	154
	155	my @exts = @{$self->{extensions}};
	156	unless ( @exts ) {
	157	my $admin = $self->{admin};
	158	@exts = $admin->load_all_extensions;
	159	}
	160
	161	my %seen;
	162	foreach my $obj ( @exts ) {
	163	while (my ($method, $glob) = each %{ref($obj) . '::'}) {
	164	next unless $obj->can($method);
	165	next if $method =~ /^_/;
	166	next if $method eq uc($method);
	167	$seen{$method}++;
	168	}
	169	}
	170
	171	my $who = $self->_caller;
	172	foreach my $name ( sort keys %seen ) {
	173	*{"${who}::$name"} = sub {
	174	${"${who}::AUTOLOAD"} = "${who}::$name";
	175	goto &{"${who}::AUTOLOAD"};
	176	};
	177	}
148	178	}
149	179
150	180	sub new {
151		my ($class, %args) = @_;
152
153		# ignore the prefix on extension modules built from top level.
154		my $base_path = Cwd::abs_path($FindBin::Bin);
155		unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
156		delete $args{prefix};
157		}
158
159		return $args{_self} if $args{_self};
160
161		$args{dispatch} \|\|= 'Admin';
162		$args{prefix} \|\|= 'inc';
163		$args{author} \|\|= ($^O eq 'VMS' ? '_author' : '.author');
164		$args{bundle} \|\|= 'inc/BUNDLES';
165		$args{base} \|\|= $base_path;
166		$class =~ s/^\Q$args{prefix}\E:://;
167		$args{name} \|\|= $class;
168		$args{version} \|\|= $class->VERSION;
169		unless ( $args{path} ) {
170		$args{path} = $args{name};
171		$args{path} =~ s!::!/!g;
172		}
173		$args{file} \|\|= "$args{base}/$args{prefix}/$args{path}.pm";
174
175		bless( \%args, $class );
	181	my ($class, %args) = @_;
	182
	183	# ignore the prefix on extension modules built from top level.
	184	my $base_path = Cwd::abs_path($FindBin::Bin);
	185	unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
	186	delete $args{prefix};
	187	}
	188
	189	return $args{_self} if $args{_self};
	190
	191	$args{dispatch} \|\|= 'Admin';
	192	$args{prefix} \|\|= 'inc';
	193	$args{author} \|\|= ($^O eq 'VMS' ? '_author' : '.author');
	194	$args{bundle} \|\|= 'inc/BUNDLES';
	195	$args{base} \|\|= $base_path;
	196	$class =~ s/^\Q$args{prefix}\E:://;
	197	$args{name} \|\|= $class;
	198	$args{version} \|\|= $class->VERSION;
	199	unless ( $args{path} ) {
	200	$args{path} = $args{name};
	201	$args{path} =~ s!::!/!g;
	202	}
	203	$args{file} \|\|= "$args{base}/$args{prefix}/$args{path}.pm";
	204
	205	bless( \%args, $class );
176	206	}
177	207
178	208	sub call {

183	213	}
184	214
185	215	sub load {
186		my ($self, $method) = @_;
187
188		$self->load_extensions(
189		"$self->{prefix}/$self->{path}", $self
190		) unless $self->{extensions};
191
192		foreach my $obj (@{$self->{extensions}}) {
193		return $obj if $obj->can($method);
194		}
195
196		my $admin = $self->{admin} or die <<"END_DIE";
	216	my ($self, $method) = @_;
	217
	218	$self->load_extensions(
	219	"$self->{prefix}/$self->{path}", $self
	220	) unless $self->{extensions};
	221
	222	foreach my $obj (@{$self->{extensions}}) {
	223	return $obj if $obj->can($method);
	224	}
	225
	226	my $admin = $self->{admin} or die <<"END_DIE";
197	227	The '$method' method does not exist in the '$self->{prefix}' path!
198	228	Please remove the '$self->{prefix}' directory and run $0 again to load it.
199	229	END_DIE
200	230
201		my $obj = $admin->load($method, 1);
202		push @{$self->{extensions}}, $obj;
203
204		$obj;
	231	my $obj = $admin->load($method, 1);
	232	push @{$self->{extensions}}, $obj;
	233
	234	$obj;
205	235	}
206	236
207	237	sub load_extensions {
208		my ($self, $path, $top) = @_;
209
210		unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
211		unshift @INC, $self->{prefix};
212		}
213
214		foreach my $rv ( $self->find_extensions($path) ) {
215		my ($file, $pkg) = @{$rv};
216		next if $self->{pathnames}{$pkg};
217
218		local $@;
219		my $new = eval { require $file; $pkg->can('new') };
220		unless ( $new ) {
221		warn $@ if $@;
222		next;
223		}
224		$self->{pathnames}{$pkg} = delete $INC{$file};
225		push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
226		}
227
228		$self->{extensions} \|\|= [];
	238	my ($self, $path, $top) = @_;
	239
	240	unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
	241	unshift @INC, $self->{prefix};
	242	}
	243
	244	foreach my $rv ( $self->find_extensions($path) ) {
	245	my ($file, $pkg) = @{$rv};
	246	next if $self->{pathnames}{$pkg};
	247
	248	local $@;
	249	my $new = eval { require $file; $pkg->can('new') };
	250	unless ( $new ) {
	251	warn $@ if $@;
	252	next;
	253	}
	254	$self->{pathnames}{$pkg} = delete $INC{$file};
	255	push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
	256	}
	257
	258	$self->{extensions} \|\|= [];
229	259	}
230	260
231	261	sub find_extensions {
232		my ($self, $path) = @_;
233
234		my @found;
235		File::Find::find( sub {
236		my $file = $File::Find::name;
237		return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
238		my $subpath = $1;
239		return if lc($subpath) eq lc($self->{dispatch});
240
241		$file = "$self->{path}/$subpath.pm";
242		my $pkg = "$self->{name}::$subpath";
243		$pkg =~ s!/!::!g;
244
245		# If we have a mixed-case package name, assume case has been preserved
246		# correctly. Otherwise, root through the file to locate the case-preserved
247		# version of the package name.
248		if ( $subpath eq lc($subpath) \|\| $subpath eq uc($subpath) ) {
249		open PKGFILE, "<$subpath.pm" or die "find_extensions: Can't open $subpath.pm: $!";
250		my $in_pod = 0;
251		while ( <PKGFILE> ) {
252		$in_pod = 1 if /^=\w/;
253		$in_pod = 0 if /^=cut/;
254		next if ($in_pod \|\| /^=cut/); # skip pod text
255		next if /^\s*#/; # and comments
256		if ( m/^\spackage\s+($pkg)\s;/i ) {
257		$pkg = $1;
258		last;
259		}
260		}
261		close PKGFILE;
262		}
263
264		push @found, [ $file, $pkg ];
265		}, $path ) if -d $path;
266
267		@found;
	262	my ($self, $path) = @_;
	263
	264	my @found;
	265	File::Find::find( sub {
	266	my $file = $File::Find::name;
	267	return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
	268	my $subpath = $1;
	269	return if lc($subpath) eq lc($self->{dispatch});
	270
	271	$file = "$self->{path}/$subpath.pm";
	272	my $pkg = "$self->{name}::$subpath";
	273	$pkg =~ s!/!::!g;
	274
	275	# If we have a mixed-case package name, assume case has been preserved
	276	# correctly. Otherwise, root through the file to locate the case-preserved
	277	# version of the package name.
	278	if ( $subpath eq lc($subpath) \|\| $subpath eq uc($subpath) ) {
	279	open PKGFILE, "<$subpath.pm" or die "find_extensions: Can't open $subpath.pm: $!";
	280	my $in_pod = 0;
	281	while ( <PKGFILE> ) {
	282	$in_pod = 1 if /^=\w/;
	283	$in_pod = 0 if /^=cut/;
	284	next if ($in_pod \|\| /^=cut/); # skip pod text
	285	next if /^\s*#/; # and comments
	286	if ( m/^\spackage\s+($pkg)\s;/i ) {
	287	$pkg = $1;
	288	last;
	289	}
	290	}
	291	close PKGFILE;
	292	}
	293
	294	push @found, [ $file, $pkg ];
	295	}, $path ) if -d $path;
	296
	297	@found;
268	298	}
269	299
270	300	sub _caller {
271		my $depth = 0;
272		my $call = caller($depth);
273		while ( $call eq __PACKAGE__ ) {
274		$depth++;
275		$call = caller($depth);
276		}
277		return $call;
	301	my $depth = 0;
	302	my $call = caller($depth);
	303	while ( $call eq __PACKAGE__ ) {
	304	$depth++;
	305	$call = caller($depth);
	306	}
	307	return $call;
278	308	}
279	309
280	310	1;
	311
	312	# Copyright 2008 Adam Kennedy.

-2

lib/IPC/PubSub/Cache/Memcached.pm less more

9	9	my $namespace = shift \|\| $class;
10	10	my $config = shift \|\| $class->default_config($namespace);
11	11	my $mem = Cache::Memcached->new($config);
	12	# Force our connection to never timeout on selects
	13	$mem->{select_timeout} = undef;
12	14	bless(\$mem, $class);
13	15	}
14	16

62	64	sub lock {
63	65	my ($self, $key) = @_;
64	66	for my $i (1..100) {
65		return if $$self->add("lock:$key" => 1);
	67	return 1 if $$self->add("lock:$key" => $$);
66	68	Time::HiRes::usleep(rand(250000)+250000);
67	69	}
	70	return 0;
68	71	}
69	72
70	73	sub unlock {
71	74	my ($self, $chan) = @_;
72		$$self->delete("lock:$chan");
	75	return 1 if $$self->delete("lock:$chan");
	76	return 0;
73	77	}
74	78
75	79	sub add_publisher {

-6

lib/IPC/PubSub/Publisher.pm less more

2	2	use warnings;
3	3	use base qw/Class::Accessor::Fast/;
4	4
5		__PACKAGE__->mk_accessors(qw/expiry _indice _uuid _cache/);
	5	__PACKAGE__->mk_accessors(qw/expiry/);
	6	__PACKAGE__->mk_ro_accessors(qw/_indice uuid _cache/);
6	7
7	8	sub new {
8	9	my $class = shift;

15	16	expiry => 0,
16	17	_cache => $cache,
17	18	_indice => { map { $_ => 1 } @_ },
18		_uuid => $uuid,
	19	uuid => $uuid,
19	20	});
20	21	$cache->add_publisher($_, $uuid) for @_;
21	22	return $self;

31	32	sub publish {
32	33	my $self = shift;
33	34	$self->_indice->{$_} \|\|= do {
34		$self->_cache->add_publisher($_);
	35	$self->_cache->add_publisher($_, $self->uuid);
35	36	1;
36	37	} for @_;
37	38	}
38	39
39	40	sub unpublish {
40	41	my $self = shift;
41		delete($self->_indice->{$_}) and $self->_cache->remove_publisher($_) for @_;
	42	delete($self->_indice->{$_}) and $self->_cache->remove_publisher($_, $self->uuid) for @_;
42	43	}
43	44
44	45	sub msg {
45	46	my $self = shift;
46		my $uuid = $self->_uuid;
	47	my $uuid = $self->uuid;
47	48	my $indice = $self->_indice;
48	49	my $expiry = $self->expiry;
49	50	foreach my $msg (@_) {

57	58	no warnings 'redefine';
58	59	sub DESTROY {
59	60	my $self = shift;
60		$self->_cache->remove_publisher($_, $self->_cache) for $self->channels;
	61	return unless $self->_cache;
	62	$self->_cache->remove_publisher($_, $self->uuid) for $self->channels;
61	63	}
62	64
63	65	1;

-4

lib/IPC/PubSub.pm less more

0	0	package IPC::PubSub;
1		$IPC::PubSub::VERSION = '0.28';
	1	$IPC::PubSub::VERSION = '0.29';
2	2
3	3	use 5.006;
4	4	use strict;

126	126	When a I<message> is published on a channel, all subscribers currently in
127	127	that channel will get it on their next C<get> or C<get_all> call.
128	128
129		Currently, it offers three backends: C<DBM_Deep> for on-disk storage,
130		C<Memcached> for possibly multi-host storage, and C<PlainHash> for
131		single-process storage.
	129	Currently, it offers four backends: C<DBM_Deep> for on-disk storage,
	130	C<Memcached> for possibly multi-host storage, C<Jifty::DBI> for
	131	database-backed storage, and C<PlainHash> for single-process storage.
132	132
133	133	Please see the tests in F<t/> for this distribution, as well as L</SYNOPSIS>
134	134	above, for some usage examples; detailed documentation is not yet available.

+87

-0

t/publisher.t less more

	0	use strict;
	1	use warnings;
	2	use Test::More;
	3	use IPC::PubSub;
	4	use IO::Socket::INET;
	5	use File::Temp ':POSIX';
	6
	7	my @backends = qw(PlainHash);
	8
	9	unshift @backends, 'DBM_Deep' if eval { require DBM::Deep };
	10	unshift @backends, 'JiftyDBI' if eval { require Jifty::DBI };
	11	unshift @backends, 'Memcached' if eval { require Cache::Memcached } and IO::Socket::INET->new('127.0.0.1:11211');
	12
	13	plan tests => 33 * scalar @backends;
	14
	15	my $tmp = tmpnam();
	16	END { unlink $tmp }
	17
	18	my %init_args = (
	19	DBM_Deep => [ $tmp ],
	20	JiftyDBI => [ db_init => 1 ],
	21	Memcached => [ rand() . $$ ],
	22	);
	23
	24	SKIP: for my $backend (@backends) {
	25	diag("Testing backend $backend");
	26
	27	my $bus = IPC::PubSub->new( $backend, @{ $init_args{$backend} } );
	28	my $pub = $bus->new_publisher( "first", "second" );
	29	my $cache = $bus->_cache;
	30
	31	is_deeply( scalar $pub->channels, { first => 1, second => 1 } );
	32	is_deeply( [ sort $pub->channels ], [ "first", "second" ] );
	33	is_deeply( $cache->publisher_indices("first"), { $pub->uuid => 0 } );
	34	is_deeply( $cache->publisher_indices("second"), { $pub->uuid => 0 } );
	35	is_deeply( $cache->publisher_indices("third"), {} );
	36
	37	$pub->publish("third");
	38	is_deeply( scalar $pub->channels,
	39	{ first => 1, second => 1, third => 1 } );
	40	is_deeply( [ sort $pub->channels ], [ "first", "second", "third" ] );
	41	is_deeply( $cache->publisher_indices("first"), { $pub->uuid => 0 } );
	42	is_deeply( $cache->publisher_indices("second"), { $pub->uuid => 0 } );
	43	is_deeply( $cache->publisher_indices("third"), { $pub->uuid => 0 } );
	44
	45	$pub->publish("third");
	46	is_deeply( scalar $pub->channels,
	47	{ first => 1, second => 1, third => 1 } );
	48	is_deeply( [ sort $pub->channels ], [ "first", "second", "third" ] );
	49	is_deeply( $cache->publisher_indices("third"), { $pub->uuid => 0 } );
	50
	51	$pub->msg("message 1");
	52	is_deeply( scalar $pub->channels,
	53	{ first => 2, second => 2, third => 2 } );
	54
	55	$pub->unpublish("second");
	56	is_deeply( scalar $pub->channels, { first => 2, third => 2 } );
	57
	58	$pub->msg("message 2");
	59	is_deeply( scalar $pub->channels, { first => 3, third => 3 } );
	60
	61	is_deeply( $cache->publisher_indices("first"), { $pub->uuid => 2 } );
	62	is_deeply( $cache->publisher_indices("second"), {} );
	63	is_deeply( $cache->publisher_indices("third"), { $pub->uuid => 2 } );
	64
	65	is($cache->get_index( first => $pub->uuid ), 2 );
	66	$cache->set_index( first => $pub->uuid, 5 );
	67	is($cache->get_index( first => $pub->uuid ), 5 );
	68	is_deeply( $cache->publisher_indices("first"), { $pub->uuid => 5 } );
	69
	70	{
	71	my $pub2 = $bus->new_publisher( "first", "second", "third" );
	72	is_deeply( scalar $pub2->channels, { first => 1, second => 1, third => 1 } );
	73	is_deeply( $cache->publisher_indices("first"), { $pub->uuid => 5, $pub2->uuid => 0 } );
	74	is_deeply( $cache->publisher_indices("second"), { $pub2->uuid => 0 } );
	75	is_deeply( $cache->publisher_indices("third"), { $pub->uuid => 2, $pub2->uuid => 0 } );
	76
	77	$pub2->unpublish("first");
	78	is_deeply( scalar $pub2->channels, { second => 1, third => 1 } );
	79	is_deeply( $cache->publisher_indices("first"), { $pub->uuid => 5 } );
	80	is_deeply( $cache->publisher_indices("second"), { $pub2->uuid => 0 } );
	81	is_deeply( $cache->publisher_indices("third"), { $pub->uuid => 2, $pub2->uuid => 0 } );
	82	}
	83	is_deeply( $cache->publisher_indices("first"), { $pub->uuid => 5 } );
	84	is_deeply( $cache->publisher_indices("second"), {} );
	85	is_deeply( $cache->publisher_indices("third"), { $pub->uuid => 2 } );
	86	}