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