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