[catagits/Catalyst-Runtime.git] / lib / Catalyst / Utils.pm

package Catalyst::Utils;

use strict;
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

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

=head2 class2classsuffix($class);

    MyApp::Controller::Foo::Bar becomes Controller::Foo::Bar

=cut

sub class2classsuffix {
    my $class = shift || '';
    my $prefix = class2appclass($class) || '';
    $class =~ s/$prefix\:://;
    return $class;
}

=head2 class2env($class);

Returns the environment name for class.

    MyApp becomes MYAPP
    My::App becomes MY_APP

=cut

sub class2env {
    my $class = shift || '';
    $class =~ s/::/_/g;
    return uc($class);
}

=head2 class2prefix( $class, $case );

Returns the uri prefix for a class. If case is false the prefix is converted to lowercase.

    My::App::Controller::Foo::Bar becomes foo/bar

=cut

sub class2prefix {
    my $class = shift || '';
    my $case  = shift || 0;
    my $prefix;
    if ( $class =~ /^.+?::([MVC]|Model|View|Controller)::(.+)$/ ) {
        $prefix = $case ? $2 : lc $2;
        $prefix =~ s{::}{/}g;
    }
    return $prefix;
}

=head2 class2tempdir( $class [, $create ] );

Returns a tempdir for a class. If create is true it will try to create the path.

    My::App becomes /tmp/my/app
    My::App::Controller::Foo::Bar becomes /tmp/my/app/c/foo/bar

=cut

sub class2tempdir {
    my $class  = shift || '';
    my $create = shift || 0;
    my @parts = split '::', lc $class;

    my $tmpdir = dir( File::Spec->tmpdir, @parts )->cleanup;

    if ( $create && !-e $tmpdir ) {

        eval { $tmpdir->mkpath; 1 }
        or do {
            # don't load Catalyst::Exception as a BEGIN in Utils,
            # because Utils often gets loaded before MyApp.pm, and if
            # Catalyst::Exception is loaded before MyApp.pm, it does
            # not honor setting
            # $Catalyst::Exception::CATALYST_EXCEPTION_CLASS in
            # MyApp.pm
            require Catalyst::Exception;
            Catalyst::Exception->throw(
                message => qq/Couldn't create tmpdir '$tmpdir', "$@"/ );
        }
    }

    return $tmpdir->stringify;
}

=head2 home($class)

Returns home directory for given class.

=head2 dist_indicator_file_list

Returns a list of files which can be tested to check if you're inside
a CPAN distribution which is not yet installed.

These are:

=over

=item Makefile.PL

=item Build.PL

=item dist.ini

=item L<cpanfile>

=back

=cut

sub dist_indicator_file_list {
    qw{Makefile.PL Build.PL dist.ini cpanfile};
}

sub home {
    my $class = shift;

    # make an $INC{ $key } style string from the class name
    (my $file = "$class.pm") =~ s{::}{/}g;

    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 ) = @_;

    return $lefthash unless defined $righthash;

    my %merged = %$lefthash;
    for my $key ( keys %$righthash ) {
        my $right_ref = ( ref $righthash->{ $key } || '' ) eq 'HASH';
        my $left_ref  = ( ( exists $lefthash->{ $key } && ref $lefthash->{ $key } ) || '' ) eq 'HASH';
        if( $right_ref and $left_ref ) {
            $merged{ $key } = merge_hashes(
                $lefthash->{ $key }, $righthash->{ $key }
            );
        }
        else {
            $merged{ $key } = $righthash->{ $key };
        }
    }

    return \%merged;
}

=head2 env_value($class, $key)

Checks for and returns an environment value. For instance, if $key is
'home', then this method will check for and return the first value it finds,
looking at $ENV{MYAPP_HOME} and $ENV{CATALYST_HOME}.

=cut

sub env_value {
    my ( $class, $key ) = @_;

    $key = uc($key);
    my @prefixes = ( class2env($class), 'CATALYST' );

    for my $prefix (@prefixes) {
        if ( defined( my $value = $ENV{"${prefix}_${key}"} ) ) {
            return $value;
        }
    }

    return;
}

=head2 term_width

Try to guess terminal width to use with formatting of debug output

All you need to get this work, is:

1) Install Term::Size::Any, or

2) Export $COLUMNS from your shell.

(Warning to bash users: 'echo $COLUMNS' may be showing you the bash
variable, not $ENV{COLUMNS}. 'export COLUMNS=$COLUMNS' and you should see
that 'env' now lists COLUMNS.)

As last resort, default value of 80 chars will be used.

Calling C<term_width> with a true value will cause it to be recalculated; you
can use this to cause it to get recalculated when your terminal is resized like
this

 $SIG{WINCH} = sub { Catalyst::Utils::term_width(1) };

=cut

my $_term_width;

sub term_width {
    my $force_reset = shift;

    undef $_term_width if $force_reset;

    return $_term_width if $_term_width;

    my $width;
    eval '
      use Term::Size::Any;
      ($width) = Term::Size::Any::chars;
      1;
    ' or do {
          if($@ =~m[Can't locate Term/Size/Any.pm]) {
            warn "Term::Size::Any is not installed, can't autodetect terminal column width\n";
          } else {
            warn "There was an error trying to detect your terminal size: $@\n";
          }
        warn 'Trouble trying to detect your terminal size, looking at $ENV{COLUMNS}'."\n";
        $width = $ENV{COLUMNS}
            if exists($ENV{COLUMNS})
            && $ENV{COLUMNS} =~ m/^\d+$/;
    };

    do {
      warn "Cannot determine desired terminal width, using default of 80 columns\n";
      $width = 80 } unless ($width && $width >= 80);
    return $_term_width = $width;
}


