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