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