=head2 resolve_namespace

Method which adds the namespace for plugins and actions.

  __PACKAGE__->setup(qw(MyPlugin));

  # will load Catalyst::Plugin::MyPlugin

=cut


sub resolve_namespace {
    my $appnamespace = shift;
    my $namespace = shift;
    my @classes = @_;
    return String::RewritePrefix->rewrite({
        q[]  => qq[${namespace}::],
        q[+] => q[],
        (defined $appnamespace
            ? (q[~] => qq[${appnamespace}::])
            : ()
        ),
    }, @classes);
}

=head2 build_middleware (@args)

Internal application that converts a single middleware definition (see
L<Catalyst/psgi_middleware>) into an actual instance of middleware.

=cut

sub build_middleware {
    my ($class, $namespace, @init_args) = @_;

    if(
      $namespace =~s/^\+// ||
      $namespace =~/^Plack::Middleware/ ||
      $namespace =~/^$class/
    ) {  ## the string is a full namespace
        return Class::Load::try_load_class($namespace) ?
          $namespace->new(@init_args) :
            die "Can't load class $namespace";
    } else { ## the string is a partial namespace
      if(Class::Load::try_load_class($class .'::Middleware::'. $namespace)) { ## Load Middleware from Project namespace
          my $ns = $class .'::Middleware::'. $namespace;
          return $ns->new(@init_args);
        } elsif(Class::Load::try_load_class("Plack::Middleware::$namespace")) { ## Act like Plack::Builder
          return "Plack::Middleware::$namespace"->new(@init_args);
        } else {
          die "Can't load middleware via '$namespace'.  It's not ".$class."::Middleware::".$namespace." or Plack::Middleware::$namespace";
        }
    }

    return; ## be sure we can count on a proper return when valid
}

=head2 apply_registered_middleware ($psgi)

Given a $psgi reference, wrap all the L<Catalyst/registered_middlewares>
around it and return the wrapped version.

This exists to deal with the fact Catalyst registered middleware can be
either an object with a wrap method or a coderef.

=cut

sub apply_registered_middleware {
    my ($class, $psgi) = @_;
    my $new_psgi = $psgi;
    foreach my $middleware ($class->registered_middlewares) {
        $new_psgi = Scalar::Util::blessed $middleware ?
          $middleware->wrap($new_psgi) :
            $middleware->($new_psgi);
    }
    return $new_psgi;
}

=head2 inject_component

Used to add components at runtime:

    into        The Catalyst package to inject into (e.g. My::App)
    component   The component package to inject
    traits      (Optional) ArrayRef of L<Moose::Role>s that the componet should consume.
    as          An optional moniker to use as the package name for the derived component

For example:

    Catalyst::Utils::inject_component( into => My::App, component => Other::App::Controller::Apple )

        The above will create 'My::App::Controller::Other::App::Controller::Apple'

    Catalyst::Utils::inject_component( into => My::App, component => Other::App::Controller::Apple, as => Apple )

        The above will create 'My::App::Controller::Apple'

    Catalyst::Utils::inject_component( into => $myapp, component => 'MyRootV', as => 'Controller::Root' );

Will inject Controller, Model, and View components into your Catalyst application
at setup (run)time. It does this by creating a new package on-the-fly, having that
package extend the given component, and then having Catalyst setup the new component
(via $app->setup_component).

B<NOTE:> This is basically a core version of L<CatalystX::InjectComponent>.  If you were using that
you can now use this safely instead.  Going forward changes required to make this work will be
synchronized with the core method.

B<NOTE:> The 'traits' option is unique to the L<Catalyst::Utils> version of this feature.

B<NOTE:> These injected components really need to be a L<Catalyst::Component> and a L<Moose>
based class.

=cut

sub inject_component {
    my %given = @_;
    my ($into, $component, $as) = @given{qw/into component as/};

    croak "No Catalyst (package) given" unless $into;
    croak "No component (package) given" unless $component;

    Class::Load::load_class($component);

    $as ||= $component;
    unless ( $as =~ m/^(?:Controller|Model|View)::/ || $given{skip_mvc_renaming} ) {
        my $category;
        for (qw/ Controller Model View /) {
            if ( $component->isa( "Catalyst::$_" ) ) {
                $category = $_;
                last;
            }
        }
        croak "Don't know what kind of component \"$component\" is" unless $category;
        $as = "${category}::$as";
    }
    my $component_package = join '::', $into, $as;

    unless ( Class::Load::is_class_loaded $component_package ) {
        eval "package $component_package; use base qw/$component/; 1;" or
            croak "Unable to build component package for \"$component_package\": $@";
        Moose::Util::apply_all_roles($component_package, @{$given{traits}}) if $given{traits};
        (my $file = "$component_package.pm") =~ s{::}{/}g;
        $INC{$file} ||= 1;    
    }

    my $_setup_component = sub {
      my $into = shift;
      my $component_package = shift;
      $into->components->{$component_package} = $into->delayed_setup_component( $component_package );
    };

    $_setup_component->( $into, $component_package );
}

