lib/Catalyst/Helper.pm

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