Commits

Burak Gürsoy  committed 25e9b11

init

  • Participants

Comments (0)

Files changed (8)

+use strict;
+use warnings;
+use lib qw( builder );
+use Build;
+
+my $mb = Build->new;
+$mb->change_versions(1);
+$mb->copyright_first_year( '2011' );
+$mb->add_pod_author_copyright_license(1);
+$mb->create_build_script;
+
+1;
+Revision history for Perl extension Module::Locate::Insensitive
+
+0.10 Wed Jan 26 01:52:33 2011
+    => First release.
+lib/Module/Locate/Insensitive.pm
+t/01-basic.t
+Build.PL
+Changes
+MANIFEST
+README
+SPEC
+Module::Locate::Insensitive
+===========================
+
+Insensitive module locator.
+
+Read the module's POD for documentation and examples.
+
+INSTALLATION
+
+To install this module type the following:
+
+   perl Makefile.PL
+   make
+   make test
+   make install
+
+or under Windows:
+
+   perl Makefile.PL
+   nmake
+   nmake test
+   nmake install
+
+DEPENDENCIES
+
+Test::More is needed for running distro tests.
+
+COPYRIGHT
+
+Copyright (c) 2011 Burak G�rsoy. All rights reserved.
+
+LICENSE
+
+This library is free software; you can redistribute it and/or modify 
+it under the same terms as Perl itself, either Perl version 5.12.1 or, 
+at your option, any later version of Perl 5 you may have available.
+{
+    module_name => 'Module::Locate::Insensitive',
+    requires    => {
+        ( $] < 5.006 ? ( 'warnings::compat'  => 0 ) : () ),
+    },
+    meta_merge  => {
+        resources => {
+            repository => 'https://bitbucket.org/burak/cpan-module-locate-insensitive',
+        },
+    },
+}

File lib/Module/Locate/Insensitive.pm