=head1 PSGI Helpers

Utility functions to make it easier to work with PSGI applications under Catalyst

=head2 env_at_path_prefix

Localize C<$env> under the current controller path prefix:

    package MyApp::Controller::User;

    use Catalyst::Utils;

    use base 'Catalyst::Controller';

    sub name :Local {
      my ($self, $c) = @_;
      my $env = $c->Catalyst::Utils::env_at_path_prefix;
    }

Assuming you have a request like GET /user/name:

In the example case C<$env> will have PATH_INFO of '/name' instead of
'/user/name' and SCRIPT_NAME will now be '/user'.

=cut

sub env_at_path_prefix {
  my $ctx = shift;
  my $path_prefix = $ctx->controller->path_prefix;
  my $env = $ctx->request->env;
  my $path_info = $env->{PATH_INFO};
  my $script_name = ($env->{SCRIPT_NAME} || '');

  $path_info =~ s/(^\/\Q$path_prefix\E)//;
  $script_name = "$script_name$1";

  return +{
    %$env,
    PATH_INFO => $path_info,
    SCRIPT_NAME => $script_name };
}

=head2 env_at_action

Localize C<$env> under the current action namespace.

    package MyApp::Controller::User;

    use Catalyst::Utils;

    use base 'Catalyst::Controller';

    sub name :Local {
      my ($self, $c) = @_;
      my $env = $c->Catalyst::Utils::env_at_action;
    }

Assuming you have a request like GET /user/name:

In the example case C<$env> will have PATH_INFO of '/' instead of
'/user/name' and SCRIPT_NAME will now be '/user/name'.

Alternatively, assuming you have a request like GET /user/name/foo:

In this example case C<$env> will have PATH_INFO of '/foo' instead of
'/user/name/foo' and SCRIPT_NAME will now be '/user/name'.

This is probably a common case where you want to mount a PSGI application
under an action but let the Args fall through to the PSGI app.

=cut

sub env_at_action {
  my $ctx = shift;
  my $argpath = join '/', @{$ctx->request->arguments};
  my $path = '/' . $ctx->request->path;

  $path =~ s/\/?\Q$argpath\E\/?$//;

  my $env = $ctx->request->env;
  my $path_info = $env->{PATH_INFO};
  my $script_name = ($env->{SCRIPT_NAME} || '');

  $path_info =~ s/(^\Q$path\E)//;
  $script_name = "$script_name$1";

  return +{
    %$env,
    PATH_INFO => $path_info,
    SCRIPT_NAME => $script_name };
}

=head2 env_at_request_uri

Localize C<$env> under the current request URI:

    package MyApp::Controller::User;

    use Catalyst::Utils;

    use base 'Catalyst::Controller';

    sub name :Local Args(1) {
      my ($self, $c, $id) = @_;
      my $env = $c->Catalyst::Utils::env_at_request_uri
    }

Assuming you have a request like GET /user/name/hello:

In the example case C<$env> will have PATH_INFO of '/' instead of
'/user/name' and SCRIPT_NAME will now be '/user/name/hello'.

=cut

sub env_at_request_uri {
  my $ctx = shift;
  my $path = '/' . $ctx->request->path;
  my $env = $ctx->request->env;
  my $path_info = $env->{PATH_INFO};
  my $script_name = ($env->{SCRIPT_NAME} || '');

  $path_info =~ s/(^\Q$path\E)//;
  $script_name = "$script_name$1";

  return +{
    %$env,
    PATH_INFO => $path_info,
    SCRIPT_NAME => $script_name };
}

=head1 AUTHORS

Catalyst Contributors, see Catalyst.pm

=head1 COPYRIGHT

This library is free software. You can redistribute it and/or modify it under
the same terms as Perl itself.

=cut

1;
Commit	Line	Data
f05af9ba	1	package Catalyst::Utils;
	2
	3	use strict;
37a3ac5c	4	use File::Spec;
d837e1a7	5	use HTTP::Request;
812a28c9	6	use Path::Class;
d837e1a7	7	use URI;
5e5bd6df	8	use Carp qw/croak/;
a8946dc8	9	use Cwd;
e7399d8b	10	use Class::Load 'is_class_loaded';
17b3d800	11	use String::RewritePrefix;
3086ccde	12	use Class::Load ();
0db6e9d5	13	use namespace::clean;
ec4d7259	14	use Devel::InnerPackage;
cbe627b9	15	use Moose::Util;
0db6e9d5	16
f05af9ba	17	=head1 NAME
	18
	19	Catalyst::Utils - The Catalyst Utils
	20
	21	=head1 SYNOPSIS
	22
	23	See L<Catalyst>.
	24
	25	=head1 DESCRIPTION
	26
b0ad47c1	27	Catalyst Utilities.
39fc2ce1	28
f05af9ba	29	=head1 METHODS
f05af9ba	30
b5ecfcf0	31	=head2 appprefix($class)
41ca9ba7	32
85d9fce6	33	MyApp::Foo becomes myapp_foo
41ca9ba7	34
	35	=cut
	36
	37	sub appprefix {
	38	my $class = shift;
0ef447d8	39	$class =~ s/::/_/g;
41ca9ba7	40	$class = lc($class);
	41	return $class;
	42	}
	43
