lib/Catalyst/Utils.pm

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