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