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