root/lang/perl/Module-Setup/trunk/lib/Module/Setup.pm @ 20962

Revision 20962, 16.1 kB (checked in by yappo, 5 years ago)

refactoring, add dialog validator

Line 
1package Module::Setup;
2
3use strict;
4use warnings;
5our $VERSION = '0.03';
6
7use Carp ();
8use Class::Trigger;
9use ExtUtils::MakeMaker qw(prompt);
10use Fcntl qw( :mode );
11use File::Basename;
12use File::Find::Rule;
13use File::Path;
14use File::Temp;
15use Getopt::Long;
16use Module::Collect;
17use Path::Class;
18use Pod::Usage;
19use YAML ();
20
21our $HAS_TERM;
22
23sub new {
24    my $class = shift;
25    bless {}, $class;
26}
27
28sub log {
29    my($self, $msg) = @_;
30    print STDERR "$msg\n" if $HAS_TERM;
31}
32sub dialog {
33    my($self, $msg, $default, $validator_callback) = @_;
34    return $default unless $HAS_TERM;
35    while (1) {
36        my $ret = prompt($msg, $default);
37        return $ret unless $validator_callback && ref($validator_callback) eq 'CODE';
38        return $ret if $validator_callback->($self, $ret);
39    }
40}
41
42sub _clear_triggers {
43    my $self = shift;
44    # reset triggers # this is bad hack
45    delete $self->{__triggers};
46    delete $self->{_class_trigger_results};
47}
48
49sub run {
50    my($self, $options, $argv) = @_;
51    $self->_clear_triggers;
52
53    $options ||= $self->setup_options;
54    my @argv = defined $argv && ref($argv) eq 'ARRAY' ? @{ $argv } : @ARGV;
55
56    $options->{flavor_class} ||= 'Default';
57
58    # create flavor
59    if ($options->{init}) {
60        $options->{flavor}   = shift @argv if @argv;
61        $options->{flavor} ||= 'default';
62        return $self->create_flavor($options);
63    }
64
65    # create module
66    $options->{module} = shift @argv;
67    $options->{flavor} = shift @argv if @argv;
68    $options->{flavor} ||= $self->select_flavor;
69
70    if ($options->{pack}) {
71        #pack flavor template
72        return $self->pack_flavor($options);
73    }
74
75
76    $self->{module_setup_dir} ||= $options->{module_setup_dir};
77    $self->{module_setup_dir}   = File::Temp->newdir if $options->{direct};
78
79    unless ( -d $self->module_setup_dir('flavors') && -d $self->module_setup_dir('flavors', $options->{flavor}) ) {
80        # setup the module-setup directory
81        $self->create_flavor($options);
82        $self->_create_directory( dir => $self->module_setup_dir('plugins') );
83    }
84
85    my $config = $self->load_config($options);
86    $self->load_plugins($config);
87
88    # create skeleton
89    my $attributes = $self->create_skeleton($config);
90    return unless $attributes;
91    $self->call_trigger( after_create_skeleton => $attributes );
92
93    # test
94    chdir Path::Class::Dir->new( @{ $attributes->{module_attribute}->{dist_path} } );
95    $self->call_trigger( check_skeleton_directory => $attributes );
96
97    $self->call_trigger( finalize_create_skeleton => $attributes );
98}
99
100sub setup_options {
101    my $self = shift;
102
103    pod2usage(2) unless @ARGV;
104
105    my $options = {};
106    GetOptions(
107        'init'           => \($options->{init}),
108        'pack'           => \($options->{pack}),
109        'direct'         => \($options->{direct}),
110        'flavor=s'       => \($options->{flavor}),
111        'flavor-class=s' => \($options->{flavor_class}),
112        'plugin=s@'      => \($options->{plugins}),
113        'target'         => \($options->{target}),
114        module_setup_dir => \($options->{module_setup_dir}),
115        version          => sub {
116            print "module-setup v$VERSION\n";
117            exit 1;
118        },
119        help             => sub { pod2usage(1); },
120    ) or pod2usage(2);
121
122    $options;
123}
124
125sub load_config {
126    my($self, $options) = @_;
127
128    $options->{plugins} ||= [];
129    my @option_plugins = @{ delete $options->{plugins} };
130
131    my $config = YAML::LoadFile( $self->module_setup_dir('flavors', $options->{flavor}, 'config.yaml') );
132        $config = +{
133        %{ $config },
134        %{ $options },
135    };
136
137    $config->{plugins} ||= [];
138    push @{ $config->{plugins} }, @option_plugins;
139
140    $config;
141}
142
143sub plugin_collect {
144    my($self, $config) = @_;
145
146    my @local_plugins;
147    push @local_plugins, @{ Module::Collect->new( path => $self->module_setup_dir('plugins') )->modules };
148    push @local_plugins, @{ Module::Collect->new( path => $self->module_setup_dir('flavors', $config->{flavor}, 'plugins') )->modules };
149    my %loaded_local_plugin;
150    for my $local_plugin (@local_plugins) {
151        $local_plugin->require;
152        if ($local_plugin->package->isa('Module::Setup::Plugin')) {
153            $loaded_local_plugin{$local_plugin->package} = $local_plugin;
154        }
155    }
156    %loaded_local_plugin;
157}
158
159sub load_plugins {
160    my($self, $config) = @_;
161
162    my %loaded_local_plugin = $self->plugin_collect($config);
163
164    my %loaded_plugin;
165    for my $plugin (@{ $config->{plugins} }) {
166        my $pkg;
167        my $config = +{};
168        if (ref($plugin)) {
169            if (ref($plugin) eq 'HASH') {
170                $pkg    = $plugin->{module};
171                $config = $plugin->{config};
172            } else {
173                next;
174            }
175        } else {
176            $pkg = $plugin;
177        }
178        $pkg = "Module::Setup::Plugin::$pkg" unless $pkg =~ s/^\+//;
179
180        unless ($loaded_local_plugin{$pkg}) {
181            eval "require $pkg"; ## no critic
182            Carp::croak $@ if $@;
183        }
184        $loaded_plugin{$pkg} = $pkg->new( context => $self, config => $config );
185    }
186}
187
188sub module_setup_dir {
189    my($self, @path) = @_;
190    my $base = $self->{module_setup_dir} || $ENV{MODULE_SETUP_DIR} || do {
191        eval { require File::HomeDir };
192        my $home = $@ ? $ENV{HOME} : File::HomeDir->my_home;
193        Path::Class::Dir->new( $home, '.module-setup' );
194    };
195
196    if (@path) {
197        my $new_base = Path::Class::Dir->new( $base, @path );
198        $new_base = Path::Class::File->new( $base, @path ) unless -d $base;
199        $base = $new_base;
200    }
201    $base;
202}
203
204sub create_directory {
205    my $self = shift;
206    $self->_create_directory(@_);
207}
208sub _create_directory {
209    my($self, %opts) = @_;
210    my $dir = $opts{dir} || File::Basename::dirname($opts{file});
211    unless (-e $dir) {
212        $self->log("Creating directory $dir");
213        $dir = $dir->stringify if ref($dir) && $dir->can('stringify'); ## bad hack
214        File::Path::mkpath($dir, 0, 0777); ## no critic
215    }
216}
217
218sub write_file {
219    my($self, $opts) = @_;
220    my $path = $opts->{dist_path};
221
222    if (-e $path) {
223        my $ans = $self->dialog("$path exists. Override? [yN] ", 'n');
224        return if $ans !~ /[Yy]/;
225    }
226
227    $self->_create_directory( file => $path );
228
229    $self->log("Creating $path");
230    open my $out, ">", $path or die "$path: $!";
231    print $out $opts->{template};
232    close $out;
233
234    chmod oct($opts->{chmod}), $path if $opts->{chmod};
235}
236
237sub install_flavor {
238    my($self, $name, $tmpl) = @_;
239
240    my $path = (exists $tmpl->{plugin} && $tmpl->{plugin}) ?
241        $self->module_setup_dir( 'flavors', $name, 'plugins', $tmpl->{plugin} ) :
242            $self->module_setup_dir( 'flavors', $name, 'template', $tmpl->{file} );
243    $self->write_file(+{
244        dist_path => $path,
245        %{ $tmpl },
246    });
247}
248
249sub write_template {
250    my($self, $options) = @_;
251
252    $self->call_trigger( template_process => $options );
253    $options->{template} = delete $options->{content} unless $options->{template};
254    $options->{dist_path} =~ s/____var-(.+)-var____/$options->{vars}->{$1} || $options->{vars}->{config}->{$1}/eg;
255
256    push @{ $self->{install_files} }, $options->{dist_path};
257    $self->write_file($options);
258}
259
260sub install_template {
261    my($self, $base, $path, $vars, $module_attribute) = @_;
262
263    my $src  = Path::Class::File->new($base, $path);
264    my $dist = Path::Class::File->new(@{ $module_attribute->{dist_path} }, $path);
265
266    my $mode = ( stat $src )[2];
267    $mode = sprintf "%03o", S_IMODE($mode);
268
269    open my $fh, '<', $src or die "$src: $!";
270    my $template = do { local $/; <$fh> };
271    close $fh;
272
273    my $options = {
274        dist_path => $dist,
275        template  => $template,
276        chmod     => $mode,
277        vars      => $vars,
278        content   => undef,
279    };
280    $self->write_template($options);
281}
282
283sub create_flavor {
284    my($self, $options) = @_;
285    $options ||= +{};
286    my $name  = $options->{flavor};
287    my $class = $options->{flavor_class};
288
289    $class = "Module::Setup::Flavor::$class" unless $class =~ s/^\+//;
290
291    Carp::croak "create flavor: $name exists " if -d $self->module_setup_dir('flavors', $name);
292    eval " require $class "; Carp::croak $@ if $@; ## no critic
293
294    my @template = $class->loader;
295    my $config = +{};
296    for my $tmpl (@template) {
297        if (exists $tmpl->{config} && ref($tmpl->{config}) eq 'HASH') {
298            $config = $tmpl->{config};
299        } else {
300            $self->install_flavor($name, $tmpl);
301        }
302    }
303
304    # plugins
305    $self->_create_directory( dir => $self->module_setup_dir('flavors', $name, 'plugins') );
306
307    if (exists $options->{plugins} && $options->{plugins} && @{ $options->{plugins} }) {
308        $config->{plugins} ||= [];
309        push @{ $config->{plugins} }, @{ $options->{plugins} };
310    }
311    $config->{plugins} ||= [];
312
313    # load plugins
314    $self->load_plugins(+{
315        %{ $config },
316        %{ $options },
317        plugins => $config->{plugins},
318    });
319
320    $self->call_trigger( befor_dump_config => $config );
321
322    $self->_clear_triggers;
323
324    # save config
325    YAML::DumpFile($self->module_setup_dir('flavors', $name, 'config.yaml'), $config);
326}
327
328sub _find_flavor_template {
329    my($self, $config) = @_;
330    my $module = $config->{module};
331    my $flavor = $config->{flavor};
332
333    Carp::croak "module name is required" unless $module;
334
335    my $flavor_path = $self->module_setup_dir('flavors', $flavor);
336    Carp::croak "No such flavor: $flavor" unless -d $flavor_path;
337
338    my @files = File::Find::Rule->new->file->relative->in( $self->module_setup_dir('flavors', $flavor, 'template') );
339    Carp::croak "No such flavor template files: $flavor" unless @files;
340    @files;
341}
342
343sub create_skeleton {
344    my($self, $config) = @_;
345    $config ||= +{};
346    $self->{install_files} = [];
347
348    my @files = $self->_find_flavor_template($config);
349
350    my $module = $config->{module};
351    my $flavor = $config->{flavor};
352
353    my @pkg  = split /::/, $module;
354    my $module_attribute = +{
355        module    => $module,
356        package   => \@pkg,
357        dist_name => join('-', @pkg),
358        dist_path => [ join('-', @pkg) ],
359    };
360    if (exists $config->{target} && $config->{target}) {
361        unshift @{ $module_attribute->{dist_path} }, $config->{target};
362    }
363    $self->call_trigger( after_setup_module_attribute => $module_attribute);
364
365    $self->create_directory( dir => Path::Class::Dir->new(@{ $module_attribute->{dist_path} }) );
366
367    my $template_vars = {
368        module      => $module_attribute->{module},
369        dist        => $module_attribute->{dist_name},
370        module_path => join('/', @{ $module_attribute->{package} }),
371        config      => $config,
372        localtime   => scalar localtime,
373    };
374    $self->call_trigger( after_setup_template_vars => $template_vars);
375
376    my $base = $self->module_setup_dir('flavors', $flavor, 'template');
377    for my $path (@files) {
378        $self->install_template($base, $path, $template_vars, $module_attribute);
379    }
380    $self->call_trigger( append_template_file => $template_vars, $module_attribute);
381
382    return +{
383        module_attribute => $module_attribute,
384        template_vars    => $template_vars,
385        install_files    => $self->{install_files},
386    };
387}
388
389sub pack_flavor {
390    my($self, $config) = @_;
391    my $module = $config->{module};
392    my $flavor = $config->{flavor};
393
394    my @template_files = $self->_find_flavor_template($config);
395
396    my @plugin_files = File::Find::Rule->new->file->relative->in( $self->module_setup_dir('flavors', $flavor, 'plugins') );
397
398    my @template;
399    for my $conf (
400        { type => 'template', files => \@template_files },
401        { type => 'plugins' , files => \@plugin_files },
402        { type => 'config'  , files =>['config.yaml'] },
403    ) {
404        my $base_path;
405        if ($conf->{type} eq 'config') {
406            $base_path = $self->module_setup_dir('flavors', $flavor);
407        } else {
408            $base_path = $self->module_setup_dir('flavors', $flavor, $conf->{type});
409        }
410
411        for my $file (@{ $conf->{files} }) {
412            my $path = Path::Class::File->new($base_path, $file);
413
414            if ($conf->{type} eq 'config') {
415                my $data = YAML::LoadFile($path);
416                push @template, +{
417                    config => $data
418                };
419            } else {
420                open my $fh, '<', $path or die "$path: $!";
421                my $data = do { local $/; <$fh> };
422                close $fh;
423                my $path_name = $conf->{type} eq 'template' ? 'file' : 'plugin';
424                push @template, +{
425                    $path_name => $file,
426                    template   => $data,
427                };
428            }
429        }
430    }
431
432    my $eq = '=';
433    my $yaml = YAML::Dump(@template);
434    print <<END;
435package $module;
436use strict;
437use warnings;
438use base 'Module::Setup::Flavor';
4391;
440
441${eq}head1
442
443$module - pack from $flavor
444
445${eq}head1 SYNOPSIS
446
447  $ module-setup --init --flavor-class=+$module new_flavor
448
449${eq}cut
450
451__DATA__
452
453$yaml
454END
455}
456
457sub select_flavor {
458    my $self = shift;
459    return 'default' unless -d $self->module_setup_dir('flavors');
460
461    my @flavors;
462    for my $flavor ( $self->module_setup_dir('flavors')->children ) {
463        next unless $flavor->is_dir;
464        my $name = $flavor->dir_list(-1);
465        ($name eq 'default') ? unshift @flavors, $name :  push @flavors, $name;
466    }
467    return $flavors[0] if @flavors == 1;
468
469    my $num = 1;
470    my $message;
471    for my $flavor (@flavors) {
472        $message .= sprintf "[%d]: %s\n", $num++, $flavor;
473    }
474
475    my $selected;
476    $self->dialog( "${message}Select flavor:", 1, sub {
477        my($self, $ret) = @_;
478        return unless $ret =~ /^[0-9]+$/;
479        $selected = $flavors[ $ret - 1 ];
480    } );
481    $self->log("You chose flavor: $selected");
482    return $selected;
483}
484
4851;
486__END__
487
488=head1 NAME
489
490Module::Setup - a simple module maker "yet another Module::Start(?:er)?"
491
492=head1 SYNOPSIS
493
494simply use
495
496  $ module-setup Foo::Bar
497
498make flavor
499
500  $ module-setup --init catalyst-action # create a "catalyst actions" flavor
501
502edit for flavor
503
504  $ cd ~/.module-setup/flavor/catalyst-action/template && some files edit for catalyst action templates
505
506use flavor
507
508  $ module-setup Foo catalyst-action # create to Catalyst::Action::Foo module
509
510redistribute pack for flavor
511
512  $ module-setup --pack MyFlavorCatalystAction catalyst-action > MyFlavorCatalystAction.pm
513
514using redistributed flavor
515
516  $ module-setup --direct --flavor-class=+MyFlavorCatalystAction New::Class
517
518importing redistributed flavor
519
520  $ module-setup --init --flavor-class=+MyFlavorCatalystAction new_flavor
521
522for git
523
524  $ module-setup --plugin=VC::Git Foo::Bar # or edit your ~/.module-setup/flavor/foo/config.yaml
525
526
527=head1 DESCRIPTION
528
529Module::Setup is very simply module start kit.
530
531When the module-setup command is executed first, a necessary template for ~/.module-setup directory is copied.
532
533=head1 What's difference Module::Setup and Module::Starter?
534
535L<Module::Starter> is very useful module. However customize of module template is complex.
536
537If L<Module::Sterter::PBP> is used, do you solve it?
538
539Yes, but switch of two or more templates is complex.
540
541If Module::Setup is used, switch of template flavor is easy.
542
543flavor customized uniquely becomes the form which can be redistributed by "module-setup --pack".
544
545if incorporating Module::Setup in your application, you can make Helper which is well alike of Catalyst::Helper.
546
547=head1 Example For Incorporating
548
549  use Module::Setup;
550  my $pmsetup = Module::Setup->new;
551  local $ENV{MODULE_SETUP_DIR} = '/tmp/module-setup'; # dont use  ~/.module-setup directory
552  my $options = {
553      # see setup_options method
554  };
555  $pmsetup->run($options, [qw/ New::Module foo_flavor /]); # create New::Module module with foo_flavor flavor
556
557=head1 AUTHOR
558
559Kazuhiro Osawa E<lt>ko@yappo.ne.jpE<gt>
560
561=head1 SEE ALSO
562
563L<Module::Setup::Plugin>, L<module-setup>
564
565this module's base code is pmsetup written by Tatsuhiko Miyagawa.
566
567some pmsetup scripts are in a L<http://svn.coderepos.org/share/lang/perl/misc/pmsetup>
568
569=head1 REPOSITORY
570
571  svn co http://svn.coderepos.org/share/lang/perl/Module-Setup/trunk Module-Setup
572
573Module::Setup is Subversion repository is hosted at L<http://coderepos.org/share/>.
574patches and collaborators are welcome.
575
576=head1 LICENSE
577
578This library is free software; you can redistribute it and/or modify
579it under the same terms as Perl itself.
580
581=cut
Note: See TracBrowser for help on using the browser.