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

=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
    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.

=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\": $@";
        (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->setup_component( $component_package );
    };

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