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