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