b5ecfcf0	44	=head2 class2appclass($class);
84cf74e7	45
0ef447d8	46	MyApp::Controller::Foo::Bar becomes MyApp
0ef447d8	47	My::App::Controller::Foo::Bar becomes My::App
2d90477f	48
84cf74e7	49	=cut
	50
	51	sub class2appclass {
	52	my $class = shift \|\| '';
	53	my $appname = '';
0ef447d8	54	if ( $class =~ /^(.+?)::([MVC]\|Model\|View\|Controller)::.+$/ ) {
84cf74e7	55	$appname = $1;
	56	}
	57	return $appname;
	58	}
	59
b5ecfcf0	60	=head2 class2classprefix($class);
2930d610	61
0ef447d8	62	MyApp::Controller::Foo::Bar becomes MyApp::Controller
0ef447d8	63	My::App::Controller::Foo::Bar becomes My::App::Controller
2d90477f	64
2930d610	65	=cut
	66
	67	sub class2classprefix {
	68	my $class = shift \|\| '';
	69	my $prefix;
0ef447d8	70	if ( $class =~ /^(.+?::([MVC]\|Model\|View\|Controller))::.+$/ ) {
2930d610	71	$prefix = $1;
	72	}
	73	return $prefix;
	74	}
	75
b5ecfcf0	76	=head2 class2classsuffix($class);
84cf74e7	77
0ef447d8	78	MyApp::Controller::Foo::Bar becomes Controller::Foo::Bar
2d90477f	79
84cf74e7	80	=cut
	81
	82	sub class2classsuffix {
	83	my $class = shift \|\| '';
	84	my $prefix = class2appclass($class) \|\| '';
0ef447d8	85	$class =~ s/$prefix\:://;
84cf74e7	86	return $class;
	87	}
	88
b5ecfcf0	89	=head2 class2env($class);
3ad654e0	90
26e73131	91	Returns the environment name for class.
3ad654e0	92
	93	MyApp becomes MYAPP
	94	My::App becomes MY_APP
	95
	96	=cut
	97
	98	sub class2env {
	99	my $class = shift \|\| '';
0ef447d8	100	$class =~ s/::/_/g;
3ad654e0	101	return uc($class);
	102	}
	103
b5ecfcf0	104	=head2 class2prefix( $class, $case );
f05af9ba	105
e2cc89a9	106	Returns the uri prefix for a class. If case is false the prefix is converted to lowercase.
f05af9ba	107
0ef447d8	108	My::App::Controller::Foo::Bar becomes foo/bar
2d90477f	109
f05af9ba	110	=cut
	111
	112	sub class2prefix {
	113	my $class = shift \|\| '';
e494bd6b	114	my $case = shift \|\| 0;
f05af9ba	115	my $prefix;
0ef447d8	116	if ( $class =~ /^.+?::([MVC]\|Model\|View\|Controller)::(.+)$/ ) {
e494bd6b	117	$prefix = $case ? $2 : lc $2;
0ef447d8	118	$prefix =~ s{::}{/}g;
f05af9ba	119	}
	120	return $prefix;
	121	}
	122
