script/dancer - metacpan.org

#!/usr/bin/perl

use strict;
use warnings;
use Dancer::Template::Simple;
use File::Basename 'basename', 'dirname';
use File::Spec::Functions;
use Getopt::Long;
use Dancer::Renderer;
use IO::Socket::INET;
use IO::Select;
use constant FILE => 1;

# options
my $help = 0;
my $name = undef;
my $path = '.';

sub templates($);
sub app_tree($);
sub create_node($;$);

GetOptions(
    "h|help"          => \$help,
    "a|application=s" => \$name,
    "p|path=s"        => \$path,
);

# main
my $PERL_INTERPRETER = -r '/usr/bin/env' ? '#!/usr/bin/env perl' : "#!$^X";

usage() and exit(0) if $help;
usage() if not defined $name;
usage() unless -d $path && -w $path;

validate_app_name($name);

my $DO_OVERWRITE_ALL = 0;
my $DANCER_APP_DIR   = get_application_path($path, $name);
my $DANCER_SCRIPT    = get_script_path($name);
my ($LIB_FILE, $LIB_PATH) = get_lib_path($name);
my $AUTO_RELOAD = eval "require Module::Refresh and require Clone" ? 1 : 0;

require Dancer;
my $DANCER_VERSION   = $Dancer::VERSION;

version_check();
safe_mkdir($DANCER_APP_DIR);
create_node( app_tree($name), $DANCER_APP_DIR );

# subs

sub usage {
    print <<'ENDUSAGE';
Dancer Helper - bootstrap a Dancer application

Usage:
    dancer [options] -a <appname>

    options are following :
    -h, --help            : display this help message
    -a, --application     : name of the application to create
    -p, --path            : existing path where to create the application tree
                            (current directory if not specified, must be writable)

ENDUSAGE
    exit 0;
}

sub validate_app_name {
    my $name = shift;
    if ($name =~ /[^\w:]/ || $name =~ /^\d/ || $name =~ /\b:\b|:{3,}/) {
        warn "Error: Invalid application name.\n";
        usage();
    }
}

sub get_application_path {
    my ($path, $app_name) = @_;
    catdir($path, _dash_name($app_name));
}

sub get_lib_path {
    my $name = shift;
    my @lib_path = split('::', $name);
    my ($lib_file, $lib_path) = (pop @lib_path) . ".pm";
    $lib_path = join('/', @lib_path);
    return ($lib_file, $lib_path);
}

sub get_script_path {
    _dash_name(shift);
}

sub _dash_name {
    my $name = shift;
    $name =~ s/\:\:/-/g;
    $name;
}

