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
  10 =head1 NAME
  11
  12 Catalyst::Utils - The Catalyst Utils
  13
  14 =head1 SYNOPSIS
  15
  16 See L<Catalyst>.
  17
  18 =head1 DESCRIPTION
  19
  20 =head1 METHODS
  21
  22 =over 4
  23
  24 =item appprefix($class)
  25
  26 Returns the application prefix for the class.
  27
  28         MyApp::Foo becomes myapp_foo
  29
  30 =cut
  31
  32 sub appprefix {
  33     my $class = shift;
  34     $class =~ s/\:\:/_/g;
  35     $class = lc($class);
  36     return $class;
  37 }
  38
  39 =item class2appclass($class);
  40
  41 Returns the appclass for class.
  42
  43     MyApp::C::Foo::Bar becomes MyApp
  44     My::App::C::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 =item class2classprefix($class);
  58
  59 Returns the classprefix for class.
  60
  61     MyApp::C::Foo::Bar becomes MyApp::C
  62     My::App::C::Foo::Bar becomes My::App::C
  63
  64 =cut
  65
  66 sub class2classprefix {
  67     my $class = shift || '';
  68     my $prefix;
  69     if ( $class =~ /^(.*::[MVC]|Model|View|Controller)?::.*$/ ) {
  70         $prefix = $1;
  71     }
  72     return $prefix;
  73 }
  74
  75 =item class2classsuffix($class);
  76
  77 Returns the classsuffix for class.
  78
  79     MyApp::C::Foo::Bar becomes C::Foo::Bar
  80
  81 =cut
  82
  83 sub class2classsuffix {
  84     my $class = shift || '';
  85     my $prefix = class2appclass($class) || '';
  86     $class =~ s/$prefix\:\://;
  87     return $class;
  88 }
  89
  90 =item class2env($class);
  91
  92 Returns the environment name for class.
  93
  94     MyApp becomes MYAPP
  95     My::App becomes MY_APP
  96
  97 =cut
  98
  99 sub class2env {
 100     my $class = shift || '';
 101     $class =~ s/\:\:/_/g;
 102     return uc($class);
 103 }
 104
 105 =item class2prefix( $class, $case );
 106
 107 Returns the prefix for class.
 108
 109     My::App::C::Foo::Bar becomes /foo/bar
 110
 111 =cut
 112
 113 sub class2prefix {
 114     my $class = shift || '';
 115     my $case  = shift || 0;
 116     my $prefix;
 117     if ( $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/ ) {
 118         $prefix = $case ? $2 : lc $2;
 119         $prefix =~ s/\:\:/\//g;
 120     }
 121     return $prefix;
 122 }
 123
 124 =item class2tempdir( $class [, $create ] );
 125
 126 Returns a tempdir for class. If create is true it will try to create the path.
 127
 128     My::App becomes /tmp/my/app
 129     My::App::C::Foo::Bar becomes /tmp/my/app/c/foo/bar
 130
 131 =cut
 132
 133 sub class2tempdir {
 134     my $class  = shift || '';
 135     my $create = shift || 0;
 136     my @parts = split '::', lc $class;
 137
 138     my $tmpdir = dir( File::Spec->tmpdir, @parts )->cleanup;
 139
 140     if ( $create && !-e $tmpdir ) {
 141
 142         eval { $tmpdir->mkpath };
 143
 144         if ($@) {
 145             Catalyst::Exception->throw(
 146                 message => qq/Couldn't create tmpdir '$tmpdir', "$@"/ );
 147         }
 148     }
 149
 150     return $tmpdir->stringify;
 151 }
 152
 153 =item home($class)
 154
 155 Returns home directory for given class.
 156
 157 =cut
 158
 159 sub home {
 160     my $name = shift;
 161     $name =~ s/\:\:/\//g;
 162     my $home = 0;
 163     if ( my $path = $INC{"$name.pm"} ) {
 164         $home = file($path)->absolute->dir;
 165         $name =~ /(\w+)$/;
 166         my $append = $1;
 167         my $subdir = dir($home)->subdir($append);
 168         for ( split '/', $name ) { $home = dir($home)->parent }
 169         if ( $home =~ /blib$/ ) { $home = dir($home)->parent }
 170         elsif (!-f file( $home, 'Makefile.PL' )
 171             && !-f file( $home, 'Build.PL' ) )
 172         {
 173             $home = $subdir;
 174         }
 175
 176         # clean up relative path:
 177         # MyApp/script/.. -> MyApp
 178         my ($lastdir) = $home->dir_list( -1, 1 );
 179         if ( $lastdir eq '..' ) {
 180             $home = dir($home)->parent->parent;
 181         }
 182     }
 183     return $home;
 184 }
 185
 186 =item prefix($class, $name);
 187
 188 Returns a prefixed action.
 189
 190     MyApp::C::Foo::Bar, yada becomes /foo/bar/yada
 191
 192 =cut
 193
 194 sub prefix {
 195     my ( $class, $name ) = @_;
 196     my $prefix = &class2prefix($class);
 197     $name = "$prefix/$name" if $prefix;
 198     return $name;
 199 }
 200
 201 =item request($request)
 202
 203 Returns a HTTP::Request object.
 204
 205 =cut
 206
 207 sub request {
 208     my $request = shift;
 209     unless ( ref $request ) {
 210         if ( $request =~ m/http/i ) {
 211             $request = URI->new($request)->canonical;
 212         }
 213         else {
 214             $request = URI->new( 'http://localhost' . $request )->canonical;
 215         }
 216     }
 217     unless ( ref $request eq 'HTTP::Request' ) {
 218         $request = HTTP::Request->new( 'GET', $request );
 219     }
 220     return $request;
 221 }
 222
 223 =back
 224
 225 =head1 AUTHOR
 226
 227 Sebastian Riedel, C<sri@cpan.org>
 228
 229 =head1 COPYRIGHT
 230
 231 This program is free software, you can redistribute it and/or modify it under
 232 the same terms as Perl itself.
 233
 234 =cut
 235
 236 1;