b5ecfcf0	123	=head2 class2tempdir( $class [, $create ] );
37a3ac5c	124
e2cc89a9	125	Returns a tempdir for a class. If create is true it will try to create the path.
37a3ac5c	126
37a3ac5c	127	My::App becomes /tmp/my/app
7d7519a4	128	My::App::Controller::Foo::Bar becomes /tmp/my/app/c/foo/bar
37a3ac5c	129
	130	=cut
	131
	132	sub class2tempdir {
	133	my $class = shift \|\| '';
	134	my $create = shift \|\| 0;
4be535b1	135	my @parts = split '::', lc $class;
37a3ac5c	136
	137	my $tmpdir = dir( File::Spec->tmpdir, @parts )->cleanup;
	138
4be535b1	139	if ( $create && !-e $tmpdir ) {
37a3ac5c	140
ab61f021	141	eval { $tmpdir->mkpath; 1 }
ab61f021	142	or do {
41a8bf1f	143	# don't load Catalyst::Exception as a BEGIN in Utils,
	144	# because Utils often gets loaded before MyApp.pm, and if
	145	# Catalyst::Exception is loaded before MyApp.pm, it does
	146	# not honor setting
	147	# $Catalyst::Exception::CATALYST_EXCEPTION_CLASS in
	148	# MyApp.pm
	149	require Catalyst::Exception;
37a3ac5c	150	Catalyst::Exception->throw(
4be535b1	151	message => qq/Couldn't create tmpdir '$tmpdir', "$@"/ );
37a3ac5c	152	}
	153	}
	154
	155	return $tmpdir->stringify;
	156	}
	157
a8946dc8	158	=head2 home($class)
	159
	160	Returns home directory for given class.
	161
0f519d62	162	=head2 dist_indicator_file_list
0f519d62	163
a8946dc8	164	Returns a list of files which can be tested to check if you're inside
e01b6093	165	a CPAN distribution which is not yet installed.
	166
	167	These are:
	168
	169	=over
	170
	171	=item Makefile.PL
	172
	173	=item Build.PL
	174
	175	=item dist.ini
	176
df221478	177	=item L<cpanfile>
df221478	178
e01b6093	179	=back
0f519d62	180
	181	=cut
	182
	183	sub dist_indicator_file_list {
df221478	184	qw{Makefile.PL Build.PL dist.ini cpanfile};
0f519d62	185	}
0f519d62	186
812a28c9	187	sub home {
51f412bd	188	my $class = shift;
	189
	190	# make an $INC{ $key } style string from the class name
	191	(my $file = "$class.pm") =~ s{::}{/}g;
	192
	193	if ( my $inc_entry = $INC{$file} ) {
51452916	194	{
51f412bd	195	# look for an uninstalled Catalyst app
	196
	197	# find the @INC entry in which $file was found
	198	(my $path = $inc_entry) =~ s/$file$//;
a8946dc8	199	$path \|\|= cwd() if !defined $path \|\| !length $path;
	200	my $home = dir($path)->absolute->cleanup;
	201
	202	# pop off /lib and /blib if they're there
	203	$home = $home->parent while $home =~ /b?lib$/;
	204
	205	# only return the dir if it has a Makefile.PL or Build.PL or dist.ini
	206	if (grep { -f $home->file($_) } dist_indicator_file_list()) {
	207	# clean up relative path:
	208	# MyApp/script/.. -> MyApp
	209
	210	my $dir;
	211	my @dir_list = $home->dir_list();
	212	while (($dir = pop(@dir_list)) && $dir eq '..') {
	213	$home = dir($home)->parent->parent;
	214	}
	215
	216	return $home->stringify;
	217	}
51452916	218	}
4be535b1	219
51f412bd	220	{
	221	# look for an installed Catalyst app
	222
	223	# trim the .pm off the thing ( Foo/Bar.pm -> Foo/Bar/ )
	224	( my $path = $inc_entry) =~ s/\.pm$//;
	225	my $home = dir($path)->absolute->cleanup;
	226
bd85860b	227	# return if it's a valid directory
51f412bd	228	return $home->stringify if -d $home;
62459712	229	}
812a28c9	230	}
51f412bd	231
51f412bd	232	# we found nothing
a8946dc8	233	return 0;
03fb1bee	234	}
03fb1bee	235
b5ecfcf0	236	=head2 prefix($class, $name);
812a28c9	237
	238	Returns a prefixed action.
	239
0ef447d8	240	MyApp::Controller::Foo::Bar, yada becomes foo/bar/yada
812a28c9	241
	242	=cut
	243
	244	sub prefix {
	245	my ( $class, $name ) = @_;
	246	my $prefix = &class2prefix($class);
	247	$name = "$prefix/$name" if $prefix;
	248	return $name;
	249	}
	250
b5ecfcf0	251	=head2 request($uri)
4d60aa90	252
e2cc89a9	253	Returns an L<HTTP::Request> object for a uri.
4d60aa90	254
	255	=cut
	256
	257	sub request {
	258	my $request = shift;
	259	unless ( ref $request ) {
a88c7ec8	260	if ( $request =~ m/^http/i ) {
f4c0f6f7	261	$request = URI->new($request);
4d60aa90	262	}
4d60aa90	263	else {
f4c0f6f7	264	$request = URI->new( 'http://localhost' . $request );
4d60aa90	265	}
	266	}
	267	unless ( ref $request eq 'HTTP::Request' ) {
	268	$request = HTTP::Request->new( 'GET', $request );
	269	}
4d60aa90	270	return $request;
	271	}
	272
dd91afb5	273	=head2 ensure_class_loaded($class_name, \%opts)
d9183506	274
	275	Loads the class unless it already has been loaded.
	276
dd91afb5	277	If $opts{ignore_loaded} is true always tries the require whether the package
	278	already exists or not. Only pass this if you're either (a) sure you know the
	279	file exists on disk or (b) have code to catch the file not found exception
	280	that will result if it doesn't.
	281
d9183506	282	=cut
	283
	284	sub ensure_class_loaded {
	285	my $class = shift;
d06051f7	286	my $opts = shift;
d9183506	287
5e5bd6df	288	croak "Malformed class Name $class"
	289	if $class =~ m/(?:\b\:\b\|\:{3,})/;
	290
59ede84e	291	croak "Malformed class Name $class"
	292	if $class =~ m/[^\w:]/;
	293
	294	croak "ensure_class_loaded should be given a classname, not a filename ($class)"
	295	if $class =~ m/\.pm$/;
	296
f55d1491	297	# $opts->{ignore_loaded} can be set to true, and this causes the class to be required, even
	298	# if it already has symbol table entries. This is to support things like Schema::Loader, which
	299	# part-generate classes in memory, but then also load some of their contents from disk.
d06051f7	300	return if !$opts->{ ignore_loaded }
e7399d8b	301	&& is_class_loaded($class); # if a symbol entry exists we don't load again
fbedfd6b	302
d9183506	303	# this hack is so we don't overwrite $@ if the load did not generate an error
	304	my $error;
	305	{
	306	local $@;
7a1958eb	307	my $file = $class . '.pm';
	308	$file =~ s{::}{/}g;
	309	eval { CORE::require($file) };
d9183506	310	$error = $@;
d9183506	311	}
6bfff75e	312
d9183506	313	die $error if $error;
fbedfd6b	314
f55d1491	315	warn "require $class was successful but the package is not defined."
e7399d8b	316	unless is_class_loaded($class);
6bfff75e	317
6bfff75e	318	return 1;
d9183506	319	}
d9183506	320
358e1592	321	=head2 merge_hashes($hashref, $hashref)
	322
	323	Base code to recursively merge two hashes together with right-hand precedence.
	324
	325	=cut
	326
	327	sub merge_hashes {
	328	my ( $lefthash, $righthash ) = @_;
	329
	330	return $lefthash unless defined $righthash;
b0ad47c1	331
358e1592	332	my %merged = %$lefthash;
0ef447d8	333	for my $key ( keys %$righthash ) {
	334	my $right_ref = ( ref $righthash->{ $key } \|\| '' ) eq 'HASH';
	335	my $left_ref = ( ( exists $lefthash->{ $key } && ref $lefthash->{ $key } ) \|\| '' ) eq 'HASH';
	336	if( $right_ref and $left_ref ) {
358e1592	337	$merged{ $key } = merge_hashes(
358e1592	338	$lefthash->{ $key }, $righthash->{ $key }
0ef447d8	339	);
358e1592	340	}
	341	else {
	342	$merged{ $key } = $righthash->{ $key };
0ef447d8	343	}
358e1592	344	}
b0ad47c1	345
358e1592	346	return \%merged;
	347	}
	348
cb69249e	349	=head2 env_value($class, $key)
	350
	351	Checks for and returns an environment value. For instance, if $key is
	352	'home', then this method will check for and return the first value it finds,
	353	looking at $ENV{MYAPP_HOME} and $ENV{CATALYST_HOME}.
	354
	355	=cut
	356
	357	sub env_value {
	358	my ( $class, $key ) = @_;
	359
	360	$key = uc($key);
	361	my @prefixes = ( class2env($class), 'CATALYST' );
	362
	363	for my $prefix (@prefixes) {
	364	if ( defined( my $value = $ENV{"${prefix}_${key}"} ) ) {
	365	return $value;
	366	}
	367	}
	368
	369	return;
	370	}
d9183506	371
39fc2ce1	372	=head2 term_width
	373
	374	Try to guess terminal width to use with formatting of debug output
	375
	376	All you need to get this work, is:
	377
	378	1) Install Term::Size::Any, or
	379
