view release on metacpan or  search on metacpan

lib/Catalyst/Utils.pm  view on Meta::CPAN

package Catalyst::Utils;
use strict;
use warnings;

use File::Spec;
use HTTP::Request;
use Path::Class;
use URI;
use Carp qw/croak/;
use Cwd;
use Class::Load 'is_class_loaded';
use String::RewritePrefix;
use Class::Load ();
use namespace::clean;
use Devel::InnerPackage;
use Moose::Util;

=head1 NAME

Catalyst::Utils - The Catalyst Utils

=head1 SYNOPSIS

See L<Catalyst>.

=head1 DESCRIPTION

Catalyst Utilities.

=head1 METHODS

=head2 appprefix($class)

    MyApp::Foo becomes myapp_foo

=cut

sub appprefix {
    my $class = shift;
    $class =~ s/::/_/g;
    $class = lc($class);
    return $class;
}

=head2 class2appclass($class);

    MyApp::Controller::Foo::Bar becomes MyApp
    My::App::Controller::Foo::Bar becomes My::App

=cut

sub class2appclass {
    my $class = shift || '';
    my $appname = '';
    if ( $class =~ /^(.+?)::([MVC]|Model|View|Controller)::.+$/ ) {
        $appname = $1;
    }
    return $appname;
}

=head2 class2classprefix($class);

    MyApp::Controller::Foo::Bar becomes MyApp::Controller
    My::App::Controller::Foo::Bar becomes My::App::Controller

=cut

lib/Catalyst/Utils.pm  view on Meta::CPAN

    if ( my $inc_entry = $INC{$file} ) {
        {
            # look for an uninstalled Catalyst app

            # find the @INC entry in which $file was found
            (my $path = $inc_entry) =~ s/$file$//;
            $path ||= cwd() if !defined $path || !length $path;
            my $home = dir($path)->absolute->cleanup;

            # pop off /lib and /blib if they're there
            $home = $home->parent while $home =~ /b?lib$/;

            # only return the dir if it has a Makefile.PL or Build.PL or dist.ini
            if (grep { -f $home->file($_) } dist_indicator_file_list()) {
                # clean up relative path:
                # MyApp/script/.. -> MyApp

                my $dir;
                my @dir_list = $home->dir_list();
                while (($dir = pop(@dir_list)) && $dir eq '..') {
                    $home = dir($home)->parent->parent;
                }

                return $home->stringify;
            }
        }

        {
            # look for an installed Catalyst app

            # trim the .pm off the thing ( Foo/Bar.pm -> Foo/Bar/ )
            ( my $path = $inc_entry) =~ s/\.pm$//;
            my $home = dir($path)->absolute->cleanup;

            # return if it's a valid directory
            return $home->stringify if -d $home;
        }
    }

    # we found nothing
    return 0;
}

=head2 prefix($class, $name);

Returns a prefixed action.

    MyApp::Controller::Foo::Bar, yada becomes foo/bar/yada

=cut

sub prefix {
    my ( $class, $name ) = @_;
    my $prefix = &class2prefix($class);
    $name = "$prefix/$name" if $prefix;
    return $name;
}

=head2 request($uri)

Returns an L<HTTP::Request> object for a uri.

=cut

sub request {
    my $request = shift;
    unless ( ref $request ) {
        if ( $request =~ m/^http/i ) {
            $request = URI->new($request);
        }
        else {
            $request = URI->new( 'http://localhost' . $request );
        }
    }
    unless ( ref $request eq 'HTTP::Request' ) {
        $request = HTTP::Request->new( 'GET', $request );
    }
    return $request;
}

=head2 ensure_class_loaded($class_name, \%opts)

Loads the class unless it already has been loaded.

If $opts{ignore_loaded} is true always tries the require whether the package
already exists or not. Only pass this if you're either (a) sure you know the
file exists on disk or (b) have code to catch the file not found exception
that will result if it doesn't.

=cut

sub ensure_class_loaded {
    my $class = shift;
    my $opts  = shift;

    croak "Malformed class Name $class"
        if $class =~ m/(?:\b\:\b|\:{3,})/;

    croak "Malformed class Name $class"
        if $class =~ m/[^\w:]/;

    croak "ensure_class_loaded should be given a classname, not a filename ($class)"
        if $class =~ m/\.pm$/;

    # $opts->{ignore_loaded} can be set to true, and this causes the class to be required, even
    # if it already has symbol table entries. This is to support things like Schema::Loader, which
    # part-generate classes in memory, but then also load some of their contents from disk.
    return if !$opts->{ ignore_loaded }
        && is_class_loaded($class); # if a symbol entry exists we don't load again

    # this hack is so we don't overwrite $@ if the load did not generate an error
    my $error;
    {
        local $@;
        my $file = $class . '.pm';
        $file =~ s{::}{/}g;
        eval { CORE::require($file) };
        $error = $@;
    }

    die $error if $error;

    warn "require $class was successful but the package is not defined."
        unless is_class_loaded($class);

    return 1;
}

=head2 merge_hashes($hashref, $hashref)

Base code to recursively merge two hashes together with right-hand precedence.

=cut

sub merge_hashes {
    my ( $lefthash, $righthash ) = @_;