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