b0ad47c1	380	2) Export $COLUMNS from your shell.
39fc2ce1	381
39fc2ce1	382	(Warning to bash users: 'echo $COLUMNS' may be showing you the bash
b0ad47c1	383	variable, not $ENV{COLUMNS}. 'export COLUMNS=$COLUMNS' and you should see
39fc2ce1	384	that 'env' now lists COLUMNS.)
	385
	386	As last resort, default value of 80 chars will be used.
	387
ad9e8de9	388	Calling C<term_width> with a true value will cause it to be recalculated; you
	389	can use this to cause it to get recalculated when your terminal is resized like
	390	this
	391
	392	$SIG{WINCH} = sub { Catalyst::Utils::term_width(1) };
	393
39fc2ce1	394	=cut
	395
	396	my $_term_width;
	397
	398	sub term_width {
ad9e8de9	399	my $force_reset = shift;
	400
	401	undef $_term_width if $force_reset;
	402
39fc2ce1	403	return $_term_width if $_term_width;
39fc2ce1	404
ab61f021	405	my $width;
ab61f021	406	eval '
dfcb05ee	407	use Term::Size::Any;
	408	($width) = Term::Size::Any::chars;
	409	1;
ab61f021	410	' or do {
dfcb05ee	411	if($@ =~m[Can't locate Term/Size/Any.pm]) {
	412	warn "Term::Size::Any is not installed, can't autodetect terminal column width\n";
	413	} else {
	414	warn "There was an error trying to detect your terminal size: $@\n";
	415	}
	416	warn 'Trouble trying to detect your terminal size, looking at $ENV{COLUMNS}'."\n";
39fc2ce1	417	$width = $ENV{COLUMNS}
	418	if exists($ENV{COLUMNS})
	419	&& $ENV{COLUMNS} =~ m/^\d+$/;
ab61f021	420	};
39fc2ce1	421
dfcb05ee	422	do {
	423	warn "Cannot determine desired terminal width, using default of 80 columns\n";
	424	$width = 80 } unless ($width && $width >= 80);
39fc2ce1	425	return $_term_width = $width;
	426	}
	427
17b3d800	428
	429	=head2 resolve_namespace
	430
	431	Method which adds the namespace for plugins and actions.
	432
	433	__PACKAGE__->setup(qw(MyPlugin));
