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