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