sub create_node($;$) {
    my ($node, $root) = @_;
    $root ||= '.';

    my $templates = templates($name);

    while ( my ($path, $content) = each %$node ) {
        $path = catfile($root, $path);

        if (ref($content) eq 'HASH') {
            safe_mkdir($path);
            create_node($content, $path);
        } elsif (ref($content) eq 'CODE') {
            # The content is a coderef, which, given the path to the file it
            # should create, will do the appropriate thing:
            $content->($path);
       } else {
            my $file = basename($path);
            my $dir  = dirname($path);
            my $ex = ($file =~ s/^\+//); # look for '+' flag (executable)
            my $template = $templates->{$file};

            $path = catfile($dir, $file); # rebuild the path without the '+' flag
            write_file($path, $template, {appdir => File::Spec->rel2abs($DANCER_APP_DIR)});
            chmod 0755, $path if $ex;
        }
    }
}

sub app_tree($) {
    my ($appname) = @_;

    return {
        "+$DANCER_SCRIPT.pl" => FILE,
        "Makefile.PL"        => FILE,
        lib                  => {
         $LIB_PATH => {
            $LIB_FILE => FILE,}
        },
        "config.yml"         => FILE,
        "environments"       => {
            "development.yml" => FILE,
            "production.yml"  => FILE,
        },
        "views" => {
            "layouts"  => {"main.tt" => FILE,},
            "index.tt" => FILE,
        },
        "public" => {
            "+dispatch.cgi"  => FILE,
            "+dispatch.fcgi" => FILE,
            "404.html"       => FILE,
            "500.html"       => FILE,
            "css"            => {
                "style.css" => FILE,
                "error.css" => FILE,
            },
            "images"      => {},
            "favicon.ico" => \&write_favicon,
        },
        "t" => {
            "001_base.t"        => FILE,
            "002_index_route.t" => FILE,
        },
    };
}


sub safe_mkdir {
    my ($dir) = @_;
    if (not -d $dir) {
        print "+ $dir\n";
        mkdir $dir;
    }
    else {
        print "  $dir\n";
    }
}

sub write_file {
    my ($path, $template, $vars) = @_;
    die "no template found for $path" unless defined $template;

    $vars->{dancer_version} = $DANCER_VERSION;

    # if file already exists, ask for confirmation
    if (-f $path && (not $DO_OVERWRITE_ALL)) {
        print "! $path exists, overwrite? [N/y/a]: ";
        my $res = <STDIN>; chomp($res);
        $DO_OVERWRITE_ALL = 1 if $res eq 'a';
        return 0 unless ($res eq 'y') or ($res eq 'a');
    }

    my $fh;
    my $content = process_template($template, $vars);
    print "+ $path\n";
    open $fh, '>', $path or die "unable to open file `$path' for writing: $!";
    print $fh $content;
    close $fh;
}

sub process_template {
    my ($template, $tokens) = @_;
    my $engine = Dancer::Template::Simple->new;
    $engine->{start_tag} = '[%';
    $engine->{stop_tag} = '%]';
    return $engine->render(\$template, $tokens);
}

# Given a path, get the favicon.ico file content from the __DATA__ section and
# write it to that file.
sub write_favicon {
    my $path = shift;
    open(my $fh, '>', $path)
      or warn "Failed to write favicon to $path - $!" and return;
    my $data = do { local $/; <DATA> };
    print {$fh} unpack 'u*', $data;
    close $fh;
}

sub templates($) {
    my $appname = shift;
    return {

'Makefile.PL' =>
"use strict;
use warnings;
use ExtUtils::MakeMaker;

WriteMakefile(
    NAME                => '$appname',
    AUTHOR              => q{YOUR NAME <youremail\@example.com>},
    VERSION_FROM        => 'lib/$appname.pm',
    ABSTRACT            => 'YOUR APPLICATION ABSTRACT',
    (\$ExtUtils::MakeMaker::VERSION >= 6.3002
      ? ('LICENSE'=> 'perl')
      : ()),
    PL_FILES            => {},
    PREREQ_PM => {
        'Test::More' => 0,
        'YAML'       => 0,
        'Dancer'     => [% dancer_version %],
    },
    dist                => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
    clean               => { FILES => '$appname-*' },
);
",
'index.tt'  => '<h2>It Works!</h2>

<p>
I\'m in <code>[%appdir%]/views/index.tt</code>
</p>
',
'main.tt'   =>
    Dancer::Renderer->html_page($appname, '<% content %>'),

"dispatch.cgi" =>
"$PERL_INTERPRETER
use Plack::Runner;
use Dancer ':syntax';
my \$psgi = path(dirname(__FILE__), '..', '$DANCER_SCRIPT.pl');
Plack::Runner->run(\$psgi);
",

"dispatch.fcgi" =>
"$PERL_INTERPRETER
use Plack::Handler::FCGI;
use Dancer ':syntax';

my \$psgi = path(dirname(__FILE__), '..', '$DANCER_SCRIPT.pl');
my \$app = do(\$psgi);
my \$server = Plack::Handler::FCGI->new(nproc  => 5, detach => 1);
\$server->run(\$app);
",

"$DANCER_SCRIPT.pl" =>

"$PERL_INTERPRETER
use Dancer;
use lib path(dirname(__FILE__), 'lib');
load_app '$appname';
dance;
",

"$LIB_FILE" =>

"package $appname;
use Dancer ':syntax';

our \$VERSION = '0.1';

get '/' => sub {
    template 'index';
};

true;
",

'style.css' =>

'body {
    font-family: Lucida,sans-serif;
    color: #eee;
    background-color: #1f1b1a;
}

#content {
    color: #000;
    background-color: #eee;
    padding: 1em;
    margin: 1em;
    padding-top: 0.5em;
}

a {
    color: #a5ec02;
}

h1 {
    color: #a5ec02;
}

footer {
    border-top: 1px solid #aba29c;
    margin-top: 2em;
    padding-top: 1em;
    font-size: 10px;
    color: #ddd;
}

pre {
    font-family: \"lucida console\",\"monaco\",\"andale mono\",\"bitstream vera sans mono\",\"consolas\",monospace;
}

',

"error.css" =>

"body {
    font-family: Lucida,sans-serif;
}

