lib/Catalyst/Utils.pm

   1 package Catalyst::Utils;
   2
   3 use strict;
   4 use attributes ();
   5 use HTTP::Request;
   6 use Path::Class;
   7 use URI;
   8
   9 =head1 NAME
  10
  11 Catalyst::Utils - The Catalyst Utils
  12
  13 =head1 SYNOPSIS
  14
  15 See L<Catalyst>.
  16
  17 =head1 DESCRIPTION
  18
  19 =head1 METHODS
  20
  21 =over 4
  22
  23 =item attrs($coderef)
  24
  25 Returns attributes for coderef in a arrayref
  26
  27 =cut
  28
  29 sub attrs { attributes::get( $_[0] ) || [] }
  30
  31 =item class2appclass($class);
  32
  33 Returns the appclass for class.
  34
  35     MyApp::C::Foo::Bar becomes MyApp
  36     My::App::C::Foo::Bar becomes My::App
  37
  38 =cut
  39
  40 sub class2appclass {
  41     my $class = shift || '';
  42     my $appname = '';
  43     if ( $class =~ /^(.*)::([MVC]|Model|View|Controller)?::.*$/ ) {
  44         $appname = $1;
  45     }
  46     return $appname;
  47 }
  48
  49 =item class2classprefix($class);
  50
  51 Returns the classprefix for class.
  52
  53     MyApp::C::Foo::Bar becomes MyApp::C
  54     My::App::C::Foo::Bar becomes My::App::C
  55
  56 =cut
  57
  58 sub class2classprefix {
  59     my $class = shift || '';
  60     my $prefix;
  61     if ( $class =~ /^(.*::[MVC]|Model|View|Controller)?::.*$/ ) {
  62         $prefix = $1;
  63     }
  64     return $prefix;
  65 }
  66
  67 =item class2classsuffix($class);
  68
  69 Returns the classsuffix for 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 class2prefix( $class, $case );
  83
  84 Returns the prefix for class.
  85
  86     My::App::C::Foo::Bar becomes /foo/bar
  87
  88 =cut
  89
  90 sub class2prefix {
  91     my $class = shift || '';
  92     my $case  = shift || 0;
  93     my $prefix;
  94     if ( $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/ ) {
  95         $prefix = $case ? $2 : lc $2;
  96         $prefix =~ s/\:\:/\//g;
  97     }
  98     return $prefix;
  99 }
 100
 101 =item home($class)
 102
 103 Returns home directory for given class.
 104
 105 =cut
 106
 107 sub home {
 108     my $name = shift;
 109     $name =~ s/\:\:/\//g;
 110     my $home = 0;
 111     if ( my $path = $INC{"$name.pm"} ) {
 112         $home = file($path)->absolute->dir;
 113         $name =~ /(\w+)$/;
 114         my $append = $1;
 115         my $subdir = dir($home)->subdir($append);
 116         for ( split '/', $name ) { $home = dir($home)->parent }
 117         if ( $home =~ /blib$/ ) { $home = dir($home)->parent }
 118         elsif (!-f file( $home, 'Makefile.PL' )
 119             && !-f file( $home, 'Build.PL' ) )
 120         {
 121             $home = $subdir;
 122         }
 123         # clean up relative path:
 124         # MyApp/script/.. -> MyApp
 125         my ($lastdir) = $home->dir_list( -1, 1 );
 126         if ( $lastdir eq '..' ) {
 127             $home = dir($home)->parent->parent;
 128         }
 129     }
 130     return $home;
 131 }
 132
 133 =item prefix($class, $name);
 134
 135 Returns a prefixed action.
 136
 137     MyApp::C::Foo::Bar, yada becomes /foo/bar/yada
 138
 139 =cut
 140
 141 sub prefix {
 142     my ( $class, $name ) = @_;
 143     my $prefix = &class2prefix($class);
 144     $name = "$prefix/$name" if $prefix;
 145     return $name;
 146 }
 147
 148 =item reflect_actions($class);
 149
 150 Returns an arrayref containing all actions of a component class.
 151
 152 =cut
 153
 154 sub reflect_actions {
 155     my $class   = shift;
 156     my $actions = [];
 157     eval '$actions = $class->_action_cache';
 158     die qq/Couldn't reflect actions of component "$class", "$@"/ if $@;
 159     return $actions;
 160 }
 161
 162 =item request($string);
 163
 164 Returns an C<HTTP::Request> from a string.
 165
 166 =cut
 167
 168 sub request {
 169     my $request = shift;
 170
 171     unless ( ref $request ) {
 172
 173         if ( $request =~ m/http/i ) {
 174             $request = URI->new($request)->canonical;
 175         }
 176         else {
 177             $request = URI->new( 'http://localhost' . $request )->canonical;
 178         }
 179     }
 180
 181     unless ( ref $request eq 'HTTP::Request' ) {
 182         $request = HTTP::Request->new( 'GET', $request );
 183     }
 184
 185     return $request;
 186 }
 187
 188 =back
 189
 190 =head1 AUTHOR
 191
 192 Sebastian Riedel, C<sri@cpan.org>
 193
 194 =head1 COPYRIGHT
 195
 196 This program is free software, you can redistribute it and/or modify it under
 197 the same terms as Perl itself.
 198
 199 =cut
 200
 201 1;