mobundle

   1 #!/usr/bin/env perl
   2 use strict;
   3 use warnings;
   4 use Carp;
   5 use Pod::Usage qw( pod2usage );
   6 use Getopt::Long qw( :config gnu_getopt );
   7 use English qw( -no_match_vars );
   8 use File::Slurp ();
   9 use Template::Perlish;
  10 use Path::Class qw( foreign_file dir );
  11 use File::Basename qw( basename );
  12 my $VERSION = '0.1.1';
  13
  14 # Integrated logging facility
  15 #  use Log::Log4perl qw( :easy :no_extra_logdie_message );
  16 #  Log::Log4perl->easy_init({level=>$INFO, layout=>'[%d %-5p] %m%n'});
  17
  18 my %config = (output => '-', 'modules-from' => [], include => []);
  19 GetOptions(
  20    \%config,
  21    qw(
  22      usage help man version
  23      autoscan|scan|a!
  24      autoscan-list|scan-list|modules-list|l!
  25      body|b=s
  26      body-from|script|program|B=s
  27      head|h=s
  28      head-from|H=s
  29      head-from-body|S:i
  30      head-from-paragraph|P!
  31      include|I=s@
  32      modules|module|m=s@
  33      modules-from|M=s@
  34      output|o=s
  35      standard-head|s!
  36      unbundle|u!
  37      )
  38 );
  39 pod2usage(message => "$0 $VERSION", -verbose => 99, -sections => ' ')
  40   if $config{version};
  41 pod2usage(-verbose => 99, -sections => 'USAGE') if $config{usage};
  42 pod2usage(-verbose => 99, -sections => 'USAGE|EXAMPLES|OPTIONS')
  43   if $config{help};
  44 pod2usage(-verbose => 2) if $config{man};
  45
  46 # Manage unbundle before all the rest
  47 if ($config{unbundle}) {
  48    unbundle(@ARGV);
  49    exit 0;
  50 }
  51
  52 # Various checks for input parameter consistence and overriding
  53 pod2usage(
  54    message   => "head and standard-head are mutually exclusive",
  55    -verbose  => 99,
  56    -sections => ''
  57 ) if exists($config{head}) && exists($config{'standard-head'});
  58 $config{head} = "#!/usr/bin/env perl\n"
  59   if exists $config{'standard-head'};
  60
  61 pod2usage(
  62    message   => "(standard-)head and head-from are mutually exclusive",
  63    -verbose  => 99,
  64    -sections => ''
  65 ) if exists($config{head}) && exists($config{'head-from'});
  66 $config{head} = read_file($config{'head-from'})
  67   if exists $config{'head-from'};
  68
  69 # Get body
  70 if (@ARGV) {
  71    pod2usage(
  72       message   => "body and bare parameter are mutually exclusive",
  73       -verbose  => 99,
  74       -sections => ''
  75    ) if exists $config{body};
  76    pod2usage(
  77       message   => "body-from and bare parameter are mutually exclusive",
  78       -verbose  => 99,
  79       -sections => ''
  80    ) if exists($config{'body-from'});
  81    pod2usage(
  82       message   => "only one bare command line parameter is allowed",
  83       -verbose  => 99,
  84       -sections => ''
  85    ) if @ARGV > 1;
  86    $config{'body-from'} = shift @ARGV;
  87 }
  88 if (exists $config{'body-from'}) {
  89    pod2usage(
  90       message   => "body and body-from are mutually exclusive",
  91       -verbose  => 99,
  92       -sections => ''
  93    ) if exists $config{body};
  94    $config{body} = read_file($config{'body-from'})
  95 }
  96 pod2usage(
  97    message   => "one between body, body-from or bare parameter is needed",
  98    -verbose  => 99,
  99    -sections => ''
 100 ) unless exists $config{body};
 101
 102
 103 if (exists $config{'head-from-body'}) {
 104    pod2usage(
 105       message   => "multiple head sources are not allowed",
 106       -verbose  => 99,
 107       -sections => ''
 108    ) if exists($config{head});
 109
 110    my @body = split /\n/, $config{body};
 111    my @header = splice @body, 0, $config{'head-from-body'} || 1;
 112
 113    $config{head} = join "\n", @header;
 114    $config{body} = join "\n", @body;
 115 } ## end if (exists $config{'head-from-body'...
 116
 117 if (exists $config{'head-from-paragraph'}) {
 118    pod2usage(
 119       message   => "multiple head sources are not allowed",
 120       -verbose  => 99,
 121       -sections => ''
 122    ) if exists($config{head});
 123
 124    ($config{head}, $config{body}) = split /\n\s*?\n/, $config{body}, 2;
 125 }
 126
 127 push @INC, @{$config{include}};
 128
 129 for my $file (@{$config{'modules-from'}}) {
 130    chomp(my @modules = read_file($file));
 131    push @{$config{modules}}, @modules;
 132 }
 133
 134 # Load files for explicitly requested modules
 135 my %modules = map {
 136    (my $filename = $_) =~ s{::}{/}g;
 137    $filename .= '.pm' unless $filename =~ /\./mxs;
 138    $filename => get_module_contents($filename);
 139 } @{$config{modules}};
 140
 141 # Now autoscan if requested. Already-loaded modules will be skipped
 142 if ($config{autoscan} || $config{'autoscan-list'}) {
 143    require Module::ScanDeps;
 144    require File::Temp;
 145    require Config;
 146
 147    my $fh = File::Temp->new(UNLINK => 1, SUFFIX => '.pl');
 148    binmode $fh;
 149    print {$fh} $config{body};
 150    $fh->close();
 151
 152    my @filenames = $fh->filename();
 153    my %flag_for;
 154    while (@filenames) {
 155       my $filename = shift @filenames;
 156       next if $flag_for{$filename}++;
 157       my $deps_for =
 158         Module::ScanDeps::scan_deps(files => [$filename], skip => {%modules});
 159
 160       my $priv = dir($Config::Config{privlib});
 161       my $arch = dir($Config::Config{archlib});
 162       while (my ($key, $mod) = each %$deps_for) {
 163          next if exists $modules{$key};
 164
 165          # Restrict to modules...
 166          next unless $mod->{type} eq 'module';
 167
 168          my $privPath = $priv->file($key)->as_foreign('Unix');
 169          my $archPath = $arch->file($key)->as_foreign('Unix');
 170          next if $mod->{file} eq $privPath || $mod->{file} eq $archPath;
 171
 172          $modules{$key} = read_file($mod->{file});
 173          push @filenames, $mod->{file};
 174       } ## end while (my ($key, $mod) = ...
 175    }
 176
 177    if ($config{'autoscan-list'}) {
 178       for my $path (sort keys %modules) {
 179          (my $name = $path) =~ s/\.pm$//;
 180          $name =~ s{/}{::}g;
 181          print "$name\n";
 182       }
 183       exit 0;
 184    }
 185 } ## end if ($config{autoscan})
 186
 187 $config{modules} = \%modules;
 188
 189 my $template = <<'END_OF_TEMPLATE';
 190 [% head %]
 191
 192 # __MOBUNDLE_INCLUSION__
 193 BEGIN {
 194    my %file_for = (
 195 [% while (my ($filename, $contents) = each %{$variables{modules}}) { %]
 196       '[%= $filename %]' => <<'END_OF_FILE',
 197 [%= $contents =~ s/^/ /gmxs; $contents; %]
 198 END_OF_FILE
 199 [% } %]
 200    );
 201
 202    unshift @INC, sub {
 203       my ($me, $packfile) = @_;
 204       return unless exists $file_for{$packfile};
 205       (my $text = $file_for{$packfile}) =~ s/^\ //gmxs;
 206       chop($text); # added \n at the end
 207       open my $fh, '<', \$text or die "open(): $!\n";
 208       return $fh;
 209    };
 210 } ## end BEGIN
 211 # __MOBUNDLE_INCLUSION__
 212
 213 [% body %]
 214 END_OF_TEMPLATE
 215 $template =~ s/\s*\z//mxs;
 216 write_file($config{output},
 217    Template::Perlish->new()->process($template, \%config));
 218
 219 sub read_file {
 220    File::Slurp::read_file $_[0] eq '-' ? \*STDIN : $_[0];
 221 }
 222
 223 sub write_file {
 224    my $f = shift;
 225    File::Slurp::write_file(($f eq '-' ? \*STDOUT : $f), @_);
 226 }
 227
 228 sub get_module_contents {
 229    my ($filename) = @_;
 230    for my $item (@INC) {
 231       my $full_path =
 232         foreign_file('Unix', $item . '/' . $filename)->stringify();
 233       next unless -e $full_path;
 234       return scalar read_file $full_path;
 235    } ## end for my $item (@INC)
 236    carp "could not find module file: '$filename'";
 237 } ## end sub get_module_contents
 238
 239 sub unbundle {
 240    BUNDLED:
 241    for my $bundled (@_) {
 242       my $modules = read_modules($bundled);
 243       while (my ($filename, $contents) = each %$modules) {
 244          save_file($filename, $contents);
 245       }
 246    }
 247 }
 248
 249 sub save_file {
 250    my ($path, $contents) = @_;
 251    my $output = $config{output} ne '-' ? $config{output} : 'lib';
 252    my $upath = foreign_file(Unix => "$output/$path");
 253    $upath->dir()->mkpath();
 254    write_file($upath->openw(), $contents);
 255 }
 256
 257 sub read_modules {
 258    my ($bundled) = @_;
 259
 260    open my $fh, '<', $bundled
 261       or die "open('$bundled'): $OS_ERROR";
 262
 263    # read __MOBUNDLE_INCLUSION__ section
 264    my @lines;
 265    1 while scalar(<$fh>) !~ m{^\#\ __MOBUNDLE_INCLUSION__$}mxs;
 266    while (<$fh>) {
 267       last if m{^\#\ __MOBUNDLE_INCLUSION__$}mxs;
 268       push @lines, $_;
 269    }
 270    if (!@lines) {
 271       warn "nothing in $bundled\n";
 272       next BUNDLED;
 273    }
 274
 275    1 while shift(@lines) !~ m{^\s*my \s* \%file_for}mxs;
 276    unshift @lines, '(';
 277    1 while pop(@lines) !~ m{^\s*unshift \s* \@INC}mxs;
 278    my $definition = join '', @lines;
 279
 280    my %file_for = eval $definition;
 281    return %file_for if wantarray();
 282    return \%file_for;
 283 }
 284
 285 __END__
 286
 287 =head1 NAME
 288
 289 mobundle - bundle modules inside your scripts
 290
 291 =head1 VERSION
 292
 293 Ask the version number to the script itself, calling:
 294
 295    shell$ mobundle --version
 296
 297 =head1 USAGE
 298
 299    mobundle [--usage] [--help] [--man] [--version]
 300
 301    mobundle [--autoscan|--scan|-a]
 302             [--autoscan-list|--scan-list|--modules-list|-l]
 303             [--body|-b <body>]
 304             [--body-from|--script|--program|-B <filename>]
 305             [--head|-h <head>] [--head-from|-H <filename>]
 306             [--head-from-body|-S <n>]
 307             [--head-from-paragraph|-P]
 308             [--include|-I <dirname>]
 309             [--module|-m <name>]
 310             [--modules-from|-M <filename>]
 311             [--output|-o <filename>]
 312             [--standard-head|-s]
 313             [--unbundle|-u]
 314
 315 =head1 EXAMPLES
 316
 317    shell$ mobundle -m Template::Perlish yourscript.pl
 318
 319    shell$ mobundle -m Template::Perlish --head '#!/path/to/perl' script.pl
 320
 321    shell$ mobundle -m Acme::Laugh --head-from-paragraph laugh.pl
 322
 323    # This lists all the modules that mobundle would include with
 324    # --autoscan|--scan|-a. Save it, trim it and you're done!
 325    shell$ mobundle --autoscan-list laugh.pl
 326
 327    # If you want to bundle some module that is local to your project
 328    shell$ mobundle -I ./lib -m My::Module ./bin/script.pl
 329
 330    # If you have a recently-bundled file you can easily extract modules
 331    shell% mobundle -u bundled-program.pl -o mylib
 332
 333 =head1 DESCRIPTION
 334
 335 C<mobundle> lets you bundle Perl modules inside your Perl script, in order
 336 to ship a single script instead of N separate files.
 337
 338 The underlying logic is simple: all modules are included in the generated
 339 script, and the module loading mechanism is tweaked in order to let you
 340 load the bundled modules. See the documentation for L<perlfunc/require>
 341 to understand how.
 342
 343 The generated script will be compound of three main parts: a C<head>,
 344 a section with the bundled modules and the logic to load them, and
 345 a C<body>. Briefly speaking:
 346
 347 =over
 348
 349 =item B<head>
 350
 351 this is where you should put your shabang and the C<use>s that you would
 352 like to happen before the module loading mechanism is tweaked.
 353
 354 The C<head> is guaranteed to start at the very first octet in the result,
 355 so you can put a shabang.
 356
 357 =item B<modules>
 358
 359 this part is generated automatically based on your instructions about which
 360 modules should be bundled.
 361
 362 =item B<body>
 363
 364 this is the body of your script, i.e. what your script is supposed to do.
 365 It will likely contain either C<use>s or C<require>s that need the modules
 366 that are bundled in the C<modules> section.
 367
 368 =back
 369
 370 If you have a bundled script, apart from doing it yourself you can also
 371 unbundle it, see L</--unbundle | -u> below.
 372
 373 =head2 Why Another? Use PAR!
 374
 375 L<PAR> is fantastic: lets you bundle all the needed components of your
 376 application inside a single executable, and ship it. But... there's a
 377 niche that it's not able to cover, at least looking at the documentation.
 378
 379 In particular, there seem to be two different operation modes, depending
 380 on your needs
 381
 382 =over
 383
 384 =item *
 385
 386 either you're willing to bundle the interpreter as well, in which case
 387 L<PAR> (or, better, L<pp>) will generate a super-executable bundling all
 388 necessary stuff
 389
 390 =item *
 391
 392 or you have to be sure that L<PAR> is installed in the target directory.
 393
 394 =back
 395
 396 My need was somewhere in between: on the one side I wasn't willing to bundle
 397 the interpreter, on the other I couldn't ensure that L<PAR> was available.
 398
 399 In particular, this kind of need arises every time that my programs only need
 400 Pure-Perl modules, that do not need any platform-specific installation
 401 process. In this case, bundling the interpreter means restricting the
 402 applicability to one (or more, at some cost) platform only; the other way
 403 is simply not acceptable in some environments.
 404
 405
 406 =head1 OPTIONS
 407
 408 =over
 409
 410 =item --autoscan | -scan | -a
 411
 412 tries to use L<Module::ScanDeps> to find non-core modules that might be
 413 needed. Note that this is not PAR, so you should be careful of what is
 414 taken in.
 415
 416 For example, L<Archive::Tar> can operate without L<IO::Zlib>, but
 417 L<Module::ScanDeps> will bring it in together with a lot of stuff.
 418
 419 =item --autoscan-list | --scan-list | --modules-list | -l
 420
 421 print out the list of modules that would be included by L</--autoscan>.
 422
 423 =item --body | -b <body>
 424
 425 turn your one-liner in a self contained script! Just pass the C<body> of your
 426 script and you're done.
 427
 428 =item --body-from | -B <filename>
 429
 430 get the body of the target script from the given filename.
 431
 432 =item --head | -h <head>
 433
 434 the C<head> is the part that will be put at the very beginning of the
 435 resulting script. Can be useful to specify a shabang.
 436
 437 =item --head-from | -H <filename>
 438
 439 get the C<head> from the given filename. See L</head>.
 440
 441 =item --head-from-body | -S <n>
 442
 443 get the C<head> taking it from the first C<n> lines of the body. See
 444 L</head> and L</body>.
 445
 446 =item --head-from-paragraph | -P
 447
 448 get the C<head> from the very first paragraph in the C<body>. See
 449 L</head> and L</body>.
 450
 451 =item --help
 452
 453 print a somewhat more verbose help, showing usage, this description of
 454 the options and some examples from the synopsis.
 455
 456 =item --include | -I <dirname>
 457
 458 add C<dirname> to @INC, which is also the directory used to look for
 459 modules' sources.
 460
 461 =item --man
 462
 463 print out the full documentation for the script.
 464
 465 =item --module | -m <name>
 466
 467 include the given module in the final script. You can specify this option
 468 multiple times for multiple modules.
 469
 470 When used with L</--autoscan>, these modules are skipped during the scan.
 471
 472 =item --modules-from | -M <filename>
 473
 474 get a list of modules to bundle from the given filename.
 475
 476 =item --output | -o <filename>
 477
 478 set a filename for output, instead of standard output. When C<-> is given,
 479 standard output is assumed.
 480
 481 When used with L</--unbundle | -u>, it is the name of the base output
 482 directory where modules will be written.
 483
 484 =item --standard-head | -s
 485
 486 put a standard header at the beginning of the generated script, i.e.:
 487
 488    #!/usr/bin/env perl
 489
 490 =item --unbundle | -u
 491
 492 unbundle an already-bundled script. In this case, the C<--output|-o>
 493 option is considered a directory; if not specified, the C<lib> directory
 494 is used (and created if needed).
 495
 496 Unbundling assumes that the bundled script was produced with a fairly recent
 497 version of I<mobundle>; in particular, it is important that the
 498 C<__MOBUNDLE_INCLUSION__> comments are present.
 499
 500 =item --usage
 501
 502 print a concise usage line and exit. You can specify this option
 503 multiple times for multiple modules.
 504
 505 =item --version
 506
 507 print the version of the script.
 508
 509 =back
 510
 511 =head1 CONFIGURATION AND ENVIRONMENT
 512
 513 mobundle requires no configuration files or environment variables.
 514
 515 =head1 DEPENDENCIES
 516
 517 Non-core modules needed:
 518
 519 =over
 520
 521 =item B<< File::Slurp >>
 522
 523 =item B<< Template::Perlish >>
 524
 525 =item B<< Path::Class >>
 526
 527 =item B<< Module::ScanDeps >>
 528
 529 but only if you want to use the L</--autoscan> option.
 530
 531 =back
 532
 533 Did you say that I should I<bundle> them?!?
 534
 535 =head1 BUGS AND LIMITATIONS
 536
 537 No bugs have been reported.
 538
 539 Please report any bugs or feature requests through http://rt.cpan.org/
 540
 541 Undoubtfully there are many bugs, and more limitations.
 542
 543 =head1 AUTHOR
 544
 545 Flavio Poletti C<polettix@cpan.org>
 546
 547 =head1 COPYRIGHT AND LICENSE
 548
 549 Copyright (c) 2008-2011 by Flavio Poletti C<polettix@cpan.org>.
 550
 551 This program is free software. You can redistribute it and/or
 552 modify it under the terms of the Artistic License 2.0.
 553
 554 This program is distributed in the hope that it will be useful,
 555 but without any warranty; without even the implied warranty of
 556 merchantability or fitness for a particular purpose.
 557
 558 =cut