h1 {
    color: #AA0000;
    border-bottom: 1px solid #444;
}

h2 { color: #444; }

pre {
    font-family: \"lucida console\",\"monaco\",\"andale mono\",\"bitstream vera sans mono\",\"consolas\",monospace;
    font-size: 12px;
    border-left: 2px solid #777;
    padding-left: 1em;
}

footer {
    font-size: 10px;
}

span.key {
    color: #449;
    font-weight: bold;
    width: 120px;
    display: inline;
}

span.value {
    color: #494;
}

/* these are for the message boxes */

pre.content {
    background-color: #eee;
    color: #000;
    padding: 1em;
    margin: 0;
    border: 1px solid #aaa;
    border-top: 0;
    margin-bottom: 1em;
}

div.title {
    font-family: \"lucida console\",\"monaco\",\"andale mono\",\"bitstream vera sans mono\",\"consolas\",monospace;
    font-size: 12px;
    background-color: #aaa;
    color: #444;
    font-weight: bold;
    padding: 3px;
    padding-left: 10px;
}

pre.content span.nu {
    color: #889;
    margin-right: 10px;
}

pre.error {
    background: #334;
    color: #ccd;
    padding: 1em;
    border-top: 1px solid #000;
    border-left: 1px solid #000;
    border-right: 1px solid #eee;
    border-bottom: 1px solid #eee;
}

",

"404.html" =>
    Dancer::Renderer->html_page(
        "Error 404",
        '<h2>Page Not Found</h2><p>Sorry, this is the void.</p>',
        'error'),

"500.html" =>
    Dancer::Renderer->html_page(
        "Error 500",
        '<h2>Internal Server Error</h2>'
                 . '<p>Wooops, something went wrong</p>',
        'error'),

'config.yml' =>

"layout: \"main\"
logger: \"file\"
appname: \"$name\"

",

'development.yml' =>
"log: \"core\"
warnings: 1
show_errors: 1

# auto_reload is a development feature
# you should enable it by yourself if you want it
# Module::Refresh is needed
auto_reload: 0
",

'production.yml' =>
'log: "warning"
warnings: 0
show_errors: 0
route_cache: 1
# never enable auto_reload in production
auto_reload: 0

',

"001_base.t" =>
"use Test::More tests => 1;
use strict;
use warnings;

use_ok '$appname';
",

"002_index_route.t" =>
"use Test::More tests => 3;
use strict;
use warnings;

# the order is important
use $appname;
use Dancer::Test;

route_exists [GET => '/'], 'a route handler is defined for /';
response_status_is ['GET' => '/'], 200, 'response status is 200 for /';
response_content_like [GET => '/'], qr/It Works.*I'm in.*index.tt/s,
    'content looks OK for /';
",

    };
}

# LWP, File::Fetch and other high level interfaces are not avaiable to us in perl 5.8.5.

sub send_http_request {
    my $url = shift;
    my ($host, $path);

    if ($url =~ /https?:\/\/([^\/]+)(.*)/) {
        ($host, $path) = ($1, $2);
    }
    else {
        die "unknown url: $url";
    }

    my $timeout = 2;
    my $latest_version;

    my $sock = IO::Socket::INET->new(PeerAddr => $host, PeerPort => 'http(80)', Proto => 'tcp');
    return undef if not defined $sock;

    my $req = "GET $path HTTP/1.0\x0d\x0aHost: $host\x0d\x0a\x0d\x0a";

    $sock->send( $req );
    my $select = IO::Select->new( $sock );

    my $resp;
    while ( $select->can_read( $timeout ) ) {
        $resp = '';
        my $ret = $sock->sysread( $resp, 4096, length($resp) );
        $select->remove( $sock );
    }
    my @headers = split /\n/, $resp;
    my $status_line = shift @headers;

    # redirection handling
    if ($status_line =~ /HTTP\/.*30[12]/) {
        for my $header (@headers) {
            if ($header =~ /Location: (\S+).*$/) {
                my $path = $1;
                if ($path =~ /^http:/) {
                    return send_http_request($path);
                }
                else {
                    return send_http_request("http://${host}${path}");
                }
            }
            last if not $header;
        }
    }
    return $resp;
}

