lib/App/MoBundle.pm

   1 #!/usr/bin/env perl
   2 use strict;
   3 use warnings;
   4 our $VERSION = '0.2.0';
   5
   6 use Carp;
   7 use English qw< -no_match_vars >;
   8 use File::Basename qw< basename dirname >;
   9 use File::Path qw< make_path >; # "mkdir -p"-alike
  10 use File::Spec;
  11 use File::Spec::Unix;
  12 use Cwd qw< realpath >;
  13
  14 use Exporter qw< import >;
  15 our @EXPORT_OK = qw<
  16    autoscan
  17    bundle
  18    mobundle_config
  19    mobundle_run
  20    unbundle
  21 >;
  22 our %EXPORT_TAGS = (all => [@EXPORT_OK]);
  23
  24 ########################################################################
  25 #
  26 # Exported functions
  27
  28 sub autoscan {
  29    my ($config) = @_;
  30    get_modules($config);
  31    add_autoscan_modules($config); # assume autoscan is requested!
  32    return $config->{modules};
  33 }
  34
  35 sub bundle {
  36    my ($config) = @_;
  37    get_modules($config);
  38
  39    # conditionally scan modules too
  40    add_autoscan_modules($config) if $config->{autoscan};
  41
  42    my $template = <<'END_OF_TEMPLATE';
  43 [% head %]
  44
  45 # __MOBUNDLE_INCLUSION__
  46 BEGIN {
  47    my %file_for = (
  48 [% while (my ($filename, $contents) = each %{$variables{modules}}) { %]
  49       '[%= $filename %]' => <<'END_OF_FILE',
  50 [%= $contents =~ s/^/ /gmxs; $contents; %]
  51 END_OF_FILE
  52 [% } %]
  53    );
  54
  55    unshift @INC, sub {
  56       my ($me, $packfile) = @_;
  57       return unless exists $file_for{$packfile};
  58       (my $text = $file_for{$packfile}) =~ s/^\ //gmxs;
  59       chop($text); # added \n at the end
  60       open my $fh, '<', \$text or die "open(): $!\n";
  61       return $fh;
  62    };
  63
  64 [% if ($variables{'add-modules-list'}) { %]
  65    our @__MOBUNDLE_MODULES__ = qw<
  66 [%    for my $path (sort {$a cmp $b} keys(%{$variables{modules}})) {
  67          (my $name = $path) =~ s{\.pm$}{}mxs or next;
  68          $name =~ s{/}{::}gmxs;
  69 %]      [%= $name %]
  70 [%    }
  71 %]   >;
  72 [% } %]
  73 } ## end BEGIN
  74 # __MOBUNDLE_INCLUSION__
  75
  76 [% body %]
  77 END_OF_TEMPLATE
  78
  79    require Template::Perlish;
  80    return Template::Perlish::render($template, $config);
  81 }
  82
  83 sub mobundle_config {
  84    my ($config, $args) = @_;
  85
  86    if (defined($config->{'standard-head'})) {
  87       die(\'head and standard-head are mutually exclusive')
  88          if defined($config->{head});
  89       $config->{head} = "#!/usr/bin/env perl\n";
  90    }
  91
  92    if (defined($config->{'head-from'})) {
  93       die(\'multiple head sources are not allowed')
  94          if defined($config->{head});
  95       $config->{head} = read_file($config->{'head-from'});
  96    }
  97
  98    # Get body
  99    if (@{$args}) {
 100       die(\'body and bare parameter are mutually exclusive')
 101         if defined($config->{body});
 102       die(\'body-from and bare parameter are mutually exclusive')
 103         if defined($config->{'body-from'});
 104       die(\'only one bare command line parameter is allowed')
 105         if @{$args} > 1;
 106       $config->{'body-from'} = $args->[0];
 107    }
 108
 109    if (defined($config->{'body-from'})) {
 110       die(\'body and body-from are mutually exclusive')
 111          if defined($config->{body});
 112       $config->{body} = read_file($config->{'body-from'});
 113    }
 114
 115    die(\'neither body nor body-from were present')
 116      unless defined($config->{body});
 117
 118    if (exists($config->{'head-from-body'})) {
 119       die(\'multiple head sources are not allowed')
 120         if defined($config->{head});
 121
 122       my @body = split /\n/, $config->{body};
 123       my @header = splice @body, 0, $config->{'head-from-body'} || 1;
 124
 125       $config->{head} = join "\n", @header;
 126       $config->{body} = join "\n", @body;
 127    } ## end if (exists $config->{'head-from-body'...
 128
 129    if (exists($config->{'head-from-paragraph'})) {
 130       die(\'multiple head sources are not allowed')
 131         if exists($config->{head});
 132
 133       ($config->{head}, $config->{body}) = split /\n\s*?\n/, $config->{body}, 2;
 134    }
 135
 136    $config->{modules} = [] unless defined($config->{modules});
 137    for my $file (@{$config->{'modules-from'}}) {
 138       chomp(my @modules = read_file($file));
 139       push @{$config->{modules}}, @modules;
 140    }
 141
 142    return $config;
 143 }
 144
 145 sub mobundle_run {
 146    my ($prg, @args) = @_;
 147
 148    require Pod::Usage;
 149    require Getopt::Long;
 150    Getopt::Long::Configure('gnu_getopt');
 151
 152    my %config = (output => '-', 'modules-from' => [], include => []);
 153    Getopt::Long::GetOptionsFromArray(
 154       \@args,
 155       \%config,
 156       qw(
 157       usage help man version
 158       add-modules-list|L!
 159       autoscan|scan|a!
 160       autoscan-list|scan-list|modules-list|l!
 161       body|b=s
 162       body-from|script|program|B=s
 163       head|h=s
 164       head-from|H=s
 165       head-from-body|S:i
 166       head-from-paragraph|P!
 167       include|I=s@
 168       modules|module|m=s@
 169       modules-from|M=s@
 170       output|o=s
 171       standard-head|s!
 172       unbundle|u!
 173       )
 174    );
 175    Pod::Usage::pod2usage(message => "$prg $VERSION", -verbose => 99, -sections => ' ')
 176      if $config{version};
 177    Pod::Usage::pod2usage(-verbose => 99, -sections => 'USAGE') if $config{usage};
 178    Pod::Usage::pod2usage(-verbose => 99, -sections => 'USAGE|EXAMPLES|OPTIONS')
 179      if $config{help};
 180    Pod::Usage::pod2usage(-verbose => 2) if $config{man};
 181
 182    # Manage unbundle before all the rest
 183    return unbundle(\%config, @args) if $config{unbundle};
 184
 185    # "Unroll" the configuration to cope with options like body-from and
 186    # head-from-paragraph... This might lead to validation breaking and some
 187    # help to the user
 188    eval {
 189       mobundle_config(\%config, \@args);
 190       1;
 191    } or do {
 192       my $message = $EVAL_ERROR;
 193       $message = ${$message} if ref($message) eq 'SCALAR';
 194       Pod::Usage::pod2usage(
 195          message   => "ERROR: $message\n",
 196          -verbose  => 99,
 197          -sections => ''
 198       );
 199    };
 200
 201    if ($config{'autoscan-list'}) {
 202       my $modules = autoscan(\%config);
 203       for my $path (sort { $a cmp $b } keys(%{$modules})) {
 204          (my $name = $path) =~ s/\.pm$//;
 205          $name =~ s{/}{::}g;
 206          print "$name\n";
 207       }
 208       return 0;
 209    }
 210
 211    write_file($config{output}, bundle(\%config));
 212    return 0;
 213
 214 }
 215
 216 sub unbundle {
 217    my $config = shift;
 218
 219    BUNDLED:
 220    for my $bundled (@_) {
 221       my $modules = read_modules($bundled) or next BUNDLED;
 222       while (my ($path, $contents) = each(%{$modules})) {
 223          my $output = $config->{output} ne '-' ? $config->{output} : 'lib';
 224          my $path = unix_to_local_path("$output/$path");
 225          make_path(dirname($path)); # ensure parent directory
 226          write_file($path, $contents);
 227       }
 228    }
 229
 230    return 0;
 231 }
 232
 233 ########################################################################
 234 #
 235 # Helpers
 236
 237 sub add_autoscan_modules {
 238    my ($config) = @_;
 239    $config->{modules} = {} unless defined($config->{modules});
 240    my $modules = $config->{modules};
 241
 242    require Module::ScanDeps;
 243    require File::Temp;
 244    require Config;
 245
 246    my $fh = File::Temp->new(UNLINK => 1, SUFFIX => '.pl');
 247    write_file($fh, $config->{body});
 248    $fh->close();
 249
 250    my $in_priv = subsumer_factory($Config::Config{privlib});
 251    my $in_arch = subsumer_factory($Config::Config{archlib});
 252
 253    my @filenames = $fh->filename;
 254    my %flag_for;
 255    while (@filenames) {
 256       my $name = shift @filenames;
 257       next if $flag_for{$name}++;
 258       my $deps_for =
 259         Module::ScanDeps::scan_deps(files => [$name], skip => $modules);
 260
 261       while (my ($key, $mod) = each(%{$deps_for})) {
 262          next if exists $modules->{$key};
 263
 264          # Restrict to modules...
 265          next unless $mod->{type} eq 'module';
 266
 267          my $filename = $mod->{file};
 268          next if $in_priv->($filename) || $in_arch->($filename);
 269
 270          $modules->{$key} = read_file($filename);
 271          push @filenames, $filename;
 272       } ## end while (my ($key, $mod) = ...
 273    }
 274    return $config;
 275 }
 276
 277 sub get_module_contents {
 278    my ($filename) = @_;
 279    for my $item (@INC) {
 280       my $full_path = unix_to_local_path("$item/$filename");
 281       next unless -e $full_path;
 282       return scalar(read_file($full_path));
 283    } ## end for my $item (@INC)
 284    carp "could not find module file: '$filename'";
 285 } ## end sub get_module_contents
 286
 287 sub get_modules {
 288    my ($config) = @_;
 289
 290    # widen search path for modules, but only until we exit from this sub
 291    local @INC = @INC;
 292    push @INC, @{$config->{include} || []};
 293
 294    my %modules = map {
 295       (my $filename = $_) =~ s{::}{/}g;
 296       $filename .= '.pm' unless $filename =~ /\./mxs;
 297
 298       # "return" the pair
 299       ($filename => get_module_contents($filename));
 300    } @{$config->{modules}};
 301
 302    $config->{modules} = \%modules;
 303    return $config;
 304 }
 305
 306 sub fh_raw {
 307    my ($file, $mode) = @_;
 308    $file = $mode eq '<' ? \*STDIN : \*STDOUT
 309       if (! ref($file)) && ($file eq '-');
 310    my ($fh, $opened);
 311
 312    # if $file is a reference, but NOT a reference to a SCALAR, assume it
 313    # already supports I/O operations and take it as-is. Otherwise, open
 314    # it (this includes references to scalars for in-memory stuff)
 315    my $ref = ref($file);
 316    if ($ref && $ref ne 'SCALAR') {
 317       $fh = $file;
 318    }
 319    else {
 320       open $fh, $mode, $file or croak "open('$file'): $OS_ERROR";
 321       $opened = 1;
 322    }
 323    binmode $fh, ':raw' or croak "binmode(): $OS_ERROR";
 324    return ($fh, $opened);
 325 }
 326
 327 sub read_file {
 328    my ($fh, $opened) = fh_raw($_[0], '<');
 329
 330    local $INPUT_RECORD_SEPARATOR = $INPUT_RECORD_SEPARATOR;
 331    $INPUT_RECORD_SEPARATOR = undef unless wantarray();
 332    my @retval = readline($fh) or croak "readline(): $OS_ERROR";
 333
 334    if ($opened) {
 335       close($fh) or croak "close(): $OS_ERROR";
 336    }
 337
 338    return wantarray() ? @retval : $retval[0];
 339 }
 340
 341 sub read_modules {
 342    my ($bundled) = @_;
 343
 344    my ($fh, $opened) = fh_raw($bundled, '<');
 345
 346    # read __MOBUNDLE_INCLUSION__ section
 347    my @lines;
 348    1 while scalar(<$fh>) !~ m{^\#\ __MOBUNDLE_INCLUSION__$}mxs;
 349    while (<$fh>) {
 350       last if m{^\#\ __MOBUNDLE_INCLUSION__$}mxs;
 351       push @lines, $_;
 352    }
 353
 354    # read no more
 355    if ($opened) {
 356       close($fh) or croak "close(): $OS_ERROR";
 357    }
 358
 359    if (!@lines) {
 360       warn "nothing in $bundled\n";
 361       return;
 362    }
 363
 364    1 while shift(@lines) !~ m{^\s*my \s* \%file_for}mxs;
 365    unshift @lines, '(';
 366    1 while pop(@lines) !~ m{^\s*unshift \s* \@INC}mxs;
 367    my $definition = join '', @lines;
 368
 369    my %file_for = eval $definition;
 370    return wantarray() ? %file_for : \%file_for;
 371 }
 372
 373
 374 sub subsumer_factory {
 375    my ($dirpath) = @_;
 376    $dirpath = realpath($dirpath) if defined($dirpath) && length($dirpath);
 377
 378    return sub { return 0 } unless defined($dirpath) && length($dirpath);
 379
 380    my ($dv, $dds) = File::Spec->splitpath($dirpath, 'no-file');
 381    my @dds = File::Spec->splitdir($dds);
 382
 383    return sub {
 384       my $filepath = realpath($_[0]);
 385       my ($fv, $fds, $fbase) = File::Spec->splitpath($filepath);
 386
 387       return 0 if $dv ne $fv;                  # different volume?
 388
 389       my @fds = File::Spec->splitdir($fds);
 390       # warn "- $filepath\n    fv<$fv> fds(@fds)\n    dv<$dv> dds(@dds)\n";
 391       return 0 if scalar(@dds) > scalar(@fds); # not long enough?
 392       for my $i (0 .. $#dds) {
 393          return 0 if $dds[$i] ne $fds[$i];     # not same (sub)-dir
 394       }
 395
 396       # everything matched...
 397       return 1;
 398    };
 399 }
 400
 401 sub unix_to_local_path {
 402    my ($upath, $is_dir) = @_;
 403    $upath = File::Spec::Unix->canonpath($upath); # remove multiple '/'...
 404    my ($vol, $dirs, $file) = File::Spec::Unix->splitpath($upath, $is_dir);
 405    $dirs = File::Spec->catdir(File::Spec::Unix->splitdir($dirs));
 406    return File::Spec->catpath($vol, $dirs, $file);
 407 }
 408
 409 sub write_file {
 410    my ($fh, $opened) = fh_raw(shift, '>');
 411
 412    print {$fh} @_ or croak "print(): $OS_ERROR";
 413
 414    if ($opened) {
 415       close($fh) or croak "close(): $OS_ERROR";
 416    }
 417
 418    return;
 419 }
 420
 421 1;