lib/Catalyst/Utils.pm

   1 package Catalyst::Utils;
   2
   3 use strict;
   4 use File::Spec;
   5 use HTTP::Request;
   6 use Path::Class;
   7 use URI;
   8 use Carp qw/croak/;
   9 use Class::MOP;
  10 use String::RewritePrefix;
  11 use List::MoreUtils qw/ any /;
  12 use Cwd qw/ cwd /;
  13
  14 use namespace::clean;
  15
  16 =head1 NAME
  17
  18 Catalyst::Utils - The Catalyst Utils
  19
  20 =head1 SYNOPSIS
  21
  22 See L<Catalyst>.
  23
  24 =head1 DESCRIPTION
  25
  26 Catalyst Utilities.
  27
  28 =head1 METHODS
  29
  30 =head2 appprefix($class)
  31
  32     MyApp::Foo becomes myapp_foo
  33
  34 =cut
  35
  36 sub appprefix {
  37     my $class = shift;
  38     $class =~ s/::/_/g;
  39     $class = lc($class);
  40     return $class;
  41 }
  42
  43 =head2 class2appclass($class);
  44
  45     MyApp::Controller::Foo::Bar becomes MyApp
  46     My::App::Controller::Foo::Bar becomes My::App
  47
  48 =cut
  49
  50 sub class2appclass {
  51     my $class = shift || '';
  52     my $appname = '';
  53     if ( $class =~ /^(.+?)::([MVC]|Model|View|Controller)::.+$/ ) {
  54         $appname = $1;
  55     }
  56     return $appname;
  57 }
  58
  59 =head2 class2classprefix($class);
  60
  61     MyApp::Controller::Foo::Bar becomes MyApp::Controller
  62     My::App::Controller::Foo::Bar becomes My::App::Controller
  63
  64 =cut
  65
  66 sub class2classprefix {
  67     my $class = shift || '';
  68     my $prefix;
  69     if ( $class =~ /^(.+?::([MVC]|Model|View|Controller))::.+$/ ) {
  70         $prefix = $1;
  71     }
  72     return $prefix;
  73 }
  74
  75 =head2 class2classsuffix($class);
  76
  77     MyApp::Controller::Foo::Bar becomes Controller::Foo::Bar
  78
  79 =cut
  80
  81 sub class2classsuffix {
  82     my $class = shift || '';
  83     my $prefix = class2appclass($class) || '';
  84     $class =~ s/$prefix\:://;
  85     return $class;
  86 }
  87
  88 =head2 class2env($class);
  89
  90 Returns the environment name for class.
  91
  92     MyApp becomes MYAPP
  93     My::App becomes MY_APP
  94
  95 =cut
  96
  97 sub class2env {
  98     my $class = shift || '';
  99     $class =~ s/::/_/g;
 100     return uc($class);
 101 }
 102
 103 =head2 class2prefix( $class, $case );
 104
 105 Returns the uri prefix for a class. If case is false the prefix is converted to lowercase.
 106
 107     My::App::Controller::Foo::Bar becomes foo/bar
 108
 109 =cut
 110
 111 sub class2prefix {
 112     my $class = shift || '';
 113     my $case  = shift || 0;
 114     my $prefix;
 115     if ( $class =~ /^.+?::([MVC]|Model|View|Controller)::(.+)$/ ) {
 116         $prefix = $case ? $2 : lc $2;
 117         $prefix =~ s{::}{/}g;
 118     }
 119     return $prefix;
 120 }
 121
 122 =head2 class2tempdir( $class [, $create ] );
 123
 124 Returns a tempdir for a class. If create is true it will try to create the path.
 125
 126     My::App becomes /tmp/my/app
 127     My::App::Controller::Foo::Bar becomes /tmp/my/app/c/foo/bar
 128
 129 =cut
 130
 131 sub class2tempdir {
 132     my $class  = shift || '';
 133     my $create = shift || 0;
 134     my @parts = split '::', lc $class;
 135
 136     my $tmpdir = dir( File::Spec->tmpdir, @parts )->cleanup;
 137
 138     if ( $create && !-e $tmpdir ) {
 139
 140         eval { $tmpdir->mkpath };
 141
 142         if ($@) {
 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;
 150             Catalyst::Exception->throw(
 151                 message => qq/Couldn't create tmpdir '$tmpdir', "$@"/ );
 152         }
 153     }
 154
 155     return $tmpdir->stringify;
 156 }
 157
 158 =head2 dist_indicator_file_list
 159
 160 Returns a list of files which can be tested to check if you're inside a checkout
 161
 162 =cut
 163
 164 sub dist_indicator_file_list {
 165     qw/ Makefile.PL Build.PL dist.ini /;
 166 }
 167
 168 =head2 home($class)
 169
 170 Returns home directory for given class.
 171
 172 Note that the class must be loaded for the home directory to be found using this function.
 173
 174 =cut
 175
 176 sub home {
 177     my $class = shift;
 178
 179     # make an $INC{ $key } style string from the class name
 180     (my $file = "$class.pm") =~ s{::}{/}g;
 181
 182     if ( my $inc_entry = $INC{$file} ) {
 183         {
 184             # look for an uninstalled Catalyst app
 185
 186             # find the @INC entry in which $file was found
 187             (my $path = $inc_entry) =~ s/$file$//;
 188             my $home = find_home_unloaded_in_checkout($path);
 189             return $home if $home;
 190         }
 191
 192         {
 193             # look for an installed Catalyst app
 194
 195             # trim the .pm off the thing ( Foo/Bar.pm -> Foo/Bar/ )
 196             ( my $path = $inc_entry) =~ s/\.pm$//;
 197             my $home = dir($path)->absolute->cleanup;
 198
 199             # return if if it's a valid directory
 200             return $home->stringify if -d $home;
 201         }
 202     }
 203
 204     # we found nothing
 205     return 0;
 206 }
 207
 208 =head2 find_home_unloaded_in_checkout ($path)
 209
 210 Tries to determine if C<$path> (or cwd if not supplied)
 211 looks like a checkout. Any leading lib, script or blib components
 212 will be removed, then the directory produced will be checked
 213 for the existence of a C<< dist_indicator_file_list() >>.
 214
 215 If one is found, the directory will be returned, otherwise false.
 216
 217 =cut
 218
 219 sub find_home_unloaded_in_checkout {
 220     my ($path) = @_;
 221     $path ||= cwd() if !defined $path || !length $path;
 222     my $home = dir($path)->absolute->cleanup;
 223     # pop off /lib and /blib if they're there
 224     # pop off /script if it's there.
 225
 226     do {
 227         # only return the dir if it has a Makefile.PL or Build.PL or dist.ini
 228         if (any { $_ } map { -f $home->file($_) } dist_indicator_file_list()) {
 229             # clean up relative path:
 230             # MyApp/script/.. -> MyApp
 231
 232             my $dir;
 233             my @dir_list = $home->dir_list();
 234             while (($dir = pop(@dir_list)) && $dir eq '..') {
 235                 $home = dir($home)->parent->parent;
 236             }
 237             return $home->stringify;
 238         }
 239         $home = $home->parent;
 240     }
 241     while # pop off /lib and /blib or /script or /t/ if they're there
 242         ($home =~ /b?lib$/ || $home =~ /script$/ || $home =~ /\/t(\/|$)/);
 243 }
 244
 245 =head2 prefix($class, $name);
 246
 247 Returns a prefixed action.
 248
 249     MyApp::Controller::Foo::Bar, yada becomes foo/bar/yada
 250
 251 =cut
 252
 253 sub prefix {
 254     my ( $class, $name ) = @_;
 255     my $prefix = &class2prefix($class);
 256     $name = "$prefix/$name" if $prefix;
 257     return $name;
 258 }
 259
 260 =head2 request($uri)
 261
 262 Returns an L<HTTP::Request> object for a uri.
 263
 264 =cut
 265
 266 sub request {
 267     my $request = shift;
 268     unless ( ref $request ) {
 269         if ( $request =~ m/^http/i ) {
 270             $request = URI->new($request);
 271         }
 272         else {
 273             $request = URI->new( 'http://localhost' . $request );
 274         }
 275     }
 276     unless ( ref $request eq 'HTTP::Request' ) {
 277         $request = HTTP::Request->new( 'GET', $request );
 278     }
 279     return $request;
 280 }
 281
 282 =head2 ensure_class_loaded($class_name, \%opts)
 283
 284 Loads the class unless it already has been loaded.
 285
 286 If $opts{ignore_loaded} is true always tries the require whether the package
 287 already exists or not. Only pass this if you're either (a) sure you know the
 288 file exists on disk or (b) have code to catch the file not found exception
 289 that will result if it doesn't.
 290
 291 =cut
 292
 293 sub ensure_class_loaded {
 294     my $class = shift;
 295     my $opts  = shift;
 296
 297     croak "Malformed class Name $class"
 298         if $class =~ m/(?:\b\:\b|\:{3,})/;
 299
 300     croak "Malformed class Name $class"
 301         if $class =~ m/[^\w:]/;
 302
 303     croak "ensure_class_loaded should be given a classname, not a filename ($class)"
 304         if $class =~ m/\.pm$/;
 305
 306     # $opts->{ignore_loaded} can be set to true, and this causes the class to be required, even
 307     # if it already has symbol table entries. This is to support things like Schema::Loader, which
 308     # part-generate classes in memory, but then also load some of their contents from disk.
 309     return if !$opts->{ ignore_loaded }
 310         && Class::MOP::is_class_loaded($class); # if a symbol entry exists we don't load again
 311
 312     # this hack is so we don't overwrite $@ if the load did not generate an error
 313     my $error;
 314     {
 315         local $@;
 316         my $file = $class . '.pm';
 317         $file =~ s{::}{/}g;
 318         eval { CORE::require($file) };
 319         $error = $@;
 320     }
 321
 322     die $error if $error;
 323
 324     warn "require $class was successful but the package is not defined."
 325         unless Class::MOP::is_class_loaded($class);
 326
 327     return 1;
 328 }
 329
 330 =head2 merge_hashes($hashref, $hashref)
 331
 332 Base code to recursively merge two hashes together with right-hand precedence.
 333
 334 =cut
 335
 336 sub merge_hashes {
 337     my ( $lefthash, $righthash ) = @_;
 338
 339     return $lefthash unless defined $righthash;
 340
 341     my %merged = %$lefthash;
 342     for my $key ( keys %$righthash ) {
 343         my $right_ref = ( ref $righthash->{ $key } || '' ) eq 'HASH';
 344         my $left_ref  = ( ( exists $lefthash->{ $key } && ref $lefthash->{ $key } ) || '' ) eq 'HASH';
 345         if( $right_ref and $left_ref ) {
 346             $merged{ $key } = merge_hashes(
 347                 $lefthash->{ $key }, $righthash->{ $key }
 348             );
 349         }
 350         else {
 351             $merged{ $key } = $righthash->{ $key };
 352         }
 353     }
 354
 355     return \%merged;
 356 }
 357
 358 =head2 env_value($class, $key)
 359
 360 Checks for and returns an environment value. For instance, if $key is
 361 'home', then this method will check for and return the first value it finds,
 362 looking at $ENV{MYAPP_HOME} and $ENV{CATALYST_HOME}.
 363
 364 =cut
 365
 366 sub env_value {
 367     my ( $class, $key ) = @_;
 368
 369     $key = uc($key);
 370     my @prefixes = ( class2env($class), 'CATALYST' );
 371
 372     for my $prefix (@prefixes) {
 373         if ( defined( my $value = $ENV{"${prefix}_${key}"} ) ) {
 374             return $value;
 375         }
 376     }
 377
 378     return;
 379 }
 380
 381 =head2 term_width
 382
 383 Try to guess terminal width to use with formatting of debug output
 384
 385 All you need to get this work, is:
 386
 387 1) Install Term::Size::Any, or
 388
 389 2) Export $COLUMNS from your shell.
 390
 391 (Warning to bash users: 'echo $COLUMNS' may be showing you the bash
 392 variable, not $ENV{COLUMNS}. 'export COLUMNS=$COLUMNS' and you should see
 393 that 'env' now lists COLUMNS.)
 394
 395 As last resort, default value of 80 chars will be used.
 396
 397 =cut
 398
 399 my $_term_width;
 400
 401 sub term_width {
 402     return $_term_width if $_term_width;
 403
 404     my $width = eval '
 405         use Term::Size::Any;
 406         my ($columns, $rows) = Term::Size::Any::chars;
 407         return $columns;
 408     ';
 409
 410     if ($@) {
 411         $width = $ENV{COLUMNS}
 412             if exists($ENV{COLUMNS})
 413             && $ENV{COLUMNS} =~ m/^\d+$/;
 414     }
 415
 416     $width = 80 unless ($width && $width >= 80);
 417     return $_term_width = $width;
 418 }
 419
 420
 421 =head2 resolve_namespace
 422
 423 Method which adds the namespace for plugins and actions.
 424
 425   __PACKAGE__->setup(qw(MyPlugin));
 426
 427   # will load Catalyst::Plugin::MyPlugin
 428
 429 =cut
 430
 431
 432 sub resolve_namespace {
 433     my $appnamespace = shift;
 434     my $namespace = shift;
 435     my @classes = @_;
 436     return String::RewritePrefix->rewrite({
 437         q[]  => qq[${namespace}::],
 438         q[+] => q[],
 439         (defined $appnamespace
 440             ? (q[~] => qq[${appnamespace}::])
 441             : ()
 442         ),
 443     }, @classes);
 444 }
 445
 446
 447 =head1 AUTHORS
 448
 449 Catalyst Contributors, see Catalyst.pm
 450
 451 =head1 COPYRIGHT
 452
 453 This library is free software. You can redistribute it and/or modify it under
 454 the same terms as Perl itself.
 455
 456 =cut
 457
 458 1;