ASP4x-Linker

 view release on metacpan or  search on metacpan

Changes  view on Meta::CPAN

2010-05-13      v0.003
  - Now, $linker->uri({foo => 'bar'}) returns a uri with foo=bar in there someplace.
  - Upgrade recommended.

2010-04-01      v.0.002
  - Added vars() method.
  - Updated docs.
  - Removed AUTOLOAD behavior from Widget and Linker.
  - Added $widget->get( $attr ) and $widget->set( $attr => $value )
  - Added $widget->on_change( $attr => sub { ... } )
  - Added several tests.

2010-04-01      v0.001
  - Initial release.
  - No joke!

inc/Module/Install.pm  view on Meta::CPAN

use Cwd        ();
use File::Find ();
use File::Path ();
use FindBin;

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";
		unless ( uc($1) eq $1 ) {
			unshift @_, ( $self, $1 );
			goto &{$self->can('call')};
		}
	};
}

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);

inc/Module/Install.pm  view on Meta::CPAN

	*{"${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 = shift;
	unless ( $self->{extensions} ) {
		$self->load_extensions(
			"$self->{prefix}/$self->{path}", $self
		);
	}

	my @exts = @{$self->{extensions}};
	unless ( @exts ) {
		my $admin = $self->{admin};

inc/Module/Install.pm  view on Meta::CPAN

		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};

inc/Module/Install.pm  view on Meta::CPAN

	unless ( $args{path} ) {
		$args{path}  = $args{name};
		$args{path}  =~ s!::!/!g;
	}
	$args{file}     ||= "$args{base}/$args{prefix}/$args{path}.pm";
	$args{wrote}      = 0;

	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);
	}

inc/Module/Install.pm  view on Meta::CPAN

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 { !ref $_ and 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};

inc/Module/Install.pm  view on Meta::CPAN

			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

inc/Module/Install.pm  view on Meta::CPAN

	@found;
}





#####################################################################
# Utility Functions

sub _caller {
	my $depth = 0;
	my $call  = caller($depth);
	while ( $call eq __PACKAGE__ ) {
		$depth++;
		$call = caller($depth);
	}
	return $call;
}

sub _read {
	local *FH;
	open FH, "< $_[0]" or die "open($_[0]): $!";
	my $str = do { local $/; <FH> };
	close FH or die "close($_[0]): $!";
	return $str;
}

sub _write {
	local *FH;
	open FH, "> $_[0]" or die "open($_[0]): $!";
	foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!" }
	close FH or die "close($_[0]): $!";
}

# _version is for processing module versions (eg, 1.03_05) not
# Perl versions (eg, 5.8.1).

sub _version ($) {
	my $s = shift || 0;
	   $s =~ s/^(\d+)\.?//;
	my $l = $1 || 0;
	my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g;
	   $l = $l . '.' . join '', @v if @v;
	return $l + 0;
}

# Cloned from Params::Util::_CLASS
sub _CLASS ($) {
	(
		defined $_[0]
		and
		! ref $_[0]
		and
		$_[0] =~ m/^[^\W\d]\w*(?:::\w+)*$/s
	) ? $_[0] : undef;
}

1;

inc/Module/Install/Base.pm  view on Meta::CPAN

#line 1
package Module::Install::Base;

$VERSION = '0.79';

# 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;
}

#line 101

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 146

inc/Module/Install/Can.pm  view on Meta::CPAN

use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
	$VERSION = '0.79';
	$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}), '.') {
		next if $dir eq '';
		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);
			}
		}
	}
}

inc/Module/Install/Fetch.pm  view on Meta::CPAN

use strict;
use Module::Install::Base;

use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
	$VERSION = '0.79';
	$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;
    }

inc/Module/Install/Makefile.pm  view on Meta::CPAN

use Module::Install::Base;
use ExtUtils::MakeMaker ();

use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
	$VERSION = '0.79';
	$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, @_ );
	return $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;

	# MakeMaker can complain about module versions that include
	# an underscore, even though its own version may contain one!
	# Hence the funny regexp to get rid of it.  See RT #35800
	# for details.