sub version_check {
    my $latest_version = 0;
    require Dancer;

    my $resp = send_http_request('http://search.cpan.org/dist/Dancer/CHANGES');
    if ($resp && $resp =~ m/Dancer (\d\.\d+)/) {
        $latest_version = $1;
    }

    if ($latest_version > $DANCER_VERSION) {
        print qq|
The latest Dancer release is $latest_version, you are currently using $DANCER_VERSION.
Please check http://search.cpan.org/dist/Dancer/ for updates.

|;
    }
}

=pod

=head1 NAME

dancer - helper script to create new Dancer applications

=head1 DESCRIPTION

Helper script for providing a bootstrapping method to quickly and easily create
the framework for a new Dancer application.

=head1 USAGE

dancer [options] -a <appname>

=over

=item -h, --help            : print what you are currently reading
=item -a, --application     : the name of your application
=item -p, --path            : the path where to create your application
                              (current directory if not specified)

=back

=head1 EXAMPLE

Here is an application created with dancer:

    $ dancer -a mywebapp
    + mywebapp
    + mywebapp/config.yml
    + mywebapp/views
    + mywebapp/views/layouts
    + mywebapp/views/layouts/main.tt
    + mywebapp/views/index.tt
    + mywebapp/environments
    + mywebapp/environments/production.yml
    + mywebapp/environments/development.yml
    + mywebapp/mywebapp.pm
    + mywebapp/mywebapp.pl
    + mywebapp/favicon.ico

The application is ready to serve:

    $ cd mywebapp
    $ ./mywebapp.pl
    >> Listening on 127.0.0.1:3000
    == Entering the development dance floor ...

=head1 AUTHOR

This script has been written by Sebastien Deseille
<sebastien.deseille@gmail.com> and Alexis Sukrieh
<sukria@cpan.org>.

=head1 SOURCE CODE

See L<Dancer> for more information.

=head1 LICENSE

This module is free software and is published under the same
terms as Perl itself.

=cut

# The following ugly data is the default favicon.ico file to write; uuencoded
# using pack 'u*'.
__DATA__
M```!``$`$!````$`"`!H!0``%@```"@````0````(`````$`"```````````
M``````````````````````!D12\`:4LV`&I,-P!K3CD`;$XY`&Q/.@!M3SH`
M;5`Z`&U0.P!N4#L`;5`\`&U1.P!N43L`;E$\`&Y1/0!N4CT`;U(]`&]2/@!O
M4SX`<E9!`')60@!S6$0`=UQ(`'E>2@!Y8$P`>F!-`'QB3@!]8U``?611`(!G
M5`"`:%4`A&M:`(9M7`"+=&,`C79E`)!Z:0"2?6P`KIZ2`+"AE0"\L*8`P[>M
M`,S"NP#/Q[\`T\O$`-7-QP#P[^L`]_;U`/K[^0#]_OT`____````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````````````````````````````````````````````````````````
M````````#0T-#0T-#0T-#0T-#0T-#0T-#0T-#0T-#0T-#0T-#0T-#0T-#0T-
M"`T-#0T-#0T-#0T-#0T2&@@-#0T-#0T-#0T-#0T!#QD(#0T-#0T-#0T("`<`
M)08-#0T-#0T(#0@-#1$F(04-"`T-#0T-#0,-#0T-%AL7"@P-#0T-#0<=$`T0
M(B0>%!`+"0T-#0T(%0@-!"`L+B\H#@@(#0T-"`T(#0T(!0@8,"LC'PT(#0T-
M#0T-#0T("`,G,2T'"`@-#0T-#0T-#0T-`API*@T-#0T-#0T-#0T-#0T)"`(3
M"`T-#0T-#0T-#0T-#0@-"`T-#0T-#0T-#0T-#0T-#0T-#0T-#0``````````
M````````````````````````````````````````````````````````````
+````````````````
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)