IPC-PubSub-0.29/0000755000175000017500000000000011120652370012262 5ustar chmrrchmrrIPC-PubSub-0.29/MANIFEST0000644000175000017500000000137111120651624013416 0ustar chmrrchmrrChanges inc/Module/Install.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/IPC/PubSub.pm lib/IPC/PubSub/Cache.pm lib/IPC/PubSub/Cache/DBM_Deep.pm lib/IPC/PubSub/Cache/JiftyDBI.pm lib/IPC/PubSub/Cache/JiftyDBI/Stash.pm lib/IPC/PubSub/Cache/JiftyDBI/Stash/Item.pm lib/IPC/PubSub/Cache/JiftyDBI/Stash/Publisher.pm lib/IPC/PubSub/Cache/Memcached.pm lib/IPC/PubSub/Cache/PlainHash.pm lib/IPC/PubSub/Cacheable.pm lib/IPC/PubSub/Publisher.pm lib/IPC/PubSub/Subscriber.pm Makefile.PL MANIFEST This list of files META.yml README SIGNATURE Public-key signature (added by MakeMaker) t/basic.t t/publisher.t IPC-PubSub-0.29/META.yml0000644000175000017500000000071611120652301013531 0ustar chmrrchmrr--- abstract: Interprocess Publish/Subscribe channels author: - Audrey Tang distribution_type: module generated_by: Module::Install version 0.70 license: MIT meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.3.html version: 1.3 name: IPC-PubSub no_index: directory: - inc - t requires: Class::Accessor::Fast: 0 DBM::Deep: 1.00 Data::UUID: 0 Storable: 0 Time::HiRes: 0 perl: 5.6.0 version: 0.29 IPC-PubSub-0.29/SIGNATURE0000644000175000017500000000514311120652322013546 0ustar chmrrchmrrThis file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.55. To verify the content in this distribution, first make sure you have Module::Signature installed, then type: % cpansign -v It will check each file's integrity, as well as the signature's validity. If "==> Signature verified OK! <==" is not displayed, the distribution may already have been compromised, and you should not run its Makefile.PL or Build.PL. -----BEGIN PGP SIGNED MESSAGE----- Hash: SHA1 SHA1 95bccc98dbd22f908804955ed1b93d1fd1307126 Changes SHA1 10db9ec4115d344c939604adb5622910dfa3103d MANIFEST SHA1 4bf7d07ec4a6c394c23e7d8bc33f266c5b2b0ba3 META.yml SHA1 1efb0dda270171a9accec4db6643c6d9b81d6e78 Makefile.PL SHA1 7edc5bba981fd5d734a9a095b3bddfed8d1acda0 README SHA1 8b836389e4bc170eb8d19b7296b2f4978ac36136 inc/Module/Install.pm SHA1 85b32a1d5f215d99f411c3dd6113b537fcd5c57d inc/Module/Install/Base.pm SHA1 fde745e180861c7c0ba3ee5a767cafdbdb1d3ebd inc/Module/Install/Can.pm SHA1 e259400ceb54c34def9c994f52d7091108ce7ffc inc/Module/Install/Fetch.pm SHA1 da42b522e5a7ffbae0ceec900f3635ad9990c565 inc/Module/Install/Makefile.pm SHA1 ba005818ee9f97146bfa4e14e53c684e9e446902 inc/Module/Install/Metadata.pm SHA1 85e6b1cf5b7ca81bfb469a99389fa947d4b8a08e inc/Module/Install/Win32.pm SHA1 d32dff9f0d2f02023ca6d79a48d62fd855916351 inc/Module/Install/WriteAll.pm SHA1 51ee056caa49c8e736d5190566ccc00b6cb58fd0 lib/IPC/PubSub.pm SHA1 0ed23d984f0dc09d76ed50c16a2b0aeaa71c8648 lib/IPC/PubSub/Cache.pm SHA1 80b988a5d95ecb1689d58052cb139cf54ff482a4 lib/IPC/PubSub/Cache/DBM_Deep.pm SHA1 4a865e5f6443b2fc2cd44e4b1e9aa9aba110b9c0 lib/IPC/PubSub/Cache/JiftyDBI.pm SHA1 a6f3aee0362d3e8e9f7d063f5e40bbd8c6f0815e lib/IPC/PubSub/Cache/JiftyDBI/Stash.pm SHA1 3b270ac2da87b439cde2a2755d1bea3b2a578a05 lib/IPC/PubSub/Cache/JiftyDBI/Stash/Item.pm SHA1 84dd4abad24f85cc5a879dd2888134cc87351c7d lib/IPC/PubSub/Cache/JiftyDBI/Stash/Publisher.pm SHA1 78f87c95d2c66ffd9ed283cf84fff08298d3e6de lib/IPC/PubSub/Cache/Memcached.pm SHA1 adaaa2bba258b95536c24d38ba3adc6ec5d8c9e4 lib/IPC/PubSub/Cache/PlainHash.pm SHA1 5f34b5791db8193cc06fc25df2bfe33aa6cc0951 lib/IPC/PubSub/Cacheable.pm SHA1 10cda8411ba967f8230c38056e6ccd984f06bc06 lib/IPC/PubSub/Publisher.pm SHA1 33e500a83f8a7be3f1d5c9486a80a41566deac3b lib/IPC/PubSub/Subscriber.pm SHA1 afc073bdc3a645a7a01646c0a08f575cc365f644 t/basic.t SHA1 140f4206abc483d51a64316123a73f0ccadb7e1b t/publisher.t -----BEGIN PGP SIGNATURE----- Version: GnuPG v2.0.9 (GNU/Linux) iEYEARECAAYFAklDVNIACgkQMflWJZZAbqAp+ACfS126BFH5oQX+brur3ylTs0Ei 2C0AoLJX4i7F9IDUWSjn3zpXyxbiy154 =m/eG -----END PGP SIGNATURE----- IPC-PubSub-0.29/Changes0000644000175000017500000000606711120651726013572 0ustar chmrrchmrr[Changes for 0.29 - 2008-12-13] * Publisher and index fixes * We don't need to force select_timeout anymore, and it causes explosions if called during global destruction, when $$self->[0] (_part_ of the pseudohash) may have gone missing already, but the object itself is still there. So $$self->{anything} explodes with "not a hash reference" _sometimes_, despite $$self always being an arrayref. ..friends don't let friends use pseudohashes. [Changes for 0.28 - 2008-08-15] * We now require DBM::Deep 1.00 or later. * Improved data consistency in DBM::Deep backend so it won't sometimes die with a "not an ARRAY reference" message. Reported by: Matthew Pitts [Changes for 0.27 - 2007-10-09] * Adjust tests so it no longer fails with newer versions of DBM::Deep. [Changes for 0.26 - 2007-05-31] * Repair a broken attempt at PAUSE uploading. [Changes for 0.25 - 2007-05-31] * The DBM::Deep tests of t/basic.t now explicitly passes the temporary database file to the backend; now it won't hangs on OSX anymore. Contributed by: Arne Skjærholt [Changes for 0.24 - 2007-02-26] * Typo fix in Memcached driver. [Changes for 0.23 - 2007-02-19] * New ->disconnect API to explicitly disconnect from the backend store. Contributed by: Alex Vandiver [Changes for 0.22 - 2006-12-11] * INCOMPATIBLE CHANGE to Jifty::DBI backend: "key" column changed to "data_key" because "key" is a reserved word in some SQL databases. Contributed by: Jesse Vincent [Changes for 0.21 - 2006-10-26] * Speed up ->modify calls for the Memcached backend. * Normalized internal keys for channels, messages and data so they can't clash. [Changes for 0.20 - 2006-10-25] * Memcached: Remove the debug messages accidentally left in ->lock and ->unlock. * New ->modify API for IPC::PubSub and Cache to atomically manipulate cache. * Time::HiRes is now required to reduce locking contention. [Changes for 0.11 - 2006-10-25] * The Memcached backend now takes a namespace parameter to avoid collision. * The ->lock, ->unlock, ->fetch, ->store APIs in IPC::PubSub now works again. [Changes for 0.10 - 2006-10-25] * Renamed from MessageBus.pm to IPC::PubSub. * IPC::PubSub's factory methods are now ->new_subscriber and ->new_publisher. * New ->channels API for Publisher and Subscriber objects. * New ->publish, ->unpublish and ->expiry APIs for Publisher objects. * New ->subscribe, ->unsubscribe APIs for Subscriber objects. [Changes for 0.04 - 2006-10-24] * Expose ->lock, ->unlock, ->fetch, ->store APIs into the IPC::PubSub object. * Implement ->lock and ->unlock methods for non-Memcached backends. * The tests are no longer entirely skipped when memcached is not running. [Changes for 0.03 - 2006-10-24] * New backend: JiftyDBI. * Multiple publishers now work in DBM_Deep and Memcached backends. * Memcached now atomically handles publisher announcement and removal. [Changes for 0.02 - 2006-10-24] * Thanks to mstrout++ this thing actually works now. :-) * Switched from Class::InsideOut to Class::Accessor::Fast. [Changes for 0.01 - 2006-10-24] * Initial release to CPAN of this three-hours-old hack. IPC-PubSub-0.29/lib/0000755000175000017500000000000011120652370013030 5ustar chmrrchmrrIPC-PubSub-0.29/lib/IPC/0000755000175000017500000000000011120652370013443 5ustar chmrrchmrrIPC-PubSub-0.29/lib/IPC/PubSub/0000755000175000017500000000000011120652370014643 5ustar chmrrchmrrIPC-PubSub-0.29/lib/IPC/PubSub/Cache/0000755000175000017500000000000011120652370015646 5ustar chmrrchmrrIPC-PubSub-0.29/lib/IPC/PubSub/Cache/PlainHash.pm0000644000175000017500000000134210566167712020071 0ustar chmrrchmrrpackage IPC::PubSub::Cache::PlainHash; use strict; use warnings; use base 'IPC::PubSub::Cache'; my %cache; use constant new => __PACKAGE__; sub fetch { my $self = shift; @cache{@_}; } sub store { my ($self, $key, $val, $time, $expiry) = @_; $cache{$key} = [$time => $val]; } sub publisher_indices { my ( $self, $chan ) = @_; +{ %{ $cache{$chan} || {} } }; } sub add_publisher { my ($self, $chan, $pub) = @_; $cache{$chan}{$pub} = 0; } sub remove_publisher { my ($self, $chan, $pub) = @_; delete $cache{$chan}{$pub}; } sub get_index { my ($self, $chan, $pub) = @_; $cache{$chan}{$pub}; } sub set_index { my ($self, $chan, $pub, $idx) = @_; $cache{$chan}{$pub} = $idx; } 1; IPC-PubSub-0.29/lib/IPC/PubSub/Cache/Memcached.pm0000644000175000017500000000442211110636117020054 0ustar chmrrchmrrpackage IPC::PubSub::Cache::Memcached; use strict; use warnings; use base 'IPC::PubSub::Cache'; use Cache::Memcached; use Time::HiRes (); sub new { my $class = shift; my $namespace = shift || $class; my $config = shift || $class->default_config($namespace); my $mem = Cache::Memcached->new($config); # Force our connection to never timeout on selects $mem->{select_timeout} = undef; bless(\$mem, $class); } sub disconnect { my $self = shift; $$self->disconnect_all; } sub default_config { my ($class, $namespace) = @_; return { servers => ['127.0.0.1:11211'], debug => 0, namespace => $namespace, }; } sub fetch_data { my $self = shift; my $key = shift; return $$self->get("data:$key"); } sub store_data { my $self = shift; my $key = shift; my $val = shift; if (defined $val) { $$self->set("data:$key" => $val); } else { $$self->delete("data:$key"); } } sub fetch { my $self = shift; values(%{$$self->get_multi(@_)}); } sub store { my ($self, $key, $val, $time, $expiry) = @_; $$self->set($key, [$time, $val], $expiry); } sub publisher_indices { my ($self, $chan) = @_; $$self->get("pubs:$chan") || {}; } sub lock { my ($self, $key) = @_; for my $i (1..100) { return 1 if $$self->add("lock:$key" => $$); Time::HiRes::usleep(rand(250000)+250000); } return 0; } sub unlock { my ($self, $chan) = @_; return 1 if $$self->delete("lock:$chan"); return 0; } sub add_publisher { my ($self, $chan, $pub) = @_; my $key = "pubs:$chan"; $self->lock($key); my $pubs = $$self->get($key) || {}; $pubs->{$pub} = 0; $$self->set($key => $pubs); $self->unlock($key); } sub remove_publisher { my ($self, $chan, $pub) = @_; my $key = "pubs:$chan"; $self->lock($key); my $pubs = $$self->get($key) || {}; delete $pubs->{$pub}; $$self->set($key => $pubs); $self->unlock($key); } sub get_index { my ($self, $chan, $pub) = @_; ($$self->get("pubs:$chan") || {})->{$pub}; } sub set_index { my ($self, $chan, $pub, $idx) = @_; my $pubs = $$self->get("pubs:$chan") || {}; $pubs->{$pub} = $idx; $$self->set("pubs:$chan", $pubs); } 1; IPC-PubSub-0.29/lib/IPC/PubSub/Cache/DBM_Deep.pm0000644000175000017500000000271011054644261017551 0ustar chmrrchmrrpackage IPC::PubSub::Cache::DBM_Deep; use strict; use warnings; use base 'IPC::PubSub::Cache'; use Storable qw/ nfreeze thaw /; use DBM::Deep; use File::Temp qw/ tempfile /; sub new { my $class = shift; my $file = shift; my $mem = DBM::Deep->new( file => ((defined $file and length $file) ? $file : $class->default_config), locking => 1, autoflush => 1, ); bless(\$mem, $class); } sub default_config { my (undef, $filename) = tempfile(UNLINK => 1); return $filename; } sub fetch { my $self = shift; return map { thaw($$self->get($_)) } @_; } sub store { my ($self, $key, $val, $time, $expiry) = @_; $$self->put($key => nfreeze([$time, $val])); } sub publisher_indices { my ($self, $chan) = @_; return { %{ $$self->get("pubs:$chan") || {} } }; } sub add_publisher { my ($self, $chan, $pub) = @_; my $pubs = { %{ $$self->get("pubs:$chan") || {} } }; $pubs->{$pub} = 0; $$self->put("pubs:$chan", $pubs); } sub remove_publisher { my ($self, $chan, $pub) = @_; my $pubs = { %{ $$self->get("pubs:$chan") || {} } }; delete $pubs->{$pub}; $$self->put("pubs:$chan", $pubs); } sub get_index { my ($self, $chan, $pub) = @_; ($$self->get("pubs:$chan") || {})->{$pub}; } sub set_index { my ($self, $chan, $pub, $idx) = @_; my $pubs = { %{ $$self->get("pubs:$chan") || {} } }; $pubs->{$pub} = $idx; $$self->put("pubs:$chan", $pubs); } 1; IPC-PubSub-0.29/lib/IPC/PubSub/Cache/JiftyDBI/0000755000175000017500000000000011120652370017252 5ustar chmrrchmrrIPC-PubSub-0.29/lib/IPC/PubSub/Cache/JiftyDBI/Stash.pm0000644000175000017500000000360511104677027020706 0ustar chmrrchmrrpackage IPC::PubSub::Cache::JiftyDBI::Stash; use strict; use warnings; use Jifty::DBI::Handle; use Jifty::DBI::SchemaGenerator; use IPC::PubSub::Cache::JiftyDBI::Stash::Item; use IPC::PubSub::Cache::JiftyDBI::Stash::Publisher; use File::Temp qw/ tempfile tempdir /; sub new { my $class = shift; my $self = {}; bless $self, $class; my %args = ( db_init => 0, db_config => undef, db_handle => undef, table_prefix => 'pubsub_', @_ ); if ($args{'table_prefix'}) { IPC::PubSub::Cache::JiftyDBI::Stash::Item->table_prefix($args{'table_prefix'}); IPC::PubSub::Cache::JiftyDBI::Stash::Publisher->table_prefix($args{'table_prefix'}); } if ($args{'db_handle'}) { $self->handle($args{'db_handle'}); } else { unless ( $args{'db_config'} ) { my $filename; ( undef, $filename ) = tempfile(); $args{'db_config'} = { driver => 'SQLite', database => $filename }; } $self->_connect( %{$args{'db_config'}} ); } if ( $args{'db_init'} ) { $self->_generate_db(); } return $self; } sub handle { my $self = shift; $self->{'handle'} = shift if (@_); return $self->{'handle'}; } sub _generate_db { my $self = shift; my $gen = Jifty::DBI::SchemaGenerator->new( $self->handle ); $gen->add_model( IPC::PubSub::Cache::JiftyDBI::Stash::Item->new( handle => $self->handle ) ); $gen->add_model( IPC::PubSub::Cache::JiftyDBI::Stash::Publisher->new( handle => $self->handle ) ); my @statements = $gen->create_table_sql_statements; $self->handle->begin_transaction; for my $statement (@statements) { my $ret = $self->handle->simple_query($statement); } $self->handle->commit; } sub _connect { my $self = shift; my $handle = Jifty::DBI::Handle->new(); $handle->connect(@_); $self->handle($handle); } 1; IPC-PubSub-0.29/lib/IPC/PubSub/Cache/JiftyDBI/Stash/0000755000175000017500000000000011120652370020334 5ustar chmrrchmrrIPC-PubSub-0.29/lib/IPC/PubSub/Cache/JiftyDBI/Stash/Publisher.pm0000644000175000017500000000126210566167712022646 0ustar chmrrchmrrpackage IPC::PubSub::Cache::JiftyDBI::Stash::Publisher; use strict; use warnings; use vars qw/$TABLE_PREFIX/; use Jifty::DBI::Schema; use Jifty::DBI::Record schema { column channel => type is 'text'; column name => type is 'text'; column idx => type is 'int'; }; sub table_prefix { my $self = shift; $TABLE_PREFIX = shift if (@_); return ($TABLE_PREFIX); } sub table { my $self = shift; return $self->table_prefix . $self->SUPER::table(); } package IPC::PubSub::Cache::JiftyDBI::Stash::PublisherCollection; use base qw/Jifty::DBI::Collection/; sub table { my $self = shift; my $tab = $self->new_item->table(); return $tab; } 1; IPC-PubSub-0.29/lib/IPC/PubSub/Cache/JiftyDBI/Stash/Item.pm0000644000175000017500000000132510566167712021607 0ustar chmrrchmrrpackage IPC::PubSub::Cache::JiftyDBI::Stash::Item; use strict; use warnings; use vars qw/$TABLE_PREFIX/; use Jifty::DBI::Schema; use Jifty::DBI::Record schema { column data_key => type is 'text'; column val => type is 'blob', filters are 'Jifty::DBI::Filter::Storable'; column expiry => type is 'int'; }; sub table_prefix { my $self = shift; $TABLE_PREFIX = shift if (@_); return ($TABLE_PREFIX); } sub table { my $self = shift; return $self->table_prefix . $self->SUPER::table(); } package IPC::PubSub::Cache::JiftyDBI::Stash::ItemCollection; use base qw/Jifty::DBI::Collection/; sub table { my $self = shift; my $tab = $self->new_item->table(); return $tab; } 1; IPC-PubSub-0.29/lib/IPC/PubSub/Cache/JiftyDBI.pm0000644000175000017500000000476011104676334017627 0ustar chmrrchmrrpackage IPC::PubSub::Cache::JiftyDBI; use strict; use warnings; use base 'IPC::PubSub::Cache'; use IPC::PubSub::Cache::JiftyDBI::Stash; use vars qw/$STASH/; sub new { my $class = shift; my $self = {}; bless $self => $class; $STASH ||= IPC::PubSub::Cache::JiftyDBI::Stash->new(@_); return $self; } sub disconnect { $STASH->handle->disconnect; } sub fetch { my $self = shift; my @keys_in_order = (@_); my $items = IPC::PubSub::Cache::JiftyDBI::Stash::ItemCollection->new( handle => $STASH->handle ); foreach my $val (@keys_in_order) { $items->limit( column => 'data_key', entry_aggregator => 'or', value => $val ); } my %items = map { $_->data_key, [$_->expiry, $_->val] } @{ $items->items_array_ref }; return @items{@keys_in_order}; } sub store { my ($self, $key, $val, $time, $expiry) = @_; $expiry ||= 0; my $item = IPC::PubSub::Cache::JiftyDBI::Stash::Item->new(handle => $STASH->handle); $item->load_by_cols( data_key => $key ); if ( $item->id ) { $item->set_val($val); $item->set_expiry($time+$expiry); } else { $item->create( data_key => $key, expiry => ($time+$expiry), val => $val ); } } sub publisher_indices { my ($self, $chan) = @_; my $publishers = IPC::PubSub::Cache::JiftyDBI::Stash::PublisherCollection->new(handle => $STASH->handle); $publishers->limit(column => 'channel', value => $chan); my %indices; map {$indices{$_->name} = $_->idx} @{$publishers->items_array_ref}; return \%indices; } sub add_publisher { my ($self, $chan, $pub) = @_; my $publisher = IPC::PubSub::Cache::JiftyDBI::Stash::Publisher->new(handle => $STASH->handle); $publisher->create( channel => $chan, name => $pub, idx => 0); } sub remove_publisher { my ($self, $chan, $pub) = @_; my $publisher = _get_publisher($chan => $pub); $publisher->delete(); } sub get_index { my ($self, $chan, $pub) = @_; my $publisher = _get_publisher($chan => $pub); if ($publisher->id) { return $publisher->idx } } sub set_index { my ($self, $chan, $pub, $idx) = @_; return _get_publisher($chan => $pub)->set_idx($idx); } sub _get_publisher { my $chan = shift; my $pub = shift; my $publisher = IPC::PubSub::Cache::JiftyDBI::Stash::Publisher->new(handle => $STASH->handle); $publisher->load_by_cols( channel => $chan, name => $pub); return $publisher; } 1; IPC-PubSub-0.29/lib/IPC/PubSub/Cacheable.pm0000644000175000017500000000151210566167712017045 0ustar chmrrchmrrpackage IPC::PubSub::Cacheable; use strict; use warnings; use Scalar::Util qw( refaddr ); my %Cache; sub new { my $class = shift; my $self = bless(\@_, $class); $self->BUILD; return $self; } sub BUILD { my $self = shift; $Cache{ refaddr($self) } ||= do { require "IPC/PubSub/Cache/$self->[0].pm"; "IPC::PubSub::Cache::$self->[0]"->new(@{$self->[1]}); }; } sub AUTOLOAD { no strict 'refs'; no warnings 'uninitialized'; my $meth = (substr(our $AUTOLOAD, rindex($AUTOLOAD, '::') + 2) || $AUTOLOAD); my $code = sub { my $self = shift; my $cache = $self->BUILD; unshift @_, $cache; goto &{$cache->can($meth)}; }; *$meth = $code; goto &$code; } sub DESTROY { my $self = shift; delete $Cache{ refaddr($self) }; } 1; IPC-PubSub-0.29/lib/IPC/PubSub/Publisher.pm0000644000175000017500000000267311120124130017132 0ustar chmrrchmrrpackage IPC::PubSub::Publisher; use strict; use warnings; use base qw/Class::Accessor::Fast/; __PACKAGE__->mk_accessors(qw/expiry/); __PACKAGE__->mk_ro_accessors(qw/_indice uuid _cache/); sub new { my $class = shift; my $cache = shift; require Data::UUID; my $uuid = Data::UUID->new->create_b64; my $self = bless({ expiry => 0, _cache => $cache, _indice => { map { $_ => 1 } @_ }, uuid => $uuid, }); $cache->add_publisher($_, $uuid) for @_; return $self; } sub channels { my $self = shift; wantarray ? keys(%{$self->_indice}) : $self->_indice; } sub publish { my $self = shift; $self->_indice->{$_} ||= do { $self->_cache->add_publisher($_, $self->uuid); 1; } for @_; } sub unpublish { my $self = shift; delete($self->_indice->{$_}) and $self->_cache->remove_publisher($_, $self->uuid) for @_; } sub msg { my $self = shift; my $uuid = $self->uuid; my $indice = $self->_indice; my $expiry = $self->expiry; foreach my $msg (@_) { while (my ($channel, $index) = each %$indice) { $self->_cache->put($channel, $uuid, $index, $msg, $expiry); $indice->{$channel} = $index+1; } } } no warnings 'redefine'; sub DESTROY { my $self = shift; return unless $self->_cache; $self->_cache->remove_publisher($_, $self->uuid) for $self->channels; } 1; IPC-PubSub-0.29/lib/IPC/PubSub/Subscriber.pm0000644000175000017500000000252610566167712017327 0ustar chmrrchmrrpackage IPC::PubSub::Subscriber; use strict; use warnings; use base qw/Class::Accessor::Fast/; __PACKAGE__->mk_accessors(qw/_pubs _cache/); sub new { my $class = shift; my $cache = shift; my $pubs = { map { $_ => $cache->publisher_indices($_); } @_ }; bless({ _cache => $cache, _pubs => $pubs }); } sub channels { my $self = shift; wantarray ? keys(%{$self->_pubs}) : $self->_pubs; } sub subscribe { my $self = shift; $self->_pubs->{$_} ||= $self->_cache->publisher_indices($_) for @_; } sub unsubscribe { my $self = shift; delete @{$self->_pubs}{@_}; } sub get_all { my $self = shift; my $pubs = $self->_pubs; my $cache = $self->_cache; return { map { my $orig = $pubs->{$_}; $pubs->{$_} = $cache->publisher_indices($_); $_ => [ grep { defined } $cache->get($_, $orig, $pubs->{$_})]; } $self->channels }; } sub get { my $self = shift; my $pubs = $self->_pubs; my $cache = $self->_cache; my ($chan) = @_ ? @_ : sort($self->channels) or return; my $orig = $pubs->{$chan}; $pubs->{$chan} = $cache->publisher_indices($chan); wantarray ? map {$_ ? $_->[1] : ()} $cache->get($chan, $orig, $pubs->{$chan}) : [map {$_ ? $_->[1] : ()} $cache->get($chan, $orig, $pubs->{$chan})]; } 1; IPC-PubSub-0.29/lib/IPC/PubSub/Cache.pm0000644000175000017500000000453711053366403016221 0ustar chmrrchmrrpackage IPC::PubSub::Cache; use strict; use warnings; use File::Spec; use Time::HiRes (); #method fetch (Str *@keys --> List of Pair) { ... } #method store (Str $key, Str $val, Num $time, Num $expiry) { ... } #method add_publisher (Str $chan, Str $pub) { ... } #method remove_publisher (Str $chan, Str $pub) { ... } #method get_index (Str $chan, Str $pub --> Int) { ... } #method set_index (Str $chan, Str $pub, Int $index) { ... } #method publisher_indices (Str $chan --> Hash of Int) { ... } sub fetch_data { my $self = shift; my $key = shift; return (($self->fetch("data:$key"))[0] || [])->[-1]; } sub store_data { my $self = shift; my $key = shift; my $val = shift; $self->store("data:$key" => $val, -1, 0); } sub modify { my $self = shift; my $key = shift; return $self->fetch_data($key) unless @_; my $with = shift; if (ref($with) eq 'CODE') { $self->lock("data:$key"); local $_ = $self->fetch_data($key); my $rv = $with->(); $self->store_data($key => $_); $self->unlock("data:$key"); return $rv; } else { $self->store_data($key => $with); return $with; } } sub get { my ($self, $chan, $orig, $curr) = @_; no warnings 'uninitialized'; sort { $a->[0] <=> $b->[0] } $self->fetch( map { my $pub = $_; my $index = $curr->{$pub}; map { "chan:$chan-$pub$_" } (($orig->{$pub}+1) .. $index); } keys(%$curr) ); } sub put { my ($self, $chan, $pub, $index, $msg, $expiry) = @_; $self->store("chan:$chan-$pub$index", $msg, Time::HiRes::time(), $expiry); $self->set_index($chan, $pub, $index); } use constant LOCK => File::Spec->catdir(File::Spec->tmpdir, 'IPC-PubSub-lock-'); my %locks; sub lock { my ($self, $chan) = @_; for my $i (1..10) { return if mkdir((LOCK . unpack("H*", $chan)), 0777); Time::HiRes::usleep(rand(250000)+250000); } } sub disconnect { } END { rmdir(LOCK . unpack("H*", $_)) for keys %locks; } sub unlock { my ($self, $chan) = @_; rmdir(LOCK . unpack("H*", $chan)); delete $locks{$chan}; } 1; IPC-PubSub-0.29/lib/IPC/PubSub.pm0000644000175000017500000001301011120652024015170 0ustar chmrrchmrrpackage IPC::PubSub; $IPC::PubSub::VERSION = '0.29'; use 5.006; use strict; use warnings; use IPC::PubSub::Cacheable; use IPC::PubSub::Publisher; use IPC::PubSub::Subscriber; use base qw/Class::Accessor::Fast/; __PACKAGE__->mk_accessors(qw/_cache/); sub new { my $self = bless {}, shift; my $backend = shift || 'PlainHash'; local $@; eval { require "IPC/PubSub/Cache/$backend.pm" } or die "Cannot load backend module: IPC::PubSub::Cache::$backend: $@"; $self->_cache(IPC::PubSub::Cacheable->new($backend => \@_)); return $self; } sub new_publisher { my $self = shift; IPC::PubSub::Publisher->new($self->_cache, @_ ? @_ : ''); } sub new_subscriber { my $self = shift; IPC::PubSub::Subscriber->new($self->_cache, @_ ? @_ : ''); } sub fetch { ( +shift )->_cache->fetch(@_) } sub store { ( +shift )->_cache->store(@_) } sub lock { ( +shift )->_cache->lock(@_) } sub unlock { ( +shift )->_cache->unlock(@_) } sub modify { ( +shift )->_cache->modify(@_) } sub disconnect { ( +shift )->_cache->disconnect } 1; __END__ =head1 NAME IPC::PubSub - Interprocess Publish/Subscribe channels =head1 SYNOPSIS # A new message bus with the DBM::Deep backend # (Other possible backends include Memcached and PlainHash) my $bus = IPC::PubSub->new(DBM_Deep => '/tmp/pubsub.db'); # A channel is any arbitrary string my $channel = '#perl6'; # Register a new publisher (you can publish to multiple channels) my $pub = $bus->new_publisher("#perl6", "#moose"); # Publish a message (may be a complex object) to those channels $pub->msg("This is a message"); # Register a new subscriber (you can subscribe to multiple channels) my $sub = $bus->new_subscriber("#moose"); # Publish an object to channels $pub->msg("This is another message"); # Set all subsequent messages from this publisher to expire in 30 seconds $pub->expiry(30); $pub->msg("This message will go away in 30 seconds"); # Simple get: Returns the messages sent since the previous get, # but only for the first channel. my @msgs = $sub->get; # Simple get, with an explicit channel key (must be among the ones # it initially subscribed to) my @moose_msgs = $sub->get("#moose"); # Complex get: Returns a hash reference from channels to array # references of [timestamp, message]. my $hash_ref = $sub->get_all; # Changing the list of channels we subscribe to $sub->subscribe('some-other-channel'); $sub->unsubscribe('some-other-channel'); # Changing the list of channels we publish to $pub->publish('some-other-channel'); $pub->unpublish('some-other-channel'); # Listing and checking if we are in a channel my @sub_channels = $sub->channels; my @pub_channels = $pub->channels; print "Sub is in #moose" if $sub->channels->{'#moose'}; print "Pub is in #moose" if $pub->channels->{'#moose'}; # Raw cache manipulation APIs (not advised; use ->modify instead) $bus->lock('channel'); $bus->unlock('channel'); my @timed_msgs = $bus->fetch('key1', 'key2', 'key3'); $bus->store('key', 'value', time, 30); # Atomic updating of cache content; $_ is stored back on the # end of the callback. my $rv = $bus->modify('key' => sub { delete $_->{foo} }); # Shorthand for $bus->modify('key' => sub { $_ = 'val' }); $bus->modify('key' => 'val'); # Shorthand for $bus->modify('key' => sub { $_ }); $bus->modify('key'); # Disconnect the backend connection explicitly $bus->disconnect; =head1 DESCRIPTION This module provides a simple API for publishing messages to I and for subscribing to them. When a I is published on a channel, all subscribers currently in that channel will get it on their next C or C call. Currently, it offers four backends: C for on-disk storage, C for possibly multi-host storage, C for database-backed storage, and C for single-process storage. Please see the tests in F for this distribution, as well as L above, for some usage examples; detailed documentation is not yet available. =head1 SEE ALSO L, where the subscribers divide the published messages among themselves, so different subscribers never see the same message. =head1 AUTHORS Audrey Tang Ecpan@audreyt.orgE =head1 COPYRIGHT Copyright 2006, 2007 by Audrey Tang Ecpan@audreyt.orgE. This software is released under the MIT license cited below. =head2 The "MIT" License Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =cut IPC-PubSub-0.29/t/0000755000175000017500000000000011120652370012525 5ustar chmrrchmrrIPC-PubSub-0.29/t/basic.t0000644000175000017500000000361511054644260014005 0ustar chmrrchmrruse strict; use warnings; use Test::More; use IPC::PubSub; use IO::Socket::INET; use File::Temp ':POSIX'; my @backends = qw(PlainHash); unshift @backends, 'DBM_Deep' if eval { require DBM::Deep }; unshift @backends, 'JiftyDBI' if eval { require Jifty::DBI }; unshift @backends, 'Memcached' if eval { require Cache::Memcached } and IO::Socket::INET->new('127.0.0.1:11211'); plan tests => 15 * scalar @backends; my $tmp = tmpnam(); END { unlink $tmp } my %init_args = ( DBM_Deep => [ $tmp ], JiftyDBI => [ db_init => 1 ], Memcached => [ rand() . $$ ], ); SKIP: for my $backend (@backends) { diag("Testing backend $backend"); my $bus = IPC::PubSub->new($backend, @{$init_args{$backend}}); my @sub; $sub[0] = $bus->new_subscriber; is_deeply([map {$_->[1]} @{$sub[0]->get_all->{''}}], [], 'get_all worked when there is no pubs'); is_deeply([$sub[0]->get], [], 'get_all worked when there is no pubs'); my $pub = $bus->new_publisher; $pub->msg('foo'); $sub[1] = $bus->new_subscriber; $pub->msg(['bar', 'bar']); $pub->msg('baz'); my $got = $sub[0]->get; is($got->[0], 'foo', 'get worked'); is($got->[1][0], 'bar', 'get worked'); is($got->[1][1], 'bar', 'get worked'); is($got->[2], 'baz', 'get worked'); is_deeply([$sub[0]->get], [], 'get emptied the cache'); is_deeply([map {ref($_) ? [@$_] : $_} map {$_->[1]} @{$sub[1]->get_all->{''}}], [['bar', 'bar'], 'baz'], 'get_all worked'); is_deeply([map {ref($_) ? [@$_] : $_} map {$_->[1]} @{$sub[1]->get_all->{''}}], [], 'get_all emptied the cache'); is($bus->modify('key'), undef, 'modify (1)'); is($bus->modify('key' => 'val'), 'val', 'modify (2)'); is($bus->modify('key'), 'val', 'modify (3)'); is($bus->modify('key' => sub { s/v/h/ }), 1, 'modify (4)'); is($bus->modify('key'), 'hal', 'modify (5)'); is($bus->modify('key' => undef), undef, 'modify (6)'); } IPC-PubSub-0.29/t/publisher.t0000644000175000017500000000712711120124204014704 0ustar chmrrchmrruse strict; use warnings; use Test::More; use IPC::PubSub; use IO::Socket::INET; use File::Temp ':POSIX'; my @backends = qw(PlainHash); unshift @backends, 'DBM_Deep' if eval { require DBM::Deep }; unshift @backends, 'JiftyDBI' if eval { require Jifty::DBI }; unshift @backends, 'Memcached' if eval { require Cache::Memcached } and IO::Socket::INET->new('127.0.0.1:11211'); plan tests => 33 * scalar @backends; my $tmp = tmpnam(); END { unlink $tmp } my %init_args = ( DBM_Deep => [ $tmp ], JiftyDBI => [ db_init => 1 ], Memcached => [ rand() . $$ ], ); SKIP: for my $backend (@backends) { diag("Testing backend $backend"); my $bus = IPC::PubSub->new( $backend, @{ $init_args{$backend} } ); my $pub = $bus->new_publisher( "first", "second" ); my $cache = $bus->_cache; is_deeply( scalar $pub->channels, { first => 1, second => 1 } ); is_deeply( [ sort $pub->channels ], [ "first", "second" ] ); is_deeply( $cache->publisher_indices("first"), { $pub->uuid => 0 } ); is_deeply( $cache->publisher_indices("second"), { $pub->uuid => 0 } ); is_deeply( $cache->publisher_indices("third"), {} ); $pub->publish("third"); is_deeply( scalar $pub->channels, { first => 1, second => 1, third => 1 } ); is_deeply( [ sort $pub->channels ], [ "first", "second", "third" ] ); is_deeply( $cache->publisher_indices("first"), { $pub->uuid => 0 } ); is_deeply( $cache->publisher_indices("second"), { $pub->uuid => 0 } ); is_deeply( $cache->publisher_indices("third"), { $pub->uuid => 0 } ); $pub->publish("third"); is_deeply( scalar $pub->channels, { first => 1, second => 1, third => 1 } ); is_deeply( [ sort $pub->channels ], [ "first", "second", "third" ] ); is_deeply( $cache->publisher_indices("third"), { $pub->uuid => 0 } ); $pub->msg("message 1"); is_deeply( scalar $pub->channels, { first => 2, second => 2, third => 2 } ); $pub->unpublish("second"); is_deeply( scalar $pub->channels, { first => 2, third => 2 } ); $pub->msg("message 2"); is_deeply( scalar $pub->channels, { first => 3, third => 3 } ); is_deeply( $cache->publisher_indices("first"), { $pub->uuid => 2 } ); is_deeply( $cache->publisher_indices("second"), {} ); is_deeply( $cache->publisher_indices("third"), { $pub->uuid => 2 } ); is($cache->get_index( first => $pub->uuid ), 2 ); $cache->set_index( first => $pub->uuid, 5 ); is($cache->get_index( first => $pub->uuid ), 5 ); is_deeply( $cache->publisher_indices("first"), { $pub->uuid => 5 } ); { my $pub2 = $bus->new_publisher( "first", "second", "third" ); is_deeply( scalar $pub2->channels, { first => 1, second => 1, third => 1 } ); is_deeply( $cache->publisher_indices("first"), { $pub->uuid => 5, $pub2->uuid => 0 } ); is_deeply( $cache->publisher_indices("second"), { $pub2->uuid => 0 } ); is_deeply( $cache->publisher_indices("third"), { $pub->uuid => 2, $pub2->uuid => 0 } ); $pub2->unpublish("first"); is_deeply( scalar $pub2->channels, { second => 1, third => 1 } ); is_deeply( $cache->publisher_indices("first"), { $pub->uuid => 5 } ); is_deeply( $cache->publisher_indices("second"), { $pub2->uuid => 0 } ); is_deeply( $cache->publisher_indices("third"), { $pub->uuid => 2, $pub2->uuid => 0 } ); } is_deeply( $cache->publisher_indices("first"), { $pub->uuid => 5 } ); is_deeply( $cache->publisher_indices("second"), {} ); is_deeply( $cache->publisher_indices("third"), { $pub->uuid => 2 } ); } IPC-PubSub-0.29/Makefile.PL0000644000175000017500000000043411054644261014243 0ustar chmrrchmrruse strict; use inc::Module::Install; name 'IPC-PubSub'; license 'MIT'; all_from 'lib/IPC/PubSub.pm'; requires 'Storable'; requires 'Time::HiRes'; requires 'DBM::Deep' => '1.00'; requires 'Data::UUID'; requires 'Class::Accessor::Fast'; sign; WriteAll; IPC-PubSub-0.29/README0000644000175000017500000001120510567232176013155 0ustar chmrrchmrrNAME IPC::PubSub - Interprocess Publish/Subscribe channels SYNOPSIS # A new message bus with the DBM::Deep backend # (Other possible backends include Memcached and PlainHash) my $bus = IPC::PubSub->new(DBM_Deep => '/tmp/pubsub.db'); # A channel is any arbitrary string my $channel = '#perl6'; # Register a new publisher (you can publish to multiple channels) my $pub = $bus->new_publisher("#perl6", "#moose"); # Publish a message (may be a complex object) to those channels $pub->msg("This is a message"); # Register a new subscriber (you can subscribe to multiple channels) my $sub = $bus->new_subscriber("#moose"); # Publish an object to channels $pub->msg("This is another message"); # Set all subsequent messages from this publisher to expire in 30 seconds $pub->expiry(30); $pub->msg("This message will go away in 30 seconds"); # Simple get: Returns the messages sent since the previous get, # but only for the first channel. my @msgs = $sub->get; # Simple get, with an explicit channel key (must be among the ones # it initially subscribed to) my @moose_msgs = $sub->get("#moose"); # Complex get: Returns a hash reference from channels to array # references of [timestamp, message]. my $hash_ref = $sub->get_all; # Changing the list of channels we subscribe to $sub->subscribe('some-other-channel'); $sub->unsubscribe('some-other-channel'); # Changing the list of channels we publish to $pub->publish('some-other-channel'); $pub->unpublish('some-other-channel'); # Listing and checking if we are in a channel my @sub_channels = $sub->channels; my @pub_channels = $pub->channels; print "Sub is in #moose" if $sub->channels->{'#moose'}; print "Pub is in #moose" if $pub->channels->{'#moose'}; # Raw cache manipulation APIs (not advised; use ->modify instead) $bus->lock('channel'); $bus->unlock('channel'); my @timed_msgs = $bus->fetch('key1', 'key2', 'key3'); $bus->store('key', 'value', time, 30); # Atomic updating of cache content; $_ is stored back on the # end of the callback. my $rv = $bus->modify('key' => sub { delete $_->{foo} }); # Shorthand for $bus->modify('key' => sub { $_ = 'val' }); $bus->modify('key' => 'val'); # Shorthand for $bus->modify('key' => sub { $_ }); $bus->modify('key'); # Disconnect the backend connection explicitly $bus->disconnect; DESCRIPTION This module provides a simple API for publishing messages to *channels* and for subscribing to them. When a *message* is published on a channel, all subscribers currently in that channel will get it on their next "get" or "get_all" call. Currently, it offers three backends: "DBM_Deep" for on-disk storage, "Memcached" for possibly multi-host storage, and "PlainHash" for single-process storage. Please see the tests in t/ for this distribution, as well as "SYNOPSIS" above, for some usage examples; detailed documentation is not yet available. SEE ALSO IPC::DirQueue, where the subscribers divide the published messages among themselves, so different subscribers never see the same message. AUTHORS Audrey Tang COPYRIGHT Copyright 2006, 2007 by Audrey Tang . This software is released under the MIT license cited below. The "MIT" License Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. IPC-PubSub-0.29/inc/0000755000175000017500000000000011120652370013033 5ustar chmrrchmrrIPC-PubSub-0.29/inc/Module/0000755000175000017500000000000011120652370014260 5ustar chmrrchmrrIPC-PubSub-0.29/inc/Module/Install/0000755000175000017500000000000011120652370015666 5ustar chmrrchmrrIPC-PubSub-0.29/inc/Module/Install/Win32.pm0000644000175000017500000000340211120652301017117 0ustar chmrrchmrr#line 1 package Module::Install::Win32; use strict; use Module::Install::Base; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.70'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; IPC-PubSub-0.29/inc/Module/Install/Base.pm0000644000175000017500000000203511120652301017070 0ustar chmrrchmrr#line 1 package Module::Install::Base; $VERSION = '0.70'; # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } ### This is the ONLY module that shouldn't have strict on # use strict; #line 41 sub new { my ($class, %args) = @_; foreach my $method ( qw(call load) ) { *{"$class\::$method"} = sub { shift()->_top->$method(@_); } unless defined &{"$class\::$method"}; } bless( \%args, $class ); } #line 61 sub AUTOLOAD { my $self = shift; local $@; my $autoload = eval { $self->_top->autoload } or return; goto &$autoload; } #line 76 sub _top { $_[0]->{_top} } #line 89 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } sub is_admin { $_[0]->admin->VERSION; } sub DESTROY {} package Module::Install::Base::FakeAdmin; my $Fake; sub new { $Fake ||= bless(\@_, $_[0]) } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 138 IPC-PubSub-0.29/inc/Module/Install/Makefile.pm0000644000175000017500000001416211120652301017737 0ustar chmrrchmrr#line 1 package Module::Install::Makefile; use strict 'vars'; use Module::Install::Base; use ExtUtils::MakeMaker (); use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.70'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing, always use defaults if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } sub makemaker_args { my $self = shift; my $args = ($self->{makemaker_args} ||= {}); %$args = ( %$args, @_ ) if @_; $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = sShift; my $name = shift; my $args = $self->makemaker_args; $args->{name} = defined $args->{$name} ? join( ' ', $args->{name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join(' ', grep length, $clean->{FILES}, @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join(' ', grep length, $realclean->{FILES}, @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } my %test_dir = (); sub _wanted_t { /\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1; } sub tests_recursive { my $self = shift; if ( $self->tests ) { die "tests_recursive will not work if tests are already defined"; } my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } %test_dir = (); require File::Find; File::Find::find( \&_wanted_t, $dir ); $self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Make sure we have a new enough require ExtUtils::MakeMaker; $self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION ); # Generate the my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name || $self->determine_NAME($args); $args->{VERSION} = $self->version || $self->determine_VERSION($args); $args->{NAME} =~ s/-/::/g; if ( $self->tests ) { $args->{test} = { TESTS => $self->tests }; } if ($] >= 5.005) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = $self->author; } if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) { $args->{NO_META} = 1; } if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } # merge both kinds of requires into prereq_pm my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } map { @$_ } grep $_, ($self->configure_requires, $self->build_requires, $self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # merge both kinds of requires into prereq_pm my $subdirs = ($args->{DIR} ||= []); if ($self->bundles) { foreach my $bundle (@{ $self->bundles }) { my ($file, $dir) = @$bundle; push @$subdirs, $dir if -d $dir; delete $prereq->{$file}; } } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } $args->{INSTALLDIRS} = $self->installdirs; my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if (my $preop = $self->admin->preop($user_preop)) { $args{dist} = $preop; } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; my $makefile = do { local $/; }; close MAKEFILE or die $!; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 371 IPC-PubSub-0.29/inc/Module/Install/Fetch.pm0000644000175000017500000000463011120652301017252 0ustar chmrrchmrr#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base; use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.70'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; IPC-PubSub-0.29/inc/Module/Install/WriteAll.pm0000644000175000017500000000132111120652301017736 0ustar chmrrchmrr#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.70'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->Meta->write if $args{meta}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { $self->makemaker_args( PL_FILES => {} ); } if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } } 1; IPC-PubSub-0.29/inc/Module/Install/Metadata.pm0000644000175000017500000001710711120652301017744 0ustar chmrrchmrr#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base; use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.70'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } my @scalar_keys = qw{ name module_name abstract author version license distribution_type perl_version tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles }; sub Meta { shift } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } foreach my $key (@scalar_keys) { *$key = sub { my $self = shift; return $self->{values}{$key} if defined wantarray and !@_; $self->{values}{$key} = shift; return $self; }; } foreach my $key (@tuple_keys) { *$key = sub { my $self = shift; return $self->{values}{$key} unless @_; my @rv; while (@_) { my $module = shift or last; my $version = shift || 0; if ( $module eq 'perl' ) { $version =~ s{^(\d+)\.(\d+)\.(\d+)} {$1 + $2/1_000 + $3/1_000_000}e; $self->perl_version($version); next; } my $rv = [ $module, $version ]; push @rv, $rv; } push @{ $self->{values}{$key} }, @rv; @rv; }; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub sign { my $self = shift; return $self->{'values'}{'sign'} if defined wantarray and ! @_; $self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 ); return $self; } sub dynamic_config { my $self = shift; unless ( @_ ) { warn "You MUST provide an explicit true/false value to dynamic_config, skipping\n"; return $self; } $self->{'values'}{'dynamic_config'} = $_[0] ? 1 : 0; return $self; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die "all_from called with no args without setting name() first"; $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; die "all_from: cannot find $file from $name" unless -e $file; } $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; # The remaining probes read from POD sections; if the file # has an accompanying .pod, use that instead my $pod = $file; if ( $pod =~ s/\.pm$/.pod/i and -e $pod ) { $file = $pod; } $self->author_from($file) unless $self->author; $self->license_from($file) unless $self->license; $self->abstract_from($file) unless $self->abstract; } sub provides { my $self = shift; my $provides = ( $self->{values}{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}{no_index}{$type} }, @_ if $type; return $self->{values}{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML', 0 ); require YAML; my $data = YAML::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } sub _slurp { local *FH; open FH, "< $_[1]" or die "Cannot open $_[1].pod: $!"; do { local $/; }; } sub perl_version_from { my ( $self, $file ) = @_; if ( $self->_slurp($file) =~ m/ ^ use \s* v? ([\d_\.]+) \s* ; /ixms ) { my $v = $1; $v =~ s{_}{}g; $self->perl_version($1); } else { warn "Cannot determine perl version info from $file\n"; return; } } sub author_from { my ( $self, $file ) = @_; my $content = $self->_slurp($file); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; $author =~ s{E}{<}g; $author =~ s{E}{>}g; $self->author($author); } else { warn "Cannot determine author info from $file\n"; } } sub license_from { my ( $self, $file ) = @_; if ( $self->_slurp($file) =~ m/ ( =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b .*? ) (=head\\d.*|=cut.*|) \z /ixms ) { my $license_text = $1; my @phrases = ( 'under the same (?:terms|license) as perl itself' => 'perl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'BSD license' => 'bsd', 1, 'Artistic license' => 'artistic', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s{\s+}{\\s+}g; if ( $license_text =~ /\b$pattern\b/i ) { if ( $osi and $license_text =~ /All rights reserved/i ) { warn "LEGAL WARNING: 'All rights reserved' may invalidate Open Source licenses. Consider removing it."; } $self->license($license); return 1; } } } warn "Cannot determine license info from $file\n"; return 'unknown'; } 1; IPC-PubSub-0.29/inc/Module/Install/Can.pm0000644000175000017500000000337411120652301016726 0ustar chmrrchmrr#line 1 package Module::Install::Can; use strict; use Module::Install::Base; use Config (); ### This adds a 5.005 Perl version dependency. ### This is a bug and will be fixed. use File::Spec (); use ExtUtils::MakeMaker (); use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.70'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { my $abs = File::Spec->catfile($dir, $_[1]); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 157 IPC-PubSub-0.29/inc/Module/Install.pm0000644000175000017500000001711211120652300016217 0ustar chmrrchmrr#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } BEGIN { require 5.004; } use strict 'vars'; use vars qw{$VERSION}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '0.70'; } # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 and (stat($0))[9] > time ) { die <<"END_DIE" } Your installer $0 has a modification time in the future. This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i or -f 'Build.PL' ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE use Cwd (); use File::Find (); use File::Path (); use FindBin; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # delegate back to parent dirs goto &$code unless $cwd eq $pwd; } $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym"; unshift @_, ( $self, $1 ); goto &{$self->can('call')} unless uc($1) eq $1; }; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; unless ( -f $self->{file} ) { require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{"$self->{file}"}; delete $INC{"$self->{path}.pm"}; return 1; } sub preload { my ($self) = @_; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { my $admin = $self->{admin}; @exts = $admin->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = delete $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { open PKGFILE, "<$subpath.pm" or die "find_extensions: Can't open $subpath.pm: $!"; my $in_pod = 0; while ( ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } close PKGFILE; } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } 1; # Copyright 2008 Adam Kennedy.