inc/Module/Install/Makefile.pm  view on Meta::CPAN

	if (my $preop = $self->admin->preop($user_preop)) {
		foreach my $key ( keys %$preop ) {
			$args{dist}->{$key} = $preop->{$key};
		}
	}

	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"

inc/Module/Install/Makefile.pm  view on Meta::CPAN

	# 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__

inc/Module/Install/Metadata.pm  view on Meta::CPAN

	bundles
	resources
};

my @resource_keys = qw{
	homepage
	bugtracker
	repository
};

sub Meta              { shift          }
sub Meta_ScalarKeys   { @scalar_keys   }
sub Meta_TupleKeys    { @tuple_keys    }
sub Meta_ResourceKeys { @resource_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 ( @resource_keys ) {
	*$key = sub {
		my $self = shift;
		unless ( @_ ) {
			return () unless $self->{values}{resources};
			return map  { $_->[1] }
			       grep { $_->[0] eq $key }
			       @{ $self->{values}{resources} };
		}
		return $self->{values}{resources}{$key} unless @_;
		my $uri = shift or die(
			"Did not provide a value to $key()"
		);
		$self->resources( $key => $uri );
		return 1;
	};
}

sub requires {
	my $self = shift;
	while ( @_ ) {
		my $module  = shift or last;
		my $version = shift || 0;
		push @{ $self->{values}{requires} }, [ $module, $version ];
	}
	$self->{values}{requires};
}

sub build_requires {
	my $self = shift;
	while ( @_ ) {
		my $module  = shift or last;
		my $version = shift || 0;
		push @{ $self->{values}{build_requires} }, [ $module, $version ];
	}
	$self->{values}{build_requires};
}

sub configure_requires {
	my $self = shift;
	while ( @_ ) {
		my $module  = shift or last;
		my $version = shift || 0;
		push @{ $self->{values}{configure_requires} }, [ $module, $version ];
	}
	$self->{values}{configure_requires};
}

sub recommends {
	my $self = shift;
	while ( @_ ) {
		my $module  = shift or last;
		my $version = shift || 0;
		push @{ $self->{values}{recommends} }, [ $module, $version ];
	}
	$self->{values}{recommends};
}

sub bundles {
	my $self = shift;
	while ( @_ ) {
		my $module  = shift or last;
		my $version = shift || 0;
		push @{ $self->{values}{bundles} }, [ $module, $version ];
	}
	$self->{values}{bundles};
}

# Resource handling
my %lc_resource = map { $_ => 1 } qw{
	homepage
	license
	bugtracker
	repository
};

sub resources {
	my $self = shift;
	while ( @_ ) {
		my $name  = shift or last;
		my $value = shift or next;
		if ( $name eq lc $name and ! $lc_resource{$name} ) {
			die("Unsupported reserved lowercase resource '$name'");
		}
		$self->{values}{resources} ||= [];
		push @{ $self->{values}{resources} }, [ $name, $value ];
	}
	$self->{values}{resources};
}

# 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\n";
		return $self;
	}
	$self->{values}{dynamic_config} = $_[0] ? 1 : 0;
	return 1;
}

sub perl_version {
	my $self = shift;
	return $self->{values}{perl_version} unless @_;
	my $version = shift or die(
		"Did not provide a value to perl_version()"
	);

	# Normalize the version
	$version = $self->_perl_version($version);

	# We don't support the reall old versions
	unless ( $version >= 5.005 ) {
		die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n";
	}

	$self->{values}{perl_version} = $version;
}

sub license {
	my $self = shift;
	return $self->{values}{license} unless @_;
	my $license = shift or die(
		'Did not provide a value to license()'
	);
	$self->{values}{license} = $license;

	# Automatically fill in license URLs
	if ( $license eq 'perl' ) {
		$self->resources( license => 'http://dev.perl.org/licenses/' );
	}

	return 1;
}

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;
		unless ( -e $file ) {
			die("all_from cannot find $file from $name");

inc/Module/Install/Metadata.pm  view on Meta::CPAN

	$self->name_from($file)         unless $self->name;
	$self->version_from($file)      unless $self->version;
	$self->perl_version_from($file) unless $self->perl_version;
	$self->author_from($pod)        unless $self->author;
	$self->license_from($pod)       unless $self->license;
	$self->abstract_from($pod)      unless $self->abstract;

	return 1;
}

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 {

inc/Module/Install/Metadata.pm  view on Meta::CPAN

		$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::Tiny', 0 );

	require YAML::Tiny;
	my $data = YAML::Tiny::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)
	 );
}