196932de	434
17b3d800	435	# will load Catalyst::Plugin::MyPlugin
	436
	437	=cut
	438
	439
	440	sub resolve_namespace {
5d8129e9	441	my $appnamespace = shift;
17b3d800	442	my $namespace = shift;
17b3d800	443	my @classes = @_;
196932de	444	return String::RewritePrefix->rewrite({
	445	q[] => qq[${namespace}::],
	446	q[+] => q[],
	447	(defined $appnamespace
	448	? (q[~] => qq[${appnamespace}::])
	449	: ()
	450	),
	451	}, @classes);
17b3d800	452	}
17b3d800	453
3086ccde	454	=head2 build_middleware (@args)
	455
	456	Internal application that converts a single middleware definition (see
	457	L<Catalyst/psgi_middleware>) into an actual instance of middleware.
	458
	459	=cut
	460
	461	sub build_middleware {
	462	my ($class, $namespace, @init_args) = @_;
	463
	464	if(
	465	$namespace =~s/^\+// \|\|
	466	$namespace =~/^Plack::Middleware/ \|\|
	467	$namespace =~/^$class/
	468	) { ## the string is a full namespace
	469	return Class::Load::try_load_class($namespace) ?
	470	$namespace->new(@init_args) :
	471	die "Can't load class $namespace";
	472	} else { ## the string is a partial namespace
9b5bca00	473	if(Class::Load::try_load_class($class .'::Middleware::'. $namespace)) { ## Load Middleware from Project namespace
	474	my $ns = $class .'::Middleware::'. $namespace;
	475	return $ns->new(@init_args);
318213cd	476	} elsif(Class::Load::try_load_class("Plack::Middleware::$namespace")) { ## Act like Plack::Builder
318213cd	477	return "Plack::Middleware::$namespace"->new(@init_args);
d9c6a83f	478	} else {
d9c6a83f	479	die "Can't load middleware via '$namespace'. It's not ".$class."::Middleware::".$namespace." or Plack::Middleware::$namespace";
3086ccde	480	}
	481	}
	482
	483	return; ## be sure we can count on a proper return when valid
	484	}
	485
	486	=head2 apply_registered_middleware ($psgi)
	487
	488	Given a $psgi reference, wrap all the L<Catalyst/registered_middlewares>
	489	around it and return the wrapped version.
	490
	491	This exists to deal with the fact Catalyst registered middleware can be
	492	either an object with a wrap method or a coderef.
	493
	494	=cut
	495
	496	sub apply_registered_middleware {
	497	my ($class, $psgi) = @_;
	498	my $new_psgi = $psgi;
	499	foreach my $middleware ($class->registered_middlewares) {
	500	$new_psgi = Scalar::Util::blessed $middleware ?
	501	$middleware->wrap($new_psgi) :
	502	$middleware->($new_psgi);
	503	}
	504	return $new_psgi;
	505	}
17b3d800	506
ec4d7259	507	=head2 inject_component
6adc45cf	508
ec4d7259	509	Used to add components at runtime:
	510
	511	into The Catalyst package to inject into (e.g. My::App)
	512	component The component package to inject
cbe627b9	513	traits (Optional) ArrayRef of L<Moose::Role>s that the componet should consume.
ec4d7259	514	as An optional moniker to use as the package name for the derived component
	515
	516	For example:
	517
	518	Catalyst::Utils::inject_component( into => My::App, component => Other::App::Controller::Apple )
	519
	520	The above will create 'My::App::Controller::Other::App::Controller::Apple'
	521
	522	Catalyst::Utils::inject_component( into => My::App, component => Other::App::Controller::Apple, as => Apple )
	523
	524	The above will create 'My::App::Controller::Apple'
	525
	526	Catalyst::Utils::inject_component( into => $myapp, component => 'MyRootV', as => 'Controller::Root' );
	527
	528	Will inject Controller, Model, and View components into your Catalyst application
	529	at setup (run)time. It does this by creating a new package on-the-fly, having that
	530	package extend the given component, and then having Catalyst setup the new component
	531	(via $app->setup_component).
	532
	533	B<NOTE:> This is basically a core version of L<CatalystX::InjectComponent>. If you were using that
	534	you can now use this safely instead. Going forward changes required to make this work will be
	535	synchronized with the core method.
	536
cbe627b9	537	B<NOTE:> The 'traits' option is unique to the L<Catalyst::Utils> version of this feature.
	538
	539	B<NOTE:> These injected components really need to be a L<Catalyst::Component> and a L<Moose>
	540	based class.
	541
ec4d7259	542	=cut
	543
	544	sub inject_component {
	545	my %given = @_;
	546	my ($into, $component, $as) = @given{qw/into component as/};
	547
	548	croak "No Catalyst (package) given" unless $into;
	549	croak "No component (package) given" unless $component;
	550
	551	Class::Load::load_class($component);
	552
	553	$as \|\|= $component;
	554	unless ( $as =~ m/^(?:Controller\|Model\|View)::/ \|\| $given{skip_mvc_renaming} ) {
	555	my $category;
	556	for (qw/ Controller Model View /) {
	557	if ( $component->isa( "Catalyst::$_" ) ) {
	558	$category = $_;
	559	last;
	560	}
	561	}
	562	croak "Don't know what kind of component \"$component\" is" unless $category;
	563	$as = "${category}::$as";
	564	}
	565	my $component_package = join '::', $into, $as;
	566
	567	unless ( Class::Load::is_class_loaded $component_package ) {
	568	eval "package $component_package; use base qw/$component/; 1;" or
	569	croak "Unable to build component package for \"$component_package\": $@";
cbe627b9	570	Moose::Util::apply_all_roles($component_package, @{$given{traits}}) if $given{traits};
ec4d7259	571	(my $file = "$component_package.pm") =~ s{::}{/}g;
	572	$INC{$file} \|\|= 1;
	573	}
	574
	575	my $_setup_component = sub {
	576	my $into = shift;
	577	my $component_package = shift;
e39312ba	578	$into->components->{$component_package} = $into->delayed_setup_component( $component_package );
ec4d7259	579	};
	580
	581	$_setup_component->( $into, $component_package );
ec4d7259	582	}
6adc45cf	583
9c7b6768	584	=head1 PSGI Helpers
	585
	586	Utility functions to make it easier to work with PSGI applications under Catalyst
	587
	588	=head2 env_at_path_prefix
	589
	590	Localize C<$env> under the current controller path prefix:
	591
	592	package MyApp::Controller::User;
	593
	594	use Catalyst::Utils;
	595
	596	use base 'Catalyst::Controller';
	597
	598	sub name :Local {
	599	my ($self, $c) = @_;
	600	my $env = $c->Catalyst::Utils::env_at_path_prefix;
	601	}
	602
