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