# Add both distribution and module name
sub name_from {
	my ($self, $file) = @_;
	if (
		Module::Install::_read($file) =~ m/
		^ \s*
		package \s*
		([\w:]+)
		\s* ;
		/ixms
	) {
		my ($name, $module_name) = ($1, $1);
		$name =~ s{::}{-}g;
		$self->name($name);
		unless ( $self->module_name ) {
			$self->module_name($module_name);
		}
	} else {
		die("Cannot determine name from $file\n");
	}
}

sub perl_version_from {
	my $self = shift;
	if (
		Module::Install::_read($_[0]) =~ m/
		^
		(?:use|require) \s*
		v?
		([\d_\.]+)
		\s* ;
		/ixms
	) {
		my $perl_version = $1;
		$perl_version =~ s{_}{}g;
		$self->perl_version($perl_version);
	} else {
		warn "Cannot determine perl version info from $_[0]\n";
		return;
	}
}

sub author_from {
	my $self    = shift;
	my $content = Module::Install::_read($_[0]);
	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<lt>}{<}g;
		$author =~ s{E<gt>}{>}g;
		$self->author($author);
	} else {
		warn "Cannot determine author info from $_[0]\n";
	}
}

sub license_from {
	my $self = shift;
	if (
		Module::Install::_read($_[0]) =~ m/
		(
			=head \d \s+
			(?:licen[cs]e|licensing|copyright|legal)\b
			.*?
		)
		(=head\\d.*|=cut.*|)
		\z

inc/Module/Install/Metadata.pm  view on Meta::CPAN

				$self->license($license);
				return 1;
			}
		}
	}

	warn "Cannot determine license info from $_[0]\n";
	return 'unknown';
}

sub bugtracker_from {
	my $self    = shift;
	my $content = Module::Install::_read($_[0]);
	my @links   = $content =~ m/L\<(http\:\/\/rt\.cpan\.org\/[^>]+)\>/g;
	unless ( @links ) {
		warn "Cannot determine bugtracker info from $_[0]\n";
		return 0;
	}
	if ( @links > 1 ) {
		warn "Found more than on rt.cpan.org link in $_[0]\n";
		return 0;
	}

	# Set the bugtracker
	bugtracker( $links[0] );
	return 1;
}

# Convert triple-part versions (eg, 5.6.1 or 5.8.9) to
# numbers (eg, 5.006001 or 5.008009).
# Also, convert double-part versions (eg, 5.8)
sub _perl_version {
	my $v = $_[-1];
	$v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e;	
	$v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e;
	$v =~ s/(\.\d\d\d)000$/$1/;
	$v =~ s/_.+$//;
	if ( ref($v) ) {
		$v = $v + 0; # Numify
	}
	return $v;
}





######################################################################
# MYMETA.yml Support

sub WriteMyMeta {
	$_[0]->write_mymeta;
}