efa8265f	603	Assuming you have a request like GET /user/name:
9c7b6768	604
	605	In the example case C<$env> will have PATH_INFO of '/name' instead of
	606	'/user/name' and SCRIPT_NAME will now be '/user'.
	607
	608	=cut
	609
	610	sub env_at_path_prefix {
	611	my $ctx = shift;
	612	my $path_prefix = $ctx->controller->path_prefix;
	613	my $env = $ctx->request->env;
	614	my $path_info = $env->{PATH_INFO};
	615	my $script_name = ($env->{SCRIPT_NAME} \|\| '');
	616
	617	$path_info =~ s/(^\/\Q$path_prefix\E)//;
	618	$script_name = "$script_name$1";
	619
	620	return +{
	621	%$env,
	622	PATH_INFO => $path_info,
	623	SCRIPT_NAME => $script_name };
	624	}
	625
	626	=head2 env_at_action
	627
4477b313	628	Localize C<$env> under the current action namespace.
9c7b6768	629
	630	package MyApp::Controller::User;
	631
	632	use Catalyst::Utils;
	633
	634	use base 'Catalyst::Controller';
	635
	636	sub name :Local {
	637	my ($self, $c) = @_;
	638	my $env = $c->Catalyst::Utils::env_at_action;
	639	}
	640
4477b313	641	Assuming you have a request like GET /user/name:
9c7b6768	642
	643	In the example case C<$env> will have PATH_INFO of '/' instead of
	644	'/user/name' and SCRIPT_NAME will now be '/user/name'.
	645
efa8265f	646	Alternatively, assuming you have a request like GET /user/name/foo:
4477b313	647
	648	In this example case C<$env> will have PATH_INFO of '/foo' instead of
	649	'/user/name/foo' and SCRIPT_NAME will now be '/user/name'.
	650
9c7b6768	651	This is probably a common case where you want to mount a PSGI application
	652	under an action but let the Args fall through to the PSGI app.
	653
	654	=cut
	655
	656	sub env_at_action {
	657	my $ctx = shift;
	658	my $argpath = join '/', @{$ctx->request->arguments};
	659	my $path = '/' . $ctx->request->path;
	660
	661	$path =~ s/\/?\Q$argpath\E\/?$//;
	662
	663	my $env = $ctx->request->env;
	664	my $path_info = $env->{PATH_INFO};
	665	my $script_name = ($env->{SCRIPT_NAME} \|\| '');
	666
	667	$path_info =~ s/(^\Q$path\E)//;
	668	$script_name = "$script_name$1";
	669
	670	return +{
	671	%$env,
	672	PATH_INFO => $path_info,
	673	SCRIPT_NAME => $script_name };
	674	}
	675
	676	=head2 env_at_request_uri
	677
4477b313	678	Localize C<$env> under the current request URI:
9c7b6768	679
	680	package MyApp::Controller::User;
	681
	682	use Catalyst::Utils;
	683
	684	use base 'Catalyst::Controller';
	685
	686	sub name :Local Args(1) {
	687	my ($self, $c, $id) = @_;
	688	my $env = $c->Catalyst::Utils::env_at_request_uri
	689	}
	690
efa8265f	691	Assuming you have a request like GET /user/name/hello:
9c7b6768	692
	693	In the example case C<$env> will have PATH_INFO of '/' instead of
	694	'/user/name' and SCRIPT_NAME will now be '/user/name/hello'.
	695
	696	=cut
	697
	698	sub env_at_request_uri {
	699	my $ctx = shift;
	700	my $path = '/' . $ctx->request->path;
	701	my $env = $ctx->request->env;
	702	my $path_info = $env->{PATH_INFO};
	703	my $script_name = ($env->{SCRIPT_NAME} \|\| '');
	704
	705	$path_info =~ s/(^\Q$path\E)//;
	706	$script_name = "$script_name$1";
	707
	708	return +{
	709	%$env,
	710	PATH_INFO => $path_info,
	711	SCRIPT_NAME => $script_name };
	712	}
	713
2f381252	714	=head1 AUTHORS
f05af9ba	715
2f381252	716	Catalyst Contributors, see Catalyst.pm
f05af9ba	717
	718	=head1 COPYRIGHT
	719
536bee89	720	This library is free software. You can redistribute it and/or modify it under
f05af9ba	721	the same terms as Perl itself.
	722
	723	=cut
	724
	725	1;