From: Jay Kuri Date: Sun, 26 Jul 2009 18:02:57 +0000 (-0600) Subject: Initial commit of Catalyst::Authentication::Realm::Adaptor X-Git-Tag: 0.02~11 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FCatalyst-Authentication-Realm-Adaptor.git;a=commitdiff_plain;h=c6a2d572d24523a391e1bbdc608414bab834fa6c Initial commit of Catalyst::Authentication::Realm::Adaptor --- c6a2d572d24523a391e1bbdc608414bab834fa6c diff --git a/.cvsignore b/.cvsignore new file mode 100644 index 0000000..40f7b87 --- /dev/null +++ b/.cvsignore @@ -0,0 +1,10 @@ +blib* +Makefile +Makefile.old +Build +_build* +pm_to_blib* +*.tar.gz +.lwpcookies +Catalyst-Authentication-Realm-Adaptor-* +cover_db diff --git a/Changes b/Changes new file mode 100644 index 0000000..9e92a1f --- /dev/null +++ b/Changes @@ -0,0 +1,5 @@ +Revision history for Catalyst-Authentication-Realm-Adaptor + +0.01 Date/time + First version, released on an unsuspecting world. + diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..00074a7 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,8 @@ +Changes +MANIFEST +Makefile.PL +README +lib/Catalyst/Authentication/Realm/Adaptor.pm +t/00-load.t +t/pod-coverage.t +t/pod.t diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..40d12dc --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,18 @@ +use inc::Module::Install 0.91; + +name 'Catalyst-Authentication-Realm-Adaptor'; +all_from 'lib/Catalyst/Authentication/Realm/Adaptor.pm'; + +perl_version '5.8.1'; + +if( -e 'MANIFEST.SKIP' ) { + system( 'pod2text lib/Catalyst/Authentication/Realm/Adaptor.pm > README'); +} + +requires ( + 'Catalyst::Runtime' => 0, + 'Catalyst::Plugin::Authentication' => 0.10003, + 'Moose' => 0, + ); + +test_requires ('Test::More' => 0.42); diff --git a/README b/README new file mode 100644 index 0000000..76cefc1 --- /dev/null +++ b/README @@ -0,0 +1,52 @@ +Catalyst-Authentication-Realm-Adaptor + +The README is used to introduce the module and provide instructions on +how to install the module, any machine dependencies it may have (for +example C compilers and installed libraries) and any other information +that should be provided before the module is installed. + +A README file is required for CPAN modules since CPAN extracts the README +file from a module distribution so that people browsing the archive +can use it to get an idea of the module's uses. It is usually a good idea +to provide version information here so that people can decide whether +fixes for the module are worth downloading. + + +INSTALLATION + +To install this module, run the following commands: + + perl Makefile.PL + make + make test + make install + +SUPPORT AND DOCUMENTATION + +After installing, you can find documentation for this module with the +perldoc command. + + perldoc Catalyst::Authentication::Realm::Adaptor + +You can also look for information at: + + RT, CPAN's request tracker + http://rt.cpan.org/NoAuth/Bugs.html?Dist=Catalyst-Authentication-Realm-Adaptor + + AnnoCPAN, Annotated CPAN documentation + http://annocpan.org/dist/Catalyst-Authentication-Realm-Adaptor + + CPAN Ratings + http://cpanratings.perl.org/d/Catalyst-Authentication-Realm-Adaptor + + Search CPAN + http://search.cpan.org/dist/Catalyst-Authentication-Realm-Adaptor/ + + +COPYRIGHT AND LICENCE + +Copyright (C) 2009 Jay Kuri + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + diff --git a/inc/Module/Install.pm b/inc/Module/Install.pm new file mode 100644 index 0000000..51eda5d --- /dev/null +++ b/inc/Module/Install.pm @@ -0,0 +1,430 @@ +#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 +# } + +use 5.005; +use strict 'vars'; + +use vars qw{$VERSION $MAIN}; +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.91'; + + # Storage for the pseudo-singleton + $MAIN = undef; + + *inc::Module::Install::VERSION = *VERSION; + @inc::Module::Install::ISA = __PACKAGE__; + +} + + + + + +# 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 ) { + my $s = (stat($0))[9]; + + # If the modification time is only slightly in the future, + # sleep briefly to remove the problem. + my $a = $s - time; + if ( $a > 0 and $a < 5 ) { sleep 5 } + + # Too far in the future, throw an error. + my $t = time; + if ( $s > $t ) { die <<"END_DIE" } + +Your installer $0 has a modification time in the future ($s > $t). + +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 ) { 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 + + + + + +# To save some more typing in Module::Install installers, every... +# use inc::Module::Install +# ...also acts as an implicit use strict. +$^H |= strict::bits(qw(refs subs vars)); + + + + + +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"; + my $method = $1; + if ( uc($method) eq $method ) { + # Do nothing + return; + } elsif ( $method =~ /^_/ and $self->can($method) ) { + # Dispatch to the root M:I class + return $self->$method(@_); + } + + # Dispatch to the appropriate plugin + 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); + 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"}; + + # Save to the singleton + $MAIN = $self; + + return 1; +} + +sub preload { + my $self = shift; + unless ( $self->{extensions} ) { + $self->load_extensions( + "$self->{prefix}/$self->{path}", $self + ); + } + + my @exts = @{$self->{extensions}}; + unless ( @exts ) { + @exts = $self->{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"; + $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); + } + + 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 { ! 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}; + + 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) ) { + my $content = Module::Install::_read($subpath . '.pm'); + my $in_pod = 0; + foreach ( split //, $content ) { + $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; + } + } + } + + push @found, [ $file, $pkg ]; + }, $path ) if -d $path; + + @found; +} + + + + + +##################################################################### +# Common 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; + if ( $] >= 5.006 ) { + open( FH, '<', $_[0] ) or die "open($_[0]): $!"; + } else { + open( FH, "< $_[0]" ) or die "open($_[0]): $!"; + } + my $string = do { local $/; }; + close FH or die "close($_[0]): $!"; + return $string; +} + +sub _readperl { + my $string = Module::Install::_read($_[0]); + $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; + $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; + $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; + return $string; +} + +sub _readpod { + my $string = Module::Install::_read($_[0]); + $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; + return $string if $_[0] =~ /\.pod\z/; + $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; + $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; + $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; + $string =~ s/^\n+//s; + return $string; +} + +sub _write { + local *FH; + if ( $] >= 5.006 ) { + open( FH, '>', $_[0] ) or die "open($_[0]): $!"; + } else { + 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; + my $d =()= $s =~ /(\.)/g; + if ( $d >= 2 ) { + # Normalise multipart versions + $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; + } + $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; +} + +sub _cmp ($$) { + _version($_[0]) <=> _version($_[1]); +} + +# Cloned from Params::Util::_CLASS +sub _CLASS ($) { + ( + defined $_[0] + and + ! ref $_[0] + and + $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s + ) ? $_[0] : undef; +} + +1; + +# Copyright 2008 - 2009 Adam Kennedy. diff --git a/inc/Module/Install/Base.pm b/inc/Module/Install/Base.pm new file mode 100644 index 0000000..60a74d2 --- /dev/null +++ b/inc/Module/Install/Base.pm @@ -0,0 +1,78 @@ +#line 1 +package Module::Install::Base; + +use strict 'vars'; +use vars qw{$VERSION}; +BEGIN { + $VERSION = '0.91'; +} + +# Suspend handler for "redefined" warnings +BEGIN { + my $w = $SIG{__WARN__}; + $SIG{__WARN__} = sub { $w }; +} + +#line 42 + +sub new { + my $class = shift; + unless ( defined &{"${class}::call"} ) { + *{"${class}::call"} = sub { shift->_top->call(@_) }; + } + unless ( defined &{"${class}::load"} ) { + *{"${class}::load"} = sub { shift->_top->load(@_) }; + } + bless { @_ }, $class; +} + +#line 61 + +sub AUTOLOAD { + local $@; + my $func = eval { shift->_top->autoload } or return; + goto &$func; +} + +#line 75 + +sub _top { + $_[0]->{_top}; +} + +#line 90 + +sub admin { + $_[0]->_top->{admin} + or + Module::Install::Base::FakeAdmin->new; +} + +#line 106 + +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 154 diff --git a/inc/Module/Install/Metadata.pm b/inc/Module/Install/Metadata.pm new file mode 100644 index 0000000..653193d --- /dev/null +++ b/inc/Module/Install/Metadata.pm @@ -0,0 +1,624 @@ +#line 1 +package Module::Install::Metadata; + +use strict 'vars'; +use Module::Install::Base (); + +use vars qw{$VERSION @ISA $ISCORE}; +BEGIN { + $VERSION = '0.91'; + @ISA = 'Module::Install::Base'; + $ISCORE = 1; +} + +my @boolean_keys = qw{ + sign +}; + +my @scalar_keys = qw{ + name + module_name + abstract + author + version + distribution_type + tests + installdirs +}; + +my @tuple_keys = qw{ + configure_requires + build_requires + requires + recommends + bundles + resources +}; + +my @resource_keys = qw{ + homepage + bugtracker + repository +}; + +my @array_keys = qw{ + keywords +}; + +sub Meta { shift } +sub Meta_BooleanKeys { @boolean_keys } +sub Meta_ScalarKeys { @scalar_keys } +sub Meta_TupleKeys { @tuple_keys } +sub Meta_ResourceKeys { @resource_keys } +sub Meta_ArrayKeys { @array_keys } + +foreach my $key ( @boolean_keys ) { + *$key = sub { + my $self = shift; + if ( defined wantarray and not @_ ) { + return $self->{values}->{$key}; + } + $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); + return $self; + }; +} + +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 ( @array_keys ) { + *$key = sub { + my $self = shift; + return $self->{values}->{$key} if defined wantarray and !@_; + $self->{values}->{$key} ||= []; + push @{$self->{values}->{$key}}, @_; + 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; + }; +} + +foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { + *$key = sub { + my $self = shift; + return $self->{values}->{$key} unless @_; + my @added; + while ( @_ ) { + my $module = shift or last; + my $version = shift || 0; + push @added, [ $module, $version ]; + } + push @{ $self->{values}->{$key} }, @added; + return map {@$_} @added; + }; +} + +# 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 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; +} + +#Stolen from M::B +my %license_urls = ( + perl => 'http://dev.perl.org/licenses/', + apache => 'http://apache.org/licenses/LICENSE-2.0', + artistic => 'http://opensource.org/licenses/artistic-license.php', + artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', + lgpl => 'http://opensource.org/licenses/lgpl-license.php', + lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', + lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', + bsd => 'http://opensource.org/licenses/bsd-license.php', + gpl => 'http://opensource.org/licenses/gpl-license.php', + gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', + gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', + mit => 'http://opensource.org/licenses/mit-license.php', + mozilla => 'http://opensource.org/licenses/mozilla1.1.php', + open_source => undef, + unrestricted => undef, + restrictive => undef, + unknown => undef, +); + +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_urls{$license} ) { + $self->resources( license => $license_urls{$license} ); + } + + 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"); + } + } + unless ( -f $file ) { + die("The path '$file' does not exist, or is not a file"); + } + + # Some methods pull from POD instead of code. + # If there is a matching .pod, use that instead + my $pod = $file; + $pod =~ s/\.pm$/.pod/i; + $pod = $file unless -e $pod; + + # Pull the different values + $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 { + $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::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}{<}g; + $author =~ s{E}{>}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 + /ixms ) { + my $license_text = $1; + my @phrases = ( + 'under the same (?:terms|license) as (?:perl|the perl programming language) itself' => 'perl', 1, + 'GNU general public license' => 'gpl', 1, + 'GNU public license' => 'gpl', 1, + 'GNU lesser general public license' => 'lgpl', 1, + 'GNU lesser public license' => 'lgpl', 1, + 'GNU library general public license' => 'lgpl', 1, + 'GNU library 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 ) { + $self->license($license); + return 1; + } + } + } + + warn "Cannot determine license info from $_[0]\n"; + return 'unknown'; +} + +sub _extract_bugtracker { + my @links = $_[0] =~ m#L<(\Qhttp://rt.cpan.org/\E[^>]+)>#g; + my %links; + @links{@links}=(); + @links=keys %links; + return @links; +} + +sub bugtracker_from { + my $self = shift; + my $content = Module::Install::_read($_[0]); + my @links = _extract_bugtracker($content); + 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; +} + +sub requires_from { + my $self = shift; + my $content = Module::Install::_readperl($_[0]); + my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; + while ( @requires ) { + my $module = shift @requires; + my $version = shift @requires; + $self->requires( $module => $version ); + } +} + +sub test_requires_from { + my $self = shift; + my $content = Module::Install::_readperl($_[0]); + my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; + while ( @requires ) { + my $module = shift @requires; + my $version = shift @requires; + $self->test_requires( $module => $version ); + } +} + +# 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) ) { + # Numify + $v = $v + 0; + } + return $v; +} + + + + + +###################################################################### +# MYMETA Support + +sub WriteMyMeta { + die "WriteMyMeta has been deprecated"; +} + +sub write_mymeta_yaml { + my $self = shift; + + # We need YAML::Tiny to write the MYMETA.yml file + unless ( eval { require YAML::Tiny; 1; } ) { + return 1; + } + + # Generate the data + my $meta = $self->_write_mymeta_data or return 1; + + # Save as the MYMETA.yml file + print "Writing MYMETA.yml\n"; + YAML::Tiny::DumpFile('MYMETA.yml', $meta); +} + +sub write_mymeta_json { + my $self = shift; + + # We need JSON to write the MYMETA.json file + unless ( eval { require JSON; 1; } ) { + return 1; + } + + # Generate the data + my $meta = $self->_write_mymeta_data or return 1; + + # Save as the MYMETA.yml file + print "Writing MYMETA.json\n"; + Module::Install::_write( + 'MYMETA.json', + JSON->new->pretty(1)->canonical->encode($meta), + ); +} + +sub _write_mymeta_data { + my $self = shift; + + # If there's no existing META.yml there is nothing we can do + return undef unless -f 'META.yml'; + + # We need Parse::CPAN::Meta to load the file + unless ( eval { require Parse::CPAN::Meta; 1; } ) { + return undef; + } + + # Merge the perl version into the dependencies + my $val = $self->Meta->{values}; + my $perl = delete $val->{perl_version}; + if ( $perl ) { + $val->{requires} ||= []; + my $requires = $val->{requires}; + + # Canonize to three-dot version after Perl 5.6 + if ( $perl >= 5.006 ) { + $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e + } + unshift @$requires, [ perl => $perl ]; + } + + # Load the advisory META.yml file + my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); + my $meta = $yaml[0]; + + # Overwrite the non-configure dependency hashs + delete $meta->{requires}; + delete $meta->{build_requires}; + delete $meta->{recommends}; + if ( exists $val->{requires} ) { + $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; + } + if ( exists $val->{build_requires} ) { + $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; + } + + return $meta; +} + +1; diff --git a/lib/Catalyst/Authentication/Realm/Adaptor.pm b/lib/Catalyst/Authentication/Realm/Adaptor.pm new file mode 100644 index 0000000..bf01894 --- /dev/null +++ b/lib/Catalyst/Authentication/Realm/Adaptor.pm @@ -0,0 +1,483 @@ +package Catalyst::Authentication::Realm::Adaptor; + +use warnings; +use strict; +use Carp; +use Moose; +extends 'Catalyst::Authentication::Realm'; + +=head1 NAME + +Catalyst::Authentication::Realm::Adaptor - Adjust parameters of authentication processes on the fly + +=head1 VERSION + +Version 0.01 + +=cut + +## goes in catagits@jules.scsys.co.uk:Catalyst-Authentication-Realm-Adaptor.git + +our $VERSION = '0.01'; + +sub authenticate { + my ( $self, $c, $authinfo ) = @_; + + my $newauthinfo; + + if (exists($self->config->{'credential_adaptor'})) { + + if ($self->config->{'credential_adaptor'}{'method'} eq 'merge_hash') { + + $newauthinfo = _munge_hash($authinfo, $self->config->{'credential_adaptor'}{'merge_hash'}, $authinfo); + + } elsif ($self->config->{'credential_adaptor'}{'method'} eq 'new_hash') { + + $newauthinfo = _munge_hash({}, $self->config->{'credential_adaptor'}{'new_hash'}, $authinfo); + + } elsif ($self->config->{'credential_adaptor'}{'method'} eq 'action') { + + my $controller = $c->controller($self->config->{'credential_adaptor'}{'controller'}); + if (!$controller) { + Catalyst::Exception->throw(__PACKAGE__ . " realm: " . $self->name . "'s credential_adaptor tried to use a controller that doesn't exist: " . + $self->config->{'credential_adaptor'}{'controller'}); + } + + my $action = $controller->action_for($self->config->{'credential_adaptor'}{'action'}); + if (!$action) { + Catalyst::Exception->throw(__PACKAGE__ . " realm: " . $self->name . "'s credential_adaptor tried to use an action that doesn't exist: " . + $self->config->{'credential_adaptor'}{'controller'} . "->" . + $self->config->{'credential_adaptor'}{'action'}); + } + $newauthinfo = $c->forward($action, $self->name, $authinfo, $self->config->{'credential_adaptor'}); + + } elsif ($self->config->{'credential_adaptor'}{'method'} eq 'code' ) { + + if (ref($self->config->{'credential_adaptor'}{'code'}) eq 'CODE') { + my $sub = $self->config->{'credential_adaptor'}{'code'}; + $newauthinfo = $sub->($self->name, $authinfo, $self->config->{'credential_adaptor'}); + } else { + Catalyst::Exception->throw(__PACKAGE__ . " realm: " . $self->name . "'s credential_adaptor is configured to use a code ref that doesn't exist"); + } + } + return $self->SUPER::authenticate($c, $newauthinfo); + } else { + return $self->SUPER::authenticate($c, $authinfo); + } +} + +sub find_user { + my ( $self, $authinfo, $c ) = @_; + + my $newauthinfo; + + if (exists($self->config->{'store_adaptor'})) { + + if ($self->config->{'store_adaptor'}{'method'} eq 'merge_hash') { + + $newauthinfo = _munge_hash($authinfo, $self->config->{'store_adaptor'}{'merge_hash'}, $authinfo); + + } elsif ($self->config->{'store_adaptor'}{'method'} eq 'new_hash') { + + $newauthinfo = _munge_hash({}, $self->config->{'store_adaptor'}{'new_hash'}, $authinfo); + + } elsif ($self->config->{'store_adaptor'}{'method'} eq 'action') { + + my $controller = $c->controller($self->config->{'store_adaptor'}{'controller'}); + if (!$controller) { + Catalyst::Exception->throw(__PACKAGE__ . " realm: " . $self->name . "'s store_adaptor tried to use a controller that doesn't exist: " . + $self->config->{'store_adaptor'}{'controller'}); + } + + my $action = $controller->action_for($self->config->{'store_adaptor'}{'action'}); + if (!$action) { + Catalyst::Exception->throw(__PACKAGE__ . " realm: " . $self->name . "'s store_adaptor tried to use an action that doesn't exist: " . + $self->config->{'store_adaptor'}{'controller'} . "->" . + $self->config->{'store_adaptor'}{'action'}); + } + $newauthinfo = $c->forward($action, $self->name, $authinfo, $self->config->{'store_adaptor'}); + + } elsif ($self->config->{'store_adaptor'}{'method'} eq 'code' ) { + + if (ref($self->config->{'store_adaptor'}{'code'}) eq 'CODE') { + my $sub = $self->config->{'store_adaptor'}{'code'}; + $newauthinfo = $sub->($self->name, $authinfo, $self->config->{'store_adaptor'}); + } else { + Catalyst::Exception->throw(__PACKAGE__ . " realm: " . $self->name . "'s store_adaptor is configured to use a code ref that doesn't exist"); + } + } + return $self->SUPER::authenticate($c, $newauthinfo); + } else { + return $self->SUPER::authenticate($c, $authinfo); + } +} + +sub _munge_hash { + my ($sourcehash, $modhash, $referencehash) = @_; + + my $resulthash = { %{$sourcehash} }; + + foreach my $key (keys %{$modhash}) { + if (ref($modhash->{$key}) eq 'HASH') { + if (ref($sourcehash->{$key}) eq 'HASH') { + $resulthash->{$key} = _munge_hash($sourcehash->{$key}, $modhash->{$key}, $referencehash) + } else { + $resulthash->{$key} = _munge_hash({}, $modhash->{$key}, $referencehash); + } + } else { + if (ref($modhash->{$key} eq 'ARRAY') && ref($sourcehash->{$key}) eq 'ARRAY') { + push @{$resulthash->{$key}}, _munge_value($modhash->{$key}, $referencehash) + } + $resulthash->{$key} = _munge_value($modhash->{$key}, $referencehash); + if (ref($resulthash->{$key}) eq 'SCALAR' && ${$resulthash->{$key}} eq '-') { + ## Scalar reference to a string '-' means delete the element from the source array. + delete($resulthash->{$key}); + } + } + } + return($resulthash); +} + +sub _munge_value { + my ($modvalue, $referencehash) = @_; + + my $newvalue; + if ($modvalue =~ m/^([+-])\((.*)\)$/) { + my $action = $1; + my $keypath = $2; + ## do magic + if ($action eq '+') { + ## action = string '-' means delete the element from the source array. + ## otherwise it means copy it from a field in the original hash with nesting + ## indicated via '.' - IE similar to Template Toolkit handling of nested hashes + my @hashpath = split /\./, $keypath; + my $val = $referencehash; + foreach my $subkey (@hashpath) { + if (ref($val) eq 'HASH') { + $val = $val->{$subkey}; + } elsif (ref($val) eq 'ARRAY') { + $val = $val->[$subkey]; + } else { + ## failed to find that key in the hash / array + $val = undef; + last; + } + } + $newvalue = $val; + } else { + ## delete the value... so we return a scalar ref to '-' + $newvalue = \'-'; + } + } elsif (ref($modvalue) eq 'ARRAY') { + $newvalue = []; + foreach my $row (0..$#{$modvalue}) { + if (defined($modvalue->[$row])) { + my $val = _munge_value($modvalue->[$row], $referencehash); + ## this is the first time I've ever wanted to use unless + ## to make things clearer + unless (ref($val) eq 'SCALAR' && ${$val} eq '-') { + $newvalue->[$row] = $val; + } + } + } + } else { + $newvalue = $modvalue; + } + return $newvalue; +} + + +=head1 SYNOPSIS + +The Catalyst::Authentication::Realm::Adaptor allows for modification of +authentication parameters within the catalyst application. It's basically a +filter used to adjust authentication parameters globally within the +application or to adjust user retrieval parameters provided by the credential +in order to be compatible with a different store. It provides for better +control over interaction between credentials and stores. This is particularly +useful when working with external authentication such as OpenID or OAuth. + + __PACKAGE__->config( + 'Plugin::Authentication' => { + 'default' => { + class => 'Adaptor' + credential => { + class => 'Password', + password_field => 'secret', + password_type => 'hashed', + password_hash_type => 'SHA-1', + }, + store => { + class => 'DBIx::Class', + user_class => 'Schema::Person', + }, + store_adaptor => { + method => 'merge_hash', + merge_hash => { + status => [ 'temporary', 'active' ] + } + } + }, + } + } + ); + + +The above example ensures that no matter how $c->authenticate() is called +within your application, the key 'status' is added to the authentication hash. +This allows you to, among other things, set parameters that should always be +applied to your authentication process or modify the parameters to better +connect a credential and a store that were not built to work together. In the +above example, we are making sure that the user search is restricted to those +with a status of either 'temporary' or 'active.' + +This realm works by intercepting the original authentication information +between the time C<< $c->authenticate($authinfo) >> is called and the time the +realm's C<$realm->authenticate($c,$authinfo)> method is called, allowing for +the $authinfo parameter to be modified or replaced as your application +requires. It can also operate after the call to the credential's +C method but before the call to the store's C +method. + +If you don't know what the above means, you probably do not need this module. + +=head1 CONFIGURATION + +The configuration for this module goes within your realm configuration alongside your +credential and store options. + +This module can operate in two points during authentication processing. +The first is prior the realm's C call (immediately after the call to +C<<$c->authenticate()>>.) To operate here, your filter options should go in a hash +under the key C. + +The second point is after the call to credential's C method but +immediately before the call to the user store's C method. To operate +prior to C, your filter options should go in a hash under the key +C. + +The filtering options for both points are the same, and both the C and +C can be used simultaneously in a single realm. + +=head2 method + +There are four ways to configure your filters. You specify which one you want by setting +the C configuration option to one of the following: C, C, +C, or C. You then provide the additional information based on which method +you have chosen. The different options are described below. + +=over 8 + +=item merge_hash + + credential_adaptor => { + method => 'merge_hash', + merge_hash => { + status => [ 'temporary', 'active' ] + } + } + +This causes the original authinfo hash to be merged with a hash provided by +the realm configuration under the key C key. This is a deep merge +and in the case of a conflict, the hash specified by merge_hash takes +precedence over what was passed into the authenticate or find_user call. The +method of merging is described in detail in the L section below. + +=item new_hash + + store_adaptor => { + method => 'new_hash', + new_hash => { + username => '+(user)', # this sets username to the value of $originalhash{user} + user_source => 'openid' + } + } + +This causes the original authinfo hash to be set aside and replaced with a new hash provided under the +C key. The new hash can grab portions of the original hash. This can be used to remap the authinfo +into a new format. See the L section for information on how to do this. + +=item code + + store_adaptor => { + method => 'code', + code => sub { + my ($realmname, $original_authinfo, $hashref_to_config ) = @_; + my $newauthinfo = {}; + ## do something + return $newauthinfo; + } + } + +The C method allows for more complex filtering by executing code +provided as a subroutine reference in the C key. The realm name, +original auth info and the portion of the config specific to this filter are +passed as arguments to the provided subroutine. In the above example, it would +be the entire store_adaptor hash. If you were using a code ref in a +credential_adaptor, you'd get the credential_adapter config instead. + +=item action + + credential_adaptor => { + method => 'action', + controller => 'UserProcessing', + action => 'FilterCredentials' + } + +The C method causes the adaptor to delegate filtering to a Catalyst +action. This is similar to the code ref above, except that instead of simply +calling the routine, the action specified is called via C<<$c->forward>>. The +arguments passed to the action are the same as the code method as well, +namely the realm name, the original authinfo hash and the config for the adaptor. + +=back + +=head1 HASH MERGING + +The hash merging mechanism in Catalyst::Authentication::Realm::Adaptor is not +a simple merge of two hashes. It has some niceties which allow for both +re-mapping of existing keys, and a mechanism for removing keys from the +original hash. When using the 'merge_hash' method above, the keys from the +original hash and the keys for the merge hash are simply combined with the +merge_hash taking precedence in the case of a key conflict. If there are +sub-hashes they are merged as well. + +If both the source and merge hash contain an array for a given hash-key, the +values in the merge array are appended to the original array. Note that hashes +within arrays will not be merged, and will instead simply be copied. + +Simple values are left intact, and in the case of a key existing in both +hashes, the value from the merge_hash takes precedence. Note that in the case +of a key conflict where the values are of different types, the value from the +merge_hash will be used and no attempt is made to merge or otherwise convert +them. + +=head2 Advanced merging + +Whether you are using C or C as the method, you have access +to the values from the original authinfo hash. In your new or merged hash, you +can use values from anywhere within the original hash. You do this by setting +the value for the key you want to set to a special string indicating the key +path in the original hash. The string is formatted as follows: +C<<'+(key1.key2.key3)'>> This will grab the hash associated with key1, retrieve the hash +associated with key2, and finally obtain the value associated with key3. This is easier to +show than to explain: + + my $originalhash = { + user => { + details => { + age => 27, + haircolor => 'black', + favoritenumbers => [ 17, 42, 19 ] + } + } + }; + + my $newhash = { + # would result in a value of 'black' + haircolor => '+(user.details.haircolor)', + + # bestnumber would be 42. + bestnumber => '+(user.details.favoritenumbers.1)' + } + +Given the example above, the value for the userage key would be 27, (obtained +via C<<'+(user.details.age)'>>) and the value for bestnumber would be 42. Note +that you can traverse both hashes and arrays using this method. This can be +quite useful when you need the values that were passed in, but you need to put +them under different keys. + +When using the C method, you sometimes may want to remove an item +from the original hash. You can do this by providing a key in your merge_hash +at the same point, but setting it's value to '-()'. This will remove the key +entirely from the resultant hash. This works better than simply setting the +value to undef in some cases. + +=head1 NOTES and CAVEATS + +The authentication system for Catalyst is quite flexible. In most cases this +module is not needed. Evidence of this fact is that the Catalyst auth system +was substantially unchanged for 2+ years prior to this modules first release. +If you are looking at this module, then there is a good chance your problem would +be better solved by adjusting your credential or store directly. + +That said, there are some areas where this module can be particularly useful. +For example, this module allows for global application of additional arguments +to authinfo for a certain realm via your config. It also allows for preliminary +testing of alternate configs before you adjust every C<<$c->authenticate()>> call +within your application. + +It is also useful when combined with the various external authentication +modules available, such as OpenID, OAuth or Facebook. These modules expect to +store their user information in the Hash provided by the Minimal user store. +Often, however, you want to store user information locally in a database or +other storage mechanism. Doing this lies somewhere between difficult and +impossible normally. With the Adapter realm, you can massage the authinfo hash +between the credential's verification and the creation of the local user, and +instead use the information returned to look up a user instead. + +Using the external auth mechanisms and the C method, you can actually +trigger an action to create a user record on the fly when the user has +authenticated via an external method. These are just some of the possibilities +that Adaptor provides that would otherwise be very difficult to accomplish, +even with Catalyst's flexible authentication system. + +With all of that said, caution is warranted when using this module. It modifies +the behavior of the application in ways that are not obvious and can therefore +lead to extremely hard to track-down bugs. This is especially true when using +the C filter method. When a developer calls C<<$c->authenticate()>> +they are not expecting any actions to be called before it returns. + +If you use the C method, I strongly recommend that you use it only as a +filter routine and do not do other catalyst dispatch related activities (such as +further forwards, detach's or redirects). Also note that it is B to call authentication routines from within a filter action. It is +extremely easy to accidentally create an infinite recursion bug which can crash +your Application. In short - B. + +=head1 AUTHOR + +Jay Kuri, C<< >> + +=head1 BUGS + +Please report any bugs or feature requests to C, or through +the web interface at L. I will be notified, and then you'll +automatically be notified of progress on your bug as I make changes. + + +=head1 SUPPORT + +You can find documentation for this module with the perldoc command. + + perldoc Catalyst::Authentication::Realm::Adaptor + +You can also look for information at: + +=over 4 + +=item * Search CPAN + +L + +=item * Catalyzed.org Wiki + +L + +=back + + +=head1 ACKNOWLEDGEMENTS + + +=head1 COPYRIGHT & LICENSE + +Copyright 2009 Jay Kuri, all rights reserved. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + + +=cut + +1; # End of Catalyst::Authentication::Realm::Adaptor diff --git a/t/00-load.t b/t/00-load.t new file mode 100644 index 0000000..c9e0789 --- /dev/null +++ b/t/00-load.t @@ -0,0 +1,9 @@ +#!perl -T + +use Test::More tests => 1; + +BEGIN { + use_ok( 'Catalyst::Authentication::Realm::Adaptor' ); +} + +diag( "Testing Catalyst::Authentication::Realm::Adaptor $Catalyst::Authentication::Realm::Adaptor::VERSION, Perl $], $^X" ); diff --git a/t/boilerplate.t b/t/boilerplate.t new file mode 100644 index 0000000..279dc60 --- /dev/null +++ b/t/boilerplate.t @@ -0,0 +1,55 @@ +#!perl -T + +use strict; +use warnings; +use Test::More tests => 3; + +sub not_in_file_ok { + my ($filename, %regex) = @_; + open( my $fh, '<', $filename ) + or die "couldn't open $filename for reading: $!"; + + my %violated; + + while (my $line = <$fh>) { + while (my ($desc, $regex) = each %regex) { + if ($line =~ $regex) { + push @{$violated{$desc}||=[]}, $.; + } + } + } + + if (%violated) { + fail("$filename contains boilerplate text"); + diag "$_ appears on lines @{$violated{$_}}" for keys %violated; + } else { + pass("$filename contains no boilerplate text"); + } +} + +sub module_boilerplate_ok { + my ($module) = @_; + not_in_file_ok($module => + 'the great new $MODULENAME' => qr/ - The great new /, + 'boilerplate description' => qr/Quick summary of what the module/, + 'stub function definition' => qr/function[12]/, + ); +} + +TODO: { + local $TODO = "Need to replace the boilerplate text"; + + not_in_file_ok(README => + "The README is used..." => qr/The README is used/, + "'version information here'" => qr/to provide version information/, + ); + + not_in_file_ok(Changes => + "placeholder date/time" => qr(Date/time) + ); + + module_boilerplate_ok('lib/Catalyst/Authentication/Realm/Adaptor.pm'); + + +} + diff --git a/t/pod-coverage.t b/t/pod-coverage.t new file mode 100644 index 0000000..fc40a57 --- /dev/null +++ b/t/pod-coverage.t @@ -0,0 +1,18 @@ +use strict; +use warnings; +use Test::More; + +# Ensure a recent version of Test::Pod::Coverage +my $min_tpc = 1.08; +eval "use Test::Pod::Coverage $min_tpc"; +plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage" + if $@; + +# Test::Pod::Coverage doesn't require a minimum Pod::Coverage version, +# but older versions don't recognize some common documentation styles +my $min_pc = 0.18; +eval "use Pod::Coverage $min_pc"; +plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" + if $@; + +all_pod_coverage_ok(); diff --git a/t/pod.t b/t/pod.t new file mode 100644 index 0000000..ee8b18a --- /dev/null +++ b/t/pod.t @@ -0,0 +1,12 @@ +#!perl -T + +use strict; +use warnings; +use Test::More; + +# Ensure a recent version of Test::Pod +my $min_tp = 1.22; +eval "use Test::Pod $min_tp"; +plan skip_all => "Test::Pod $min_tp required for testing POD" if $@; + +all_pod_files_ok();