sub write_mymeta {
	my $self = shift;
	
	# If there's no existing META.yml there is nothing we can do
	return unless -f 'META.yml';

	# Merge the perl version into the dependencies
	my $val  = $self->Meta->{values};
	my $perl = delete $val->{perl_version};
	if ( $perl ) {
		$val->{requires} ||= [];

inc/Module/Install/Win32.pm  view on Meta::CPAN

use Module::Install::Base;

use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
	$VERSION = '0.79';
	@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')

inc/Module/Install/WriteAll.pm  view on Meta::CPAN

use strict;
use Module::Install::Base;

use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
	$VERSION = '0.79';
	@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};

lib/ASP4x/Linker.pm  view on Meta::CPAN

use strict;
use warnings 'all';
use Carp 'confess';
use ASP4x::Linker::Widget;
use ASP4::ConfigLoader;

our $VERSION = '1.003';


sub new
{
  my ($class, %args) = @_;
  
  $args{base_href} ||= $ENV{REQUEST_URI};
  confess "No 'base_href' argument provided and can't discover it from \$ENV{REQUEST_URI}!"
    unless $args{base_href};
  
  $args{widgets} = [ ];
  
  return bless \%args, $class;
}# end new()


# Public read-only properties:
sub base_href { shift->{base_href} }
sub _router { eval { ASP4::ConfigLoader->load->web->router } }
sub widgets { @{ shift->{widgets} } }


sub add_widget
{
  my ($s, %args) = @_;
  
  my $widget = ASP4x::Linker::Widget->new( %args );
  $widget->linker( $s );
  
  confess "Another widget with the name '@{[ $widget->name ]}' already exists."
    if grep { $_->name eq $widget->name } $s->widgets;
  
  push @{ $s->{widgets} }, $widget;
  $widget;
}# end add_widget()


sub widget
{
  my ($s, $name) = @_;
  
  my ($widget) = grep { $_->name eq $name } $s->widgets
    or return;
  
  return $widget;
}# end widget()


sub reset
{
  map { $_->reset } shift->widgets;
}# end reset()


sub uri
{
  my ($s, $args) = @_;
  
  my $vars = $s->vars( $args );
  
  no warnings 'uninitialized';
  my ($uri) = split /\?/, $s->base_href;
  my $context = ASP4::HTTPContext->current;
  my $server = $context->server;
  my $final_querystring = join '&', map { $server->URLEncode($_) . '=' . $server->URLEncode($vars->{$_}) }
                                      grep { defined($vars->{$_}) }
                                        sort keys %$vars;
  
  return $final_querystring ? join '?', ( $uri, $final_querystring ) : $uri;
}# end uri()


sub hidden_fields
{
  my ($s, $args) = @_;
  
  my $vars = $s->vars( $args, 1 );
  
  no warnings 'uninitialized';
  my ($uri) = split /\?/, $s->base_href;
  my $context = ASP4::HTTPContext->current;
  my $server = $context->server;

  my @inputs = map {qq(<input type="hidden" name="@{[ $server->URLEncode( $_ ) ]}" value="@{[ $server->URLEncode( $vars->{$_} ) ]}" />)}
                 keys %$vars;
  return join "\n", @inputs;
}# end hidden_fields()


sub vars
{
  my ($s, $args) = @_;
  
  my @parts = ( );
  no warnings 'uninitialized';
  my ($uri) = split /\?/, $s->base_href;
  
  my $context = ASP4::HTTPContext->current;
  my $server = $context->server;
  my %vars = %{ $context->request->Form };

lib/ASP4x/Linker.pm  view on Meta::CPAN

  map { $vars{$_} = $args->{$_} }
    grep { ! ref($args->{$_}) }
      sort keys %$args;
  
  my $res = \%vars;
  $s->reset();
  return $res;
}# end _prepare_vars()


sub DESTROY { my $s = shift; undef(%$s); }

1;

=pod

=head1 NAME

ASP4x::Linker - In-page persistence of widget-specific variables.

=head1 DEPRECATED

lib/ASP4x/Linker.pm  view on Meta::CPAN

  -or be more specific-
  my $linker = ASP4x::Linker->new( base_href => "/whatever.html" );
  
  # Add a widget:
  $linker->add_widget(
    name  => "widgetA",
    attrs => [qw( page_size page_number sort_col sort_dir )]
  );
  
  # If the page size is changed, go back to page 1:
  $linker->widget("widgetA")->on_change( page_size => sub {
    my ($s) = @_;
    $s->set( page_number => 1 );
  });
  
  # Add another widget:
  $linker->add_widget(
    name  => "widgetB",
    attrs => [qw( keywords tag start_date stop_date )]
  );
  

lib/ASP4x/Linker/Widget.pm  view on Meta::CPAN

package ASP4x::Linker::Widget;

use strict;
use warnings 'all';
use Carp 'confess';


sub new
{
  my ($class, %args) = @_;
  
  foreach(qw( name ))
  {
    confess "Required param '$_' was not provided"
      unless $args{$_};
  }# end foreach()
  
  my $context = ASP4::HTTPContext->current;

lib/ASP4x/Linker/Widget.pm  view on Meta::CPAN

  };
  $args{original_vars} = {
    map { $_ => $form->{"$args{name}.$_"} }
      @{$args{attrs}}
  };
  
  return bless \%args, $class;
}# end new()


sub attrs { sort @{ shift->{attrs} } }

sub name { shift->{name} }

sub set
{
  my ($s, %args) = @_;
  while( my ($attr, $val) = each %args )
  {
    confess "widget '$s->{name}' does not have any attribute named '$attr'"
      unless exists($s->{vars}->{$attr});
    $s->{vars}->{$attr} = $val;
    if( my $triggers = $s->{triggers}->{$attr} )
    {
      map { $_->( $s ) } @$triggers
    }# end if()
  }# end while()
  
#  $val;
  $s;
}# end set()


sub get
{
  my ($s, $key) = @_;
  
  exists( $s->{vars}->{ $key } ) or return;
  $s->{vars}->{$key};
}# end get()


sub vars
{
  my $s = shift;
  
  return $s->{vars};
}# end filters()


sub reset
{
  my $s = shift;
  
  %{ $s->{vars} } = %{ $s->{original_vars} };
}# end reset()


sub linker
{
  my $s = shift;
  @_ ? $s->{linker} = shift : $s->{linker};
}# end linker()


sub uri { shift->linker->uri }


sub on_change
{
  my ($s, $attr, $code) = @_;
  
  return unless exists( $s->{vars}->{$attr} );
  $s->{triggers}->{ $attr } ||= [ ];
  push @{ $s->{triggers}->{ $attr } }, $code;
}# end on_change()

sub DESTROY { my $s = shift; undef(%$s); }

1;# return true:

=pod

=head1 NAME

ASP4x::Linker::Widget - A single item that should be persisted via links.

=head1 SYNOPSIS

lib/ASP4x/Linker/Widget.pm  view on Meta::CPAN

  
  # Change some attributes:
  $widget->set( page_size   => 10 );
  $widget->set( page_number => 4 );
  
  # Get the value of some attributes:
  $widget->get( 'page_size' );    # 10
  $widget->get( 'page_number' );  # 4

  # Make page_number reset to 1 if the page_size is changed:
  $widget->on_change( page_size => sub {
    my $s = shift;
    $s->set( page_number => 1 );
  });
  
  $widget->set( page_size => 20 );
  print $widget->get( 'page_number' );  # 1
  
  # Set multiple values at once:
  $widget->set( %args );
  

lib/ASP4x/Linker/Widget.pm  view on Meta::CPAN

=head2 set( $attr => $value )

Changes the value of an attribute to a new value.

B<NOTE:> As of version , attempts to apply a value to a non-existant attribute will result in a runtime exception.

=head2 get( $attr )

Returns the current value of the attribute.

=head2 on_change( $attr => sub { ... } )

Adds a trigger to the widget that will be called when the given attribute's value is changed via C<set()>.

=head2 uri()

Just a wrapper around the widget's parent C<ASP4x::Linker> object.

=head1 SEE ALSO

L<ASP4x::Linker>

t/010-basic/060-widget-triggers.t  view on Meta::CPAN

my $linker = ASP4x::Linker->new();

my $widget = $linker->add_widget(
  name  => 'artists',
  attrs => [qw( page_number page_size )]
);

ok( $widget, "Got widget" );

# Reset the page number to '1' when the page size is updated:
$widget->on_change( page_size => sub {
  my $s = shift;
  $s->set( page_number => 1 );
});

is( $linker->uri => '/?artists.page_number=4&artists.page_size=10' );
$widget->set( page_size => 20 );
is( $linker->uri => '/?artists.page_number=1&artists.page_size=20' );