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