+package Module::Locate::Insensitive;
+use strict;
+use warnings;
+use vars qw( $VERSION @EXPORT );
+use subs qw( locate_module insensitive );
+use base qw( Exporter );
+
+$VERSION = '0.10';
+
+##no critic (RegularExpressions::ProhibitEnumeratedClasses)
+use constant RE_NONALPHA => qr{([^a-zA-Z0-9_])}xms;
+use constant RE_ROUTE => qr{
+    (?:
+        [:]{2} # Foo::Bar
+        |
+        \-     # Foo-Bar
+        |
+        [']    # Foo'Bar
+    )
+}xms;
+
+use Carp qw( croak );
+use File::Spec;
+
+BEGIN {
+    *_DEBUG = sub () { 0 } if ! defined &_DEBUG;
+}
+
+@EXPORT = qw( locate );
+
+sub locate {
+    my $name   = shift || croak q{You didn't specify any module name to search};
+    my @routes = split RE_ROUTE, $name;
+
+    _check_bogus_route( $name, \@routes );
+
+    my $pm      = pop(@routes) . '.pm';
+    my $i       = 0;
+    my %correct = map { $_ => [ $i++, $_ ] } @routes, $pm;
+    my @inc     = _filter_inc();
+    my @files;
+
+    foreach my $path ( map { _inc( $_, \@routes, \%correct ) } @inc ) {
+        my $ok = _has_file( $path, $pm );
+        next if ! $ok;
+        $correct{ $pm }[1] = $ok;
+        push @files, File::Spec->catfile( $path, $ok );
+    }
+
+    return if ! @files;
+
+    my $correction = join q{::},
+                            map  { $correct{ $_ }->[1] }
+                            sort { $correct{ $a }->[0] <=> $correct{ $b }->[0] }
+                            keys %correct;
+    $correction =~ s{[.]pm\z}{}xms;
+
+    return wantarray ? ( $correction, @files ) : $correction;
+}
+
+sub _filter_inc {
+    my @dirs;
+    foreach my $path ( @INC ) {
+        next if ref $path;
+        if ( ! -d $path ) {
+            warn "Bogus \@INC directory $path. Skipping...\n" if _DEBUG;
+            next;
+        }
+        push @dirs, $path;
+    }
+    return @dirs;
+}
+
+sub _inc {
+    my($inc, $routes, $correct) = @_;
+    my $base    = $inc;
+    my $counter = 0;
+    foreach my $r ( @{ $routes } ) {
+        my $ok = _has_dir( $base, $r );
+        last if ! $ok;
+        $base = File::Spec->catfile( $base, $ok );
+        $correct->{ $r }[1] = $ok;
+        $counter++;
+    }
+    return +() if $counter != @{ $routes };
+    return $base;
+}
+
+
+sub _has_dir {
+    my($dir, $name) = @_;
+    return _probe( $dir, $name, 1 );
+}
+
+sub _has_file {
+    my($dir, $name) = @_;
+    return _probe( $dir, $name );
+}
+
+sub _probe {
+    my($dir, $name, $is_dir) = @_;
+    opendir my $DIR, $dir or die "Unable to opendir($dir): $!\n";
+
+    my $found;
+    my $exp = $is_dir ? sub { ! -d File::Spec->catfile( @_ ) }
+                      : sub {   -d File::Spec->catfile( @_ ) }
+                      ;
+
+    PROBE: while ( my $file = readdir $DIR) {
+        next PROBE if $exp->( $dir, $file ) || _is_dot( $file );
+        if ( lc $file eq lc $name ) {
+            $found = $file;
+            last PROBE;
+        }
+    }
+
+    closedir $DIR;
+    return $found;
+}
+
+sub _check_bogus_route {
+    my($name, $routes) = @_;
+
+    foreach my $r ( @{ $routes } ) {
+        if ( $r =~ RE_NONALPHA ) {
+            my $bogus = $1;
+            $bogus =~ s{[(]}{\\(}xmsg;
+            $bogus =~ s{[)]}{\\)}xmsg;
+            die "The module name $name you have specified has an "
+               ."invalid character ($1) in its '$r' part. "
+               ."Please use :: or - to separate namespaces.\n";
+        }
+    }
+
+    return;
+}
+
+sub _is_dot {
+    my $file = shift || return;
+    return $file eq q{.} || $file eq q{..};
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Module::Locate::Insensitive - Insensitive module locator
+
+=head1 SYNOPSIS
+
+    use Module::Locate::Insensitive;
+    my($corrected, @file_paths) = locate('cgi');
+    if ( $corrected ) {
+        # load($corrected) or read_file($_) for @file_paths or do something else
+    }
+
+=head1 DESCRIPTION
+
+Tries to locate the module specified insensitively.
+
+=head1 METHODS
+
+=head2 locate STRING
+
+Uses C<STRING> to probe C<@INC> directories. C<STRING> can be an alphanumeric
+string or strings combined with single quotes or dashes as in:
+
+    foo
+    FoO
+    fOO
+    Foo
+    Foo'Bar
+    Foo-Bar
+    Foo'Bar'Baz
+    Foo-Bar-Baz
+    foO-BAR-baz
+
+If successful, returns the corrected package name followed by the list of
+file paths it found.
+
+=head1 SEE ALSO
+
+L<Module::Locate>, L<Module::Require>.
+
+=cut

File lib/insensitive.pm

+## no critic (NamingConventions::Capitalization)
+package insensitive;
+use strict;
+use warnings;
+use vars qw( $VERSION );
+use Module::Locate::Insensitive;
+use Carp qw( croak );
+use Scalar::Util qw( looks_like_number );
+
+$VERSION = '0.10';
+
+my %LOADED;
+
+sub import {
+    my($class, @args) = @_;
+    my $target = shift @args;
+    my $caller = caller;
+
+    if ( ! $LOADED{ $target } ) {
+        my $fixed = insensitive( $target );
+        croak "Can't locate $target in \@INC (\@INC contains @INC)" if ! $fixed;
+        ALIAS: {
+            no strict qw( refs );
+            (my $no_dash = $target) =~ s{[\-']}{::}xmsg;
+            *{ $no_dash . q{::} } = \*{ $fixed . q{::} };
+        };
+        my $eok = eval qq( require $fixed; 1; ) or croak "Can't load $fixed $@";
+        $LOADED{ $target } = $LOADED{ $fixed } = $fixed;
+    }
+
+    $class->_importer( $LOADED{ $target }, $caller, \@args ) if @args;
+
+    return;
+}
+
+sub _importer {
+    my($class, $module, $caller, $args) = @_;
+    my $number = looks_like_number( $args->[0] ) ? shift @{ $args } : q{};
+    require Data::Dumper;
+    my $d = Data::Dumper->new([$args],['*args']);
+    $d->Indent(0);
+    (my $param = $d->Dump) =~ s{ \A \@args \s+? = }{}xms;
+    my $export = <<"MAGIC";
+        package $caller;
+        use $module $number;
+        use $module $param;
+        1;
+MAGIC
+    my $ok = eval $export;
+    croak $@ || q{Unknown error} if ! $ok;
+    return;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+insensitive - Insensitive module loading
+
+=cut

File t/01-basic.t

+use strict;
+use warnings;
+use utf8;
+use Test::More qw( no_plan );
+
+use Module::Locate::Insensitive;
+
+ok( my @response = locate('cgi'), 'Got data');
+ok( @response >= 2, 'Got corrected name and path');
+
+ok( my $cgi         = locate(q{cgi}),        'Got the module name');
+ok( my $cgi_cookie1 = locate(q{cgi'cookie}), 'Got the quoted module name');
+ok( my $cgi_cookie2 = locate(q{cgi-cookie}), 'Got the dashed module name');
+
+is( $cgi, 'CGI', 'Corrected as CGI');
+is( $cgi_cookie1, 'CGI::Cookie', 'Corrected as CGI::Cookie (1)');
+is( $cgi_cookie2, 'CGI::Cookie', 'Corrected as CGI::Cookie (2)');
+
+1;
+
+__END__