6a052e6001d7f209c1deb762b5d1d3c2b7d12b90
[catagits/Catalyst-Devel.git] / lib / Catalyst / Helper.pm
1 package Catalyst::Helper;
2 use Moose;
3 use Config;
4 use File::Spec;
5 use File::Spec::Unix;
6 use File::Path;
7 use FindBin;
8 use IO::File;
9 use POSIX 'strftime';
10 use Template;
11 use Catalyst::Devel;
12 use Catalyst::Utils;
13 use Catalyst::Exception;
14 use Path::Class qw/dir file/;
15 use File::ShareDir qw/dist_dir/;
16 use namespace::autoclean;
17
18 my %cache;
19
20 =head1 NAME
21
22 Catalyst::Helper - Bootstrap a Catalyst application
23
24 =head1 SYNOPSIS
25
26   catalyst.pl <myappname>
27
28 =cut
29
30 sub get_sharedir_file {
31     my ($self, @filename) = @_;
32     my $dist_dir;
33     if (-d "inc/.author" && -f "lib/Catalyst/Helper.pm"
34             ) { # Can't use sharedir if we're in a checkout
35                 # this feels horrible, better ideas?
36         $dist_dir = 'share';
37     }
38     else {
39         $dist_dir = dist_dir('Catalyst-Devel');
40     }
41     my $file = file( $dist_dir, @filename);
42     Carp::confess("Cannot find $file") unless -r $file;
43     my $contents = $file->slurp;
44     return $contents;
45 }
46
47 # Do not touch this method, *EVER*, it is needed for back compat.
48 sub get_file {
49     my ( $self, $class, $file ) = @_;
50     unless ( $cache{$class} ) {
51         local $/;
52         $cache{$class} = eval "package $class; <DATA>";
53     }
54     my $data = $cache{$class};
55     Carp::confess("Could not get data from __DATA__ segment for $class")
56         unless $data;
57     my @files = split /^__(.+)__\r?\n/m, $data;
58     shift @files;
59     while (@files) {
60         my ( $name, $content ) = splice @files, 0, 2;
61         return $content if $name eq $file;
62     }
63     return 0;
64 }
65
66
67 sub mk_app {
68     my ( $self, $name ) = @_;
69
70     # Needs to be here for PAR
71     require Catalyst;
72
73     if ( $name =~ /[^\w:]/ || $name =~ /^\d/ || $name =~ /\b:\b|:{3,}/) {
74         warn "Error: Invalid application name.\n";
75         return 0;
76     }
77     $self->{name            } = $name;
78     $self->{dir             } = $name;
79     $self->{dir             } =~ s/\:\:/-/g;
80     $self->{script          } = dir( $self->{dir}, 'script' );
81     $self->{appprefix       } = Catalyst::Utils::appprefix($name);
82     $self->{appenv          } = Catalyst::Utils::class2env($name);
83     $self->{startperl       } = -r '/usr/bin/env'
84                                 ? '#!/usr/bin/env perl'
85                                 : "#!$Config{perlpath} -w";
86     $self->{scriptgen       } = $Catalyst::Devel::CATALYST_SCRIPT_GEN;
87     $self->{catalyst_version} = $Catalyst::VERSION;
88     $self->{author          } = $self->{author} = $ENV{'AUTHOR'}
89       || eval { @{ [ getpwuid($<) ] }[6] }
90       || 'Catalyst developer';
91
92     my $gen_scripts  = ( $self->{makefile} ) ? 0 : 1;
93     my $gen_makefile = ( $self->{scripts} )  ? 0 : 1;
94     my $gen_app = ( $self->{scripts} || $self->{makefile} ) ? 0 : 1;
95
96     if ($gen_app) {
97         for ( qw/ _mk_dirs _mk_config _mk_appclass _mk_rootclass _mk_readme
98               _mk_changes _mk_apptest _mk_images _mk_favicon/ ) {
99             
100             $self->$_;
101         }
102     }
103     if ($gen_makefile) {
104         $self->_mk_makefile;
105     }
106     if ($gen_scripts) {
107         for ( qw/ _mk_cgi _mk_fastcgi _mk_server 
108                   _mk_test _mk_create _mk_information
109         / ) {
110               $self->$_;
111         }
112     }
113     return $self->{dir};
114 }
115
116 ## not much of this can really be changed, mk_compclass must be left for 
117 ## backcompat
118 sub mk_component {
119     my $self = shift;
120     my $app  = shift;
121     $self->{app} = $app;
122     $self->{author} = $self->{author} = $ENV{'AUTHOR'}
123       || eval { @{ [ getpwuid($<) ] }[6] }
124       || 'A clever guy';
125     $self->{base} ||= dir( $FindBin::Bin, '..' );
126     unless ( $_[0] =~ /^(?:model|view|controller)$/i ) {
127         my $helper = shift;
128         my @args   = @_;
129         my $class  = "Catalyst::Helper::$helper";
130         eval "require $class";
131
132         if ($@) {
133             Catalyst::Exception->throw(
134                 message => qq/Couldn't load helper "$class", "$@"/ );
135         }
136
137         if ( $class->can('mk_stuff') ) {
138             return 1 unless $class->mk_stuff( $self, @args );
139         }
140     }
141     else {
142         my $type   = shift;
143         my $name   = shift || "Missing name for model/view/controller";
144         my $helper = shift;
145         my @args   = @_;
146        return 0 if $name =~ /[^\w\:]/;
147         $type              = lc $type;
148         $self->{long_type} = ucfirst $type;
149         $type              = 'M' if $type =~ /model/i;
150         $type              = 'V' if $type =~ /view/i;
151         $type              = 'C' if $type =~ /controller/i;
152         my $appdir = dir( split /\:\:/, $app );
153         my $test_path =
154           dir( $self->{base}, 'lib', $appdir, 'C' );
155         $type = $self->{long_type} unless -d $test_path;
156         $self->{type}  = $type;
157         $self->{name}  = $name;
158         $self->{class} = "$app\::$type\::$name";
159
160         # Class
161         my $path =
162           dir( $self->{base}, 'lib', $appdir, $type );
163         my $file = $name;
164         if ( $name =~ /\:/ ) {
165             my @path = split /\:\:/, $name;
166             $file = pop @path;
167             $path = dir( $path, @path );
168         }
169         $self->mk_dir($path);
170         $file = file( $path, "$file.pm" );
171         $self->{file} = $file;
172
173         # Test
174         $self->{test_dir} = dir( $self->{base}, 't' );
175         $self->{test}     = $self->next_test;
176
177         # Helper
178         if ($helper) {
179             my $comp  = $self->{long_type};
180             my $class = "Catalyst::Helper::$comp\::$helper";
181             eval "require $class";
182
183             if ($@) {
184                 Catalyst::Exception->throw(
185                     message => qq/Couldn't load helper "$class", "$@"/ );
186             }
187
188             ## must be left for back compat! ###################################
189             if ( $class->can('mk_compclass') ) {
190                 return 1 unless $class->mk_compclass( $self, @args );
191             }
192             else { return 1 unless $self->_mk_compclass }
193
194             if ( $class->can('mk_comptest') ) {
195                 $class->mk_comptest( $self, @args );
196             }
197             else { $self->_mk_comptest }
198             ####################################################################
199         }
200
201         # Fallback
202         else {
203             return 1 unless $self->_mk_compclass;
204             $self->_mk_comptest;
205         }
206     }
207     return 1;
208 }
209
210 sub mk_dir {
211     my ( $self, $dir ) = @_;
212     if ( -d $dir ) {
213         print qq/ exists "$dir"\n/;
214         return 0;
215     }
216     if ( mkpath [$dir] ) {
217         print qq/created "$dir"\n/;
218         return 1;
219     }
220
221     Catalyst::Exception->throw( message => qq/Couldn't create "$dir", "$!"/ );
222 }
223
224 sub mk_file {
225     my ( $self, $file, $content ) = @_;
226     if ( -e $file && -s _ ) {
227         print qq/ exists "$file"\n/;
228         return 0
229           unless ( $self->{'.newfiles'}
230             || $self->{scripts}
231             || $self->{makefile} );
232         if ( $self->{'.newfiles'} ) {
233             if ( my $f = IO::File->new("< $file") ) {
234                 my $oldcontent = join( '', (<$f>) );
235                 return 0 if $content eq $oldcontent;
236             }
237             $file .= '.new';
238         }
239     }
240     
241     if ( my $f = IO::File->new("> $file") ) {
242         binmode $f;
243         print $f $content;
244         print qq/created "$file"\n/;
245         return 1;
246     }
247
248     Catalyst::Exception->throw( message => qq/Couldn't create "$file", "$!"/ );
249 }
250
251 sub next_test {
252     my ( $self, $tname ) = @_;
253     if ($tname) { $tname = "$tname.t" }
254     else {
255         my $name   = $self->{name};
256         my $prefix = $name;
257         $prefix =~ s/::/-/g;
258         $prefix         = $prefix;
259         $tname          = $prefix . '.t';
260         $self->{prefix} = $prefix;
261         $prefix         = lc $prefix;
262         $prefix =~ s/-/\//g;
263         $self->{uri} = "/$prefix";
264     }
265     my $dir  = $self->{test_dir};
266     my $type = lc $self->{type};
267     $self->mk_dir($dir);
268     return file( $dir, "$type\_$tname" );
269 }
270
271 # Do not touch this method, *EVER*, it is needed for back compat.
272 ## addendum: we had to split this method so we could have backwards
273 ## compatability.  otherwise, we'd have no way to pass stuff from __DATA__
274
275 sub render_file {
276     my ( $self, $file, $path, $vars ) = @_;
277     my $template = $self->get_file( ( caller(0) )[0], $file );
278     $self->render_file_contents($template, $path, $vars);
279 }
280
281 sub render_sharedir_file {
282     my ( $self, $file, $path, $vars ) = @_;
283     my $template = $self->get_sharedir_file( $file );
284     die("Cannot get template from $file for $self\n") unless $template;
285     $self->render_file_contents($template, $path, $vars);
286 }
287
288 sub render_file_contents {
289     my ( $self, $template, $path, $vars ) = @_;
290     $vars ||= {};
291     my $t = Template->new;
292     return 0 unless $template;
293     my $output;
294     $t->process( \$template, { %{$self}, %$vars }, \$output )
295       || Catalyst::Exception->throw(
296         message => qq/Couldn't process "$template", / . $t->error() );
297     $self->mk_file( $path, $output );
298 }
299
300 sub _mk_information {
301     my $self = shift;
302     print qq/Change to application directory and Run "perl Makefile.PL" to make sure your install is complete\n/;
303 }
304
305 sub _mk_dirs {
306     my $self = shift;
307     $self->mk_dir( $self->{dir} );
308     $self->mk_dir( $self->{script} );
309     $self->{lib} = dir( $self->{dir}, 'lib' );
310     $self->mk_dir( $self->{lib} );
311     $self->{root} = dir( $self->{dir}, 'root' );
312     $self->mk_dir( $self->{root} );
313     $self->{static} = dir( $self->{root}, 'static' );
314     $self->mk_dir( $self->{static} );
315     $self->{images} = dir( $self->{static}, 'images' );
316     $self->mk_dir( $self->{images} );
317     $self->{t} = dir( $self->{dir}, 't' );
318     $self->mk_dir( $self->{t} );
319
320     $self->{class} = dir( split( /\:\:/, $self->{name} ) );
321     $self->{mod} = dir( $self->{lib}, $self->{class} );
322     $self->mk_dir( $self->{mod} );
323
324     if ( $self->{short} ) {
325         $self->{m} = dir( $self->{mod}, 'M' );
326         $self->mk_dir( $self->{m} );
327         $self->{v} = dir( $self->{mod}, 'V' );
328         $self->mk_dir( $self->{v} );
329         $self->{c} = dir( $self->{mod}, 'C' );
330         $self->mk_dir( $self->{c} );
331     }
332     else {
333         $self->{m} = dir( $self->{mod}, 'Model' );
334         $self->mk_dir( $self->{m} );
335         $self->{v} = dir( $self->{mod}, 'View' );
336         $self->mk_dir( $self->{v} );
337         $self->{c} = dir( $self->{mod}, 'Controller' );
338         $self->mk_dir( $self->{c} );
339     }
340     my $name = $self->{name};
341     $self->{rootname} =
342       $self->{short} ? "$name\::C::Root" : "$name\::Controller::Root";
343     $self->{base} = dir( $self->{dir} )->absolute;
344 }
345
346 sub _mk_appclass {
347     my $self = shift;
348     my $mod  = $self->{mod};
349     $self->render_sharedir_file( file('lib', 'MyApp.pm.tt'), "$mod.pm" );
350 }
351
352 sub _mk_rootclass {
353     my $self = shift;
354     $self->render_sharedir_file( file('lib', 'MyApp', 'Controller', 'Root.pm.tt'),
355         file( $self->{c}, "Root.pm" ) );
356 }
357
358 sub _mk_makefile {
359     my $self = shift;
360     $self->{path} = dir( 'lib', split( '::', $self->{name} ) );
361     $self->{path} .= '.pm';
362     my $dir = $self->{dir};
363     $self->render_sharedir_file( 'Makefile.PL.tt', file($dir, "Makefile.PL") );
364
365     if ( $self->{makefile} ) {
366
367         # deprecate the old Build.PL file when regenerating Makefile.PL
368         $self->_deprecate_file(
369             file( $self->{dir}, 'Build.PL' ) );
370     }
371 }
372
373 sub _mk_config {
374     my $self      = shift;
375     my $dir       = $self->{dir};
376     my $appprefix = $self->{appprefix};
377     $self->render_sharedir_file( 'myapp.conf.tt',
378         file( $dir, "$appprefix.conf" ) );
379 }
380
381 sub _mk_readme {
382     my $self = shift;
383     my $dir  = $self->{dir};
384     $self->render_sharedir_file( 'README.tt', file($dir, "README") );
385 }
386
387 sub _mk_changes {
388     my $self = shift;
389     my $dir  = $self->{dir};
390     my $time = strftime('%Y-%m-%d %H:%M:%S', localtime time);
391     $self->render_sharedir_file( 'Changes.tt', file($dir, "Changes"), { time => $time } );
392 }
393
394 sub _mk_apptest {
395     my $self = shift;
396     my $t    = $self->{t};
397     $self->render_sharedir_file( file('t', '01app.t.tt'),         file($t, "01app.t") );
398     $self->render_sharedir_file( file('t', '02pod.t.tt'),         file($t, "02pod.t") );
399     $self->render_sharedir_file( file('t', '03podcoverage.t.tt'), file($t, "03podcoverage.t") );
400 }
401
402 sub _mk_cgi {
403     my $self      = shift;
404     my $script    = $self->{script};
405     my $appprefix = $self->{appprefix};
406     $self->render_sharedir_file( file('script', 'myapp_cgi.pl.tt'), file($script,"$appprefix\_cgi.pl") );
407     chmod 0700, file($script,"$appprefix\_cgi.pl");
408 }
409
410 sub _mk_fastcgi {
411     my $self      = shift;
412     my $script    = $self->{script};
413     my $appprefix = $self->{appprefix};
414     $self->render_sharedir_file( file('script', 'myapp_fastcgi.pl.tt'), file($script, "$appprefix\_fastcgi.pl") );
415     chmod 0700, file($script, "$appprefix\_fastcgi.pl");
416 }
417
418 sub _mk_server {
419     my $self      = shift;
420     my $script    = $self->{script};
421     my $appprefix = $self->{appprefix};
422     $self->render_sharedir_file( file('script', 'myapp_server.pl.tt'), file($script, "$appprefix\_server.pl") );
423     chmod 0700, file($script, "$appprefix\_server.pl");
424 }
425
426 sub _mk_test {
427     my $self      = shift;
428     my $script    = $self->{script};
429     my $appprefix = $self->{appprefix};
430     $self->render_sharedir_file( file('script', 'myapp_test.pl.tt'), file($script, "$appprefix\_test.pl") );
431     chmod 0700, file($script, "$appprefix\_test.pl");
432 }
433
434 sub _mk_create {
435     my $self      = shift;
436     my $script    = $self->{script};
437     my $appprefix = $self->{appprefix};
438     $self->render_sharedir_file( file('script', 'myapp_create.pl.tt'), file($script, "$appprefix\_create.pl") );
439     chmod 0700, file($script, "$appprefix\_create.pl");
440 }
441
442 sub _mk_compclass {
443     my $self = shift;
444     my $file = $self->{file};
445     return $self->render_sharedir_file( file('lib', 'Helper', 'compclass.pm.tt'), $file );
446 }
447
448 sub _mk_comptest {
449     my $self = shift;
450     my $test = $self->{test};
451     $self->render_sharedir_file( file('t', 'comptest.tt'), $test );  ## wtf do i rename this to?
452 }
453
454 sub _mk_images {
455     my $self   = shift;
456     my $images = $self->{images};
457     my @images =
458       qw/catalyst_logo btn_120x50_built btn_120x50_built_shadow
459       btn_120x50_powered btn_120x50_powered_shadow btn_88x31_built
460       btn_88x31_built_shadow btn_88x31_powered btn_88x31_powered_shadow/;
461     for my $name (@images) {
462         my $image = $self->get_sharedir_file("root", "static", "images", "$name.png.bin");
463         $self->mk_file( file( $images, "$name.png" ), $image );
464     }
465 }
466
467 sub _mk_favicon {
468     my $self    = shift;
469     my $root    = $self->{root};
470     my $favicon = $self->get_sharedir_file( 'root', 'favicon.ico.bin' );
471     my $dest = dir( $root, "favicon.ico" );
472     $self->mk_file( $dest, $favicon );
473
474 }
475
476 sub _deprecate_file {
477     my ( $self, $file ) = @_;
478     if ( -e $file ) {
479         my ($f, $oldcontent);
480         if ( $f = IO::File->new("< $file") ) {
481             $oldcontent = join( '', (<$f>) );
482         }
483         my $newfile = $file . '.deprecated';
484         if ( $f = IO::File->new("> $newfile") ) {
485             binmode $f;
486             print $f $oldcontent;
487             print qq/created "$newfile"\n/;
488             unlink $file;
489             print qq/removed "$file"\n/;
490             return 1;
491         }
492         Catalyst::Exception->throw(
493             message => qq/Couldn't create "$file", "$!"/ );
494     }
495 }
496
497 =head1 DESCRIPTION
498
499 This module is used by B<catalyst.pl> to create a set of scripts for a
500 new catalyst application. The scripts each contain documentation and
501 will output help on how to use them if called incorrectly or in some
502 cases, with no arguments.
503
504 It also provides some useful methods for a Helper module to call when
505 creating a component. See L</METHODS>.
506
507 =head1 SCRIPTS
508
509 =head2 _create.pl
510
511 Used to create new components for a catalyst application at the
512 development stage.
513
514 =head2 _server.pl
515
516 The catalyst test server, starts an HTTPD which outputs debugging to
517 the terminal.
518
519 =head2 _test.pl
520
521 A script for running tests from the command-line.
522
523 =head2 _cgi.pl
524
525 Run your application as a CGI.
526
527 =head2 _fastcgi.pl
528
529 Run the application as a fastcgi app. Either by hand, or call this
530 from FastCgiServer in your http server config.
531
532 =head1 HELPERS
533
534 The L</_create.pl> script creates application components using Helper
535 modules. The Catalyst team provides a good number of Helper modules
536 for you to use. You can also add your own.
537
538 Helpers are classes that provide two methods.
539
540     * mk_compclass - creates the Component class
541     * mk_comptest  - creates the Component test
542
543 So when you call C<scripts/myapp_create.pl view MyView TT>, create
544 will try to execute Catalyst::Helper::View::TT->mk_compclass and
545 Catalyst::Helper::View::TT->mk_comptest.
546
547 See L<Catalyst::Helper::View::TT> and
548 L<Catalyst::Helper::Model::DBIC::Schema> for examples.
549
550 All helper classes should be under one of the following namespaces.
551
552     Catalyst::Helper::Model::
553     Catalyst::Helper::View::
554     Catalyst::Helper::Controller::
555
556 =head2 COMMON HELPERS
557
558 =over
559
560 =item *
561
562 L<Catalyst::Helper::Model::DBIC::Schema> - DBIx::Class models
563
564 =item *
565
566 L<Catalyst::Helper::View::TT> - Template Toolkit view
567
568 =item *
569
570 L<Catalyst::Helper::Model::LDAP>
571
572 =item *
573
574 L<Catalyst::Helper::Model::Adaptor> - wrap any class into a Catalyst model
575
576 =back
577
578 =head3 NOTE
579
580 The helpers will read author name from /etc/passwd by default.
581 To override, please export the AUTHOR variable.
582
583 =head1 METHODS
584
585 =head2 mk_compclass
586
587 This method in your Helper module is called with C<$helper>
588 which is a L<Catalyst::Helper> object, and whichever other arguments
589 the user added to the command-line. You can use the $helper to call methods
590 described below.
591
592 If the Helper module does not contain a C<mk_compclass> method, it
593 will fall back to calling L</render_file>, with an argument of
594 C<compclass>.
595
596 =head2 mk_comptest
597
598 This method in your Helper module is called with C<$helper>
599 which is a L<Catalyst::Helper> object, and whichever other arguments
600 the user added to the command-line. You can use the $helper to call methods
601 described below.
602
603 If the Helper module does not contain a C<mk_compclass> method, it
604 will fall back to calling L</render_file>, with an argument of
605 C<comptest>.
606
607 =head2 mk_stuff
608
609 This method is called if the user does not supply any of the usual
610 component types C<view>, C<controller>, C<model>. It is passed the
611 C<$helper> object (an instance of L<Catalyst::Helper>), and any other
612 arguments the user typed.
613
614 There is no fallback for this method.
615
616 =head1 INTERNAL METHODS
617
618 These are the methods that the Helper classes can call on the
619 <$helper> object passed to them.
620
621 =head2 render_file ($file, $path, $vars)
622
623 Render and create a file from a template in DATA using Template
624 Toolkit. $file is the relevent chunk of the __DATA__ section, $path is
625 the path to the file and $vars is the hashref as expected by
626 L<Template Toolkit|Template>.
627
628 =head2 get_file ($class, $file)
629
630 Fetch file contents from the DATA section. This is used internally by
631 L</render_file>.  $class is the name of the class to get the DATA
632 section from.  __PACKAGE__ or ( caller(0) )[0] might be sensible
633 values for this.
634
635 =head2 mk_app
636
637 Create the main application skeleton. This is called by L<catalyst.pl>.
638
639 =head2 mk_component ($app)
640
641 This method is called by L<create.pl> to make new components
642 for your application.
643
644 =head2 mk_dir ($path)
645
646 Surprisingly, this function makes a directory.
647
648 =head2 mk_file ($file, $content)
649
650 Writes content to a file. Called by L</render_file>.
651
652 =head2 next_test ($test_name)
653
654 Calculates the name of the next numbered test file and returns it.
655 Don't give the number or the .t suffix for the test name.
656
657 =cut
658
659 =head2 get_sharedir_file
660
661 Method for getting a file out of share/
662
663 =cut
664
665 =head2 render_file_contents
666
667 Process a L<Template::Toolkit> template.
668
669 =cut
670
671 =head2 render_sharedir_file
672
673 Render a template/image file from our share directory
674
675 =cut
676
677 =head1 NOTE
678
679 The helpers will read author name from /etc/passwd by default.
680 To override, please export the AUTHOR variable.
681
682 =head1 SEE ALSO
683
684 L<Catalyst::Manual>, L<Catalyst::Test>, L<Catalyst::Request>,
685 L<Catalyst::Response>, L<Catalyst>
686
687 =head1 AUTHORS
688
689 Catalyst Contributors, see Catalyst.pm
690
691 =head1 LICENSE
692
693 This library is free software. You can redistribute it and/or modify
694 it under the same terms as Perl itself.
695
696 =cut
697
698 1;
699