Dogcows Code - chaz/homebank2ledger/blob - maint/fatpack.pl

   1 #!/usr/bin/env perl
   2
   3 # This script creates a fatpacked version of homebank2ledger. Much of this code was inspired by or
   4 # blatantly copied from cpanminus build scripts, written by Tatsuhiko Miyagawa.
   5
   6 use warnings FATAL => 'all';
   7 use strict;
   8 use autodie ':all';
   9
  10 use App::FatPacker ();
  11 use Cwd;
  12 use File::Find;
  13 use File::Path;
  14 use File::pushd;
  15 use Module::CoreList;
  16
  17
  18 my $distdir = shift;
  19
  20 my $script_name = 'bin/homebank2ledger';
  21 my $libdir = 'lib';
  22
  23 if ($distdir) {
  24     if (-d "$distdir/blib") {
  25         $script_name = "$distdir/blib/script/homebank2ledger";
  26         $libdir = "$distdir/blib/lib";
  27     }
  28     else {
  29         $script_name = "$distdir/$script_name";
  30         $libdir = "$distdir/$libdir";
  31     }
  32 }
  33
  34 make_fatlib();
  35 make_script();
  36 exit;
  37
  38
  39 BEGIN {
  40     # IO::Socket::IP requires newer Socket, which is C-based
  41     $ENV{PERL_HTTP_TINY_IPV4_ONLY} = 1;
  42 }
  43
  44 END {
  45     no autodie;
  46     unlink('homebank2ledger.tmp');
  47     rmtree('.fatpack-build');
  48     rmtree('fatlib');
  49 }
  50
  51
  52 sub find_requires {
  53     my $file = shift;
  54
  55     my %requires;
  56     open my $in, "<", $file;
  57     while (<$in>) {
  58         /^\s*(?:use|require) (\S+)[^;]*;\s*$/
  59           and $requires{$1} = 1;
  60     }
  61
  62     keys %requires;
  63 }
  64
  65 sub mod_to_pm {
  66     local $_ = shift;
  67     s!::!/!g;
  68     "$_.pm";
  69 }
  70
  71 sub pm_to_mod {
  72     local $_ = shift;
  73     s!/!::!g;
  74     s/\.pm$//;
  75     $_;
  76 }
  77
  78 sub in_lib {
  79     my $file = shift;
  80     -e "$libdir/$file";
  81 }
  82
  83 sub is_core {
  84     my $module = shift;
  85     exists $Module::CoreList::version{5.008001}{$module};
  86 }
  87
  88 sub exclude_modules {
  89     my($modules, $except) = @_;
  90     my %exclude = map { $_ => 1 } @$except;
  91     [ grep !$exclude{$_}, @$modules ];
  92 }
  93
  94 sub pack_modules {
  95     my($path, $modules, $no_trace) = @_;
  96
  97     $modules = exclude_modules($modules, $no_trace);
  98
  99     my $packer = App::FatPacker->new;
 100     my @requires = grep !is_core(pm_to_mod($_)), grep /\.pm$/, split /\n/,
 101       $packer->trace(use => $modules, args => ['-e', 1]);
 102     push @requires, map mod_to_pm($_), @$no_trace;
 103
 104     my @packlists = $packer->packlists_containing(\@requires);
 105     for my $packlist (@packlists) {
 106         print "Packing $packlist\n";
 107     }
 108     $packer->packlists_to_tree($path, \@packlists);
 109 }
 110
 111 sub make_fatlib {
 112     my @modules = grep !in_lib(mod_to_pm($_)), find_requires($script_name);
 113
 114     pack_modules(cwd . '/fatlib', \@modules, []);
 115
 116     use Config;
 117     print "Remove fatlib/$Config{archname}\n";
 118     rmtree("fatlib/$Config{archname}");
 119     rmtree("fatlib/POD2");
 120
 121     my $want = sub {
 122         if (/\.pod$/) {
 123             print "Remove $_\n";
 124             unlink $_;
 125         }
 126     };
 127
 128     find({ wanted => $want, no_chdir => 1 }, 'fatlib');
 129 }
 130
 131
 132 sub generate_file {
 133     my($base, $target, $fatpack) = @_;
 134
 135     open my $in,  "<", $base;
 136     open my $out, ">", "$target.tmp";
 137
 138     print STDERR "Generating $target from $base\n";
 139
 140     while (<$in>) {
 141         s|^#!\h*perl|#!/usr/bin/env perl|;
 142         s|^# FATPACK.*|$fatpack|;
 143         print $out $_;
 144     }
 145
 146     close $out;
 147
 148     eval { unlink $target };
 149     rename "$target.tmp", $target;
 150 }
 151
 152 sub make_script {
 153     mkdir '.fatpack-build';
 154     system qw(cp -r fatlib), $libdir, qw(.fatpack-build/);
 155
 156     my $fatpack_compact = do {
 157         my $dir = pushd '.fatpack-build';
 158
 159         my @files;
 160         my $want = sub {
 161             push @files, $_ if /\.pm$/;
 162             if (/\.pod$/) {
 163                 print "Remove $_\n";
 164                 unlink $_;
 165             }
 166         };
 167
 168         find({ wanted => $want, no_chdir => 1 }, 'fatlib', 'lib');
 169         system qw(perlstrip --cache -v), @files;
 170
 171         `fatpack file`;
 172     };
 173
 174     my $filename = $script_name;
 175     $filename =~ s!^.*/!!;
 176
 177     generate_file($script_name, $filename, $fatpack_compact);
 178     chmod 0755, $filename;
 179 }
 180