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 Cwd;
  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 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.init /;
 166 }
 167
 168 =head2 home($class)
 169
 170 Returns home directory for given class.
 171
 172 =cut
 173
 174 sub home {
 175     my $class = shift;
 176
 177     # make an $INC{ $key } style string from the class name
 178     (my $file = "$class.pm") =~ s{::}{/}g;
 179
 180     if ( my $inc_entry = $INC{$file} ) {
 181         {
 182             # look for an uninstalled Catalyst app
 183
 184             # find the @INC entry in which $file was found
 185             (my $path = $inc_entry) =~ s/$file$//;
 186             $path ||= cwd() if !defined $path || !length $path;
 187             my $home = dir($path)->absolute->cleanup;
 188
 189             # pop off /lib and /blib if they're there
 190             $home = $home->parent while $home =~ /b?lib$/;
 191
 192             # only return the dir if it has a Makefile.PL or Build.PL or dist.ini
 193             if (any { $_ } map { -f $home->file($_) } dist_indicator_file_list()) {
 194
 195                 # clean up relative path:
 196                 # MyApp/script/.. -> MyApp
 197
 198                 my $dir;
 199                 my @dir_list = $home->dir_list();
 200                 while (($dir = pop(@dir_list)) && $dir eq '..') {
 201                     $home = dir($home)->parent->parent;
 202                 }
 203
 204                 return $home->stringify;
 205             }
 206         }
 207
 208         {
 209             # look for an installed Catalyst app
 210
 211             # trim the .pm off the thing ( Foo/Bar.pm -> Foo/Bar/ )
 212             ( my $path = $inc_entry) =~ s/\.pm$//;
 213             my $home = dir($path)->absolute->cleanup;
 214
 215             # return if if it's a valid directory
 216             return $home->stringify if -d $home;
 217         }
 218     }
 219
 220     # we found nothing
 221     return 0;
 222 }
 223
 224 =head2 prefix($class, $name);
 225
 226 Returns a prefixed action.
 227
 228     MyApp::Controller::Foo::Bar, yada becomes foo/bar/yada
 229
 230 =cut
 231
 232 sub prefix {
 233     my ( $class, $name ) = @_;
 234     my $prefix = &class2prefix($class);
 235     $name = "$prefix/$name" if $prefix;
 236     return $name;
 237 }
 238
 239 =head2 request($uri)
 240
 241 Returns an L<HTTP::Request> object for a uri.
 242
 243 =cut
 244
 245 sub request {
 246     my $request = shift;
 247     unless ( ref $request ) {
 248         if ( $request =~ m/^http/i ) {
 249             $request = URI->new($request);
 250         }
 251         else {
 252             $request = URI->new( 'http://localhost' . $request );
 253         }
 254     }
 255     unless ( ref $request eq 'HTTP::Request' ) {
 256         $request = HTTP::Request->new( 'GET', $request );
 257     }
 258     return $request;
 259 }
 260
 261 =head2 ensure_class_loaded($class_name, \%opts)
 262
 263 Loads the class unless it already has been loaded.
 264
 265 If $opts{ignore_loaded} is true always tries the require whether the package
 266 already exists or not. Only pass this if you're either (a) sure you know the
 267 file exists on disk or (b) have code to catch the file not found exception
 268 that will result if it doesn't.
 269
 270 =cut
 271
 272 sub ensure_class_loaded {
 273     my $class = shift;
 274     my $opts  = shift;
 275
 276     croak "Malformed class Name $class"
 277         if $class =~ m/(?:\b\:\b|\:{3,})/;
 278
 279     croak "Malformed class Name $class"
 280         if $class =~ m/[^\w:]/;
 281
 282     croak "ensure_class_loaded should be given a classname, not a filename ($class)"
 283         if $class =~ m/\.pm$/;
 284
 285     # $opts->{ignore_loaded} can be set to true, and this causes the class to be required, even
 286     # if it already has symbol table entries. This is to support things like Schema::Loader, which
 287     # part-generate classes in memory, but then also load some of their contents from disk.
 288     return if !$opts->{ ignore_loaded }
 289         && Class::MOP::is_class_loaded($class); # if a symbol entry exists we don't load again
 290
 291     # this hack is so we don't overwrite $@ if the load did not generate an error
 292     my $error;
 293     {
 294         local $@;
 295         my $file = $class . '.pm';
 296         $file =~ s{::}{/}g;
 297         eval { CORE::require($file) };
 298         $error = $@;
 299     }
 300
 301     die $error if $error;
 302
 303     warn "require $class was successful but the package is not defined."
 304         unless Class::MOP::is_class_loaded($class);
 305
 306     return 1;
 307 }
 308
 309 =head2 merge_hashes($hashref, $hashref)
 310
 311 Base code to recursively merge two hashes together with right-hand precedence.
 312
 313 =cut
 314
 315 sub merge_hashes {
 316     my ( $lefthash, $righthash ) = @_;
 317
 318     return $lefthash unless defined $righthash;
 319
 320     my %merged = %$lefthash;
 321     for my $key ( keys %$righthash ) {
 322         my $right_ref = ( ref $righthash->{ $key } || '' ) eq 'HASH';
 323         my $left_ref  = ( ( exists $lefthash->{ $key } && ref $lefthash->{ $key } ) || '' ) eq 'HASH';
 324         if( $right_ref and $left_ref ) {
 325             $merged{ $key } = merge_hashes(
 326                 $lefthash->{ $key }, $righthash->{ $key }
 327             );
 328         }
 329         else {
 330             $merged{ $key } = $righthash->{ $key };
 331         }
 332     }
 333
 334     return \%merged;
 335 }
 336
 337 =head2 env_value($class, $key)
 338
 339 Checks for and returns an environment value. For instance, if $key is
 340 'home', then this method will check for and return the first value it finds,
 341 looking at $ENV{MYAPP_HOME} and $ENV{CATALYST_HOME}.
 342
 343 =cut
 344
 345 sub env_value {
 346     my ( $class, $key ) = @_;
 347
 348     $key = uc($key);
 349     my @prefixes = ( class2env($class), 'CATALYST' );
 350
 351     for my $prefix (@prefixes) {
 352         if ( defined( my $value = $ENV{"${prefix}_${key}"} ) ) {
 353             return $value;
 354         }
 355     }
 356
 357     return;
 358 }
 359
 360 =head2 term_width
 361
 362 Try to guess terminal width to use with formatting of debug output
 363
 364 All you need to get this work, is:
 365
 366 1) Install Term::Size::Any, or
 367
 368 2) Export $COLUMNS from your shell.
 369
 370 (Warning to bash users: 'echo $COLUMNS' may be showing you the bash
 371 variable, not $ENV{COLUMNS}. 'export COLUMNS=$COLUMNS' and you should see
 372 that 'env' now lists COLUMNS.)
 373
 374 As last resort, default value of 80 chars will be used.
 375
 376 =cut
 377
 378 my $_term_width;
 379
 380 sub term_width {
 381     return $_term_width if $_term_width;
 382
 383     my $width = eval '
 384         use Term::Size::Any;
 385         my ($columns, $rows) = Term::Size::Any::chars;
 386         return $columns;
 387     ';
 388
 389     if ($@) {
 390         $width = $ENV{COLUMNS}
 391             if exists($ENV{COLUMNS})
 392             && $ENV{COLUMNS} =~ m/^\d+$/;
 393     }
 394
 395     $width = 80 unless ($width && $width >= 80);
 396     return $_term_width = $width;
 397 }
 398
 399
 400 =head2 resolve_namespace
 401
 402 Method which adds the namespace for plugins and actions.
 403
 404   __PACKAGE__->setup(qw(MyPlugin));
 405
 406   # will load Catalyst::Plugin::MyPlugin
 407
 408 =cut
 409
 410
 411 sub resolve_namespace {
 412     my $appnamespace = shift;
 413     my $namespace = shift;
 414     my @classes = @_;
 415     return String::RewritePrefix->rewrite({
 416         q[]  => qq[${namespace}::],
 417         q[+] => q[],
 418         (defined $appnamespace
 419             ? (q[~] => qq[${appnamespace}::])
 420             : ()
 421         ),
 422     }, @classes);
 423 }
 424
 425
 426 =head1 AUTHORS
 427
 428 Catalyst Contributors, see Catalyst.pm
 429
 430 =head1 COPYRIGHT
 431
 432 This library is free software. You can redistribute it and/or modify it under
 433 the same terms as Perl itself.
 434
 435 =cut
 436
 437 1;