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.0';
  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' => []);
  19 GetOptions(
  20    \%config,
  21    qw(
  22      usage help man version
  23      autoscan|scan|a!
  24      autoscan-list|scan-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      modules|module|m=s@
  32      modules-from|M=s@
  33      output|o=s
  34      standard-head|s!
  35      )
  36 );
  37 pod2usage(message => "$0 $VERSION", -verbose => 99, -sections => ' ')
  38   if $config{version};
  39 pod2usage(-verbose => 99, -sections => 'USAGE') if $config{usage};
  40 pod2usage(-verbose => 99, -sections => 'USAGE|EXAMPLES|OPTIONS')
  41   if $config{help};
  42 pod2usage(-verbose => 2) if $config{man};
  43
  44 # Various checks for input parameter consistence and overriding
  45 pod2usage(
  46    message   => "head and standard-head are mutually exclusive",
  47    -verbose  => 99,
  48    -sections => ''
  49 ) if exists($config{head}) && exists($config{'standard-head'});
  50 $config{head} = "#!/usr/bin/env perl\n"
  51   if exists $config{'standard-head'};
  52
  53 pod2usage(
  54    message   => "(standard-)head and head-from are mutually exclusive",
  55    -verbose  => 99,
  56    -sections => ''
  57 ) if exists($config{head}) && exists($config{'head-from'});
  58 $config{head} = read_file($config{'head-from'})
  59   if exists $config{'head-from'};
  60
  61 # Get body
  62 if (@ARGV) {
  63    pod2usage(
  64       message   => "body and bare parameter are mutually exclusive",
  65       -verbose  => 99,
  66       -sections => ''
  67    ) if exists $config{body};
  68    pod2usage(
  69       message   => "body-from and bare parameter are mutually exclusive",
  70       -verbose  => 99,
  71       -sections => ''
  72    ) if exists($config{'body-from'});
  73    pod2usage(
  74       message   => "only one bare command line parameter is allowed",
  75       -verbose  => 99,
  76       -sections => ''
  77    ) if @ARGV > 1;
  78    $config{'body-from'} = shift @ARGV;
  79 }
  80 if (exists $config{'body-from'}) {
  81    pod2usage(
  82       message   => "body and body-from are mutually exclusive",
  83       -verbose  => 99,
  84       -sections => ''
  85    ) if exists $config{body};
  86    $config{body} = read_file($config{'body-from'})
  87 }
  88 pod2usage(
  89    message   => "one between body, body-from or bare parameter is needed",
  90    -verbose  => 99,
  91    -sections => ''
  92 ) unless exists $config{body};
  93
  94
  95 if (exists $config{'head-from-body'}) {
  96    pod2usage(
  97       message   => "multiple head sources are not allowed",
  98       -verbose  => 99,
  99       -sections => ''
 100    ) if exists($config{head});
 101
 102    my @body = split /\n/, $config{body};
 103    my @header = splice @body, 0, $config{'head-from-body'} || 1;
 104
 105    $config{head} = join "\n", @header;
 106    $config{body} = join "\n", @body;
 107 } ## end if (exists $config{'head-from-body'...
 108
 109 if (exists $config{'head-from-paragraph'}) {
 110    pod2usage(
 111       message   => "multiple head sources are not allowed",
 112       -verbose  => 99,
 113       -sections => ''
 114    ) if exists($config{head});
 115
 116    ($config{head}, $config{body}) = split /\n\s*?\n/, $config{body}, 2;
 117 }
 118
 119 for my $file (@{$config{'modules-from'}}) {
 120    chomp(my @modules = read_file($file));
 121    push @{$config{modules}}, @modules;
 122 }
 123
 124 # Load files for explicitly requested modules
 125 my %modules = map {
 126    (my $filename = $_) =~ s{::}{/}g;
 127    $filename .= '.pm' unless $filename =~ /\./mxs;
 128    $filename => get_module_contents($filename);
 129 } @{$config{modules}};
 130
 131 # Now autoscan if requested. Already-loaded modules will be skipped
 132 if ($config{autoscan} || $config{'autoscan-list'}) {
 133    require Module::ScanDeps;
 134    require File::Temp;
 135    require Config;
 136
 137    my $fh = File::Temp->new(UNLINK => 1, SUFFIX => '.pl');
 138    binmode $fh;
 139    print {$fh} $config{body};
 140    $fh->close();
 141
 142    my @filenames = $fh->filename();
 143    my %flag_for;
 144    while (@filenames) {
 145       my $filename = shift @filenames;
 146       next if $flag_for{$filename}++;
 147       my $deps_for =
 148         Module::ScanDeps::scan_deps(files => [$filename], skip => {%modules});
 149
 150       my $priv = dir($Config::Config{privlib});
 151       my $arch = dir($Config::Config{archlib});
 152       while (my ($key, $mod) = each %$deps_for) {
 153          next if exists $modules{$key};
 154
 155          # Restrict to modules...
 156          next unless $mod->{type} eq 'module';
 157
 158          my $privPath = $priv->file($key)->as_foreign('Unix');
 159          my $archPath = $arch->file($key)->as_foreign('Unix');
 160          next if $mod->{file} eq $privPath || $mod->{file} eq $archPath;
 161
 162          $modules{$key} = read_file($mod->{file});
 163          push @filenames, $mod->{file};
 164       } ## end while (my ($key, $mod) = ...
 165    }
 166
 167    if ($config{'autoscan-list'}) {
 168       for my $path (sort keys %modules) {
 169          (my $name = $path) =~ s/\.pm$//;
 170          $name =~ s{/}{::}g;
 171          print "$name\n";
 172       }
 173       exit 0;
 174    }
 175 } ## end if ($config{autoscan})
 176
 177 $config{modules} = \%modules;
 178
 179 my $template = <<'END_OF_TEMPLATE';
 180 [% head %]
 181
 182 BEGIN {
 183    my %file_for = (
 184 [% while (my ($filename, $contents) = each %{$variables{modules}}) { %]
 185       '[%= $filename %]' => <<'END_OF_FILE',
 186 [%= $contents =~ s/^/ /gmxs; $contents; %]
 187 END_OF_FILE
 188 [% } %]
 189    );
 190
 191    unshift @INC, sub {
 192       my ($me, $packfile) = @_;
 193       return unless exists $file_for{$packfile};
 194       (my $text = $file_for{$packfile}) =~ s/^\ //gmxs;
 195       chop($text); # added \n at the end
 196       open my $fh, '<', \$text or die "open(): $!\n";
 197       return $fh;
 198    };
 199 } ## end BEGIN
 200
 201 [% body %]
 202 END_OF_TEMPLATE
 203
 204 write_file($config{output},
 205    Template::Perlish->new()->process($template, \%config));
 206
 207 sub read_file {
 208    File::Slurp::read_file $_[0] eq '-' ? \*STDIN : $_[0];
 209 }
 210
 211 sub write_file {
 212    my $f = shift;
 213    File::Slurp::write_file(($f eq '-' ? \*STDOUT : $f), @_);
 214 }
 215
 216 sub get_module_contents {
 217    my ($filename) = @_;
 218    for my $item (@INC) {
 219       my $full_path =
 220         foreign_file('Unix', $item . '/' . $filename)->stringify();
 221       next unless -e $full_path;
 222       return scalar read_file $full_path;
 223    } ## end for my $item (@INC)
 224    carp "could not find module file: '$filename'";
 225 } ## end sub get_module_contents
 226
 227 __END__
 228
 229 =head1 NAME
 230
 231 mobundle - bundle modules inside your scripts
 232
 233 =head1 VERSION
 234
 235 Ask the version number to the script itself, calling:
 236
 237    shell$ mobundle --version
 238
 239 =head1 USAGE
 240
 241    mobundle [--usage] [--help] [--man] [--version]
 242
 243    mobundle [--autoscan|--scan|-a]
 244             [--autoscan-list|--scanlist|-l]
 245             [--body|-b <body>]
 246             [--body-from|--script|--program|-B <filename>]
 247             [--head|-h <head>] [--head-from|-H <filename>]
 248             [--head-from-body|-S <n>]
 249             [--head-from-paragraph|-P]
 250             [--module|-m <name>]
 251             [--modules-from|-M <filename>]
 252             [--output|-o <filename>]
 253             [--standard-head|-s]
 254
 255 =head1 EXAMPLES
 256
 257    shell$ mobundle -m Template::Perlish yourscript.pl
 258
 259    shell$ mobundle -m Template::Perlish --head '#!/path/to/perl' yscript.pl
 260
 261    shell$ mobundle -m Acme::Laugh --head-from-paragraph laugh.pl
 262
 263    # This lists all the modules that mobundle would include with
 264    # --autoscan|--scan|-a. Save it, trim it and you're done!
 265    shell$ mobundle --autoscan-list laugh.pl
 266
 267 =head1 DESCRIPTION
 268
 269 C<mobundle> lets you bundle Perl modules inside your Perl script, in order
 270 to ship a single script instead of N separate files.
 271
 272 The underlying logic is simple: all modules are included in the generated
 273 script, and the module loading mechanism is tweaked in order to let you
 274 load the bundled modules. See the documentation for L<perlfunc/require>
 275 to understand how.
 276
 277 The generated script will be compound of three main parts: a C<head>,
 278 a section with the bundled modules and the logic to load them, and
 279 a C<body>. Briefly speaking:
 280
 281 =over
 282
 283 =item B<head>
 284
 285 this is where you should put your shabang and the C<use>s that you would
 286 like to happen before the module loading mechanism is tweaked.
 287
 288 The C<head> is guaranteed to start at the very first octet in the result,
 289 so you can put a shabang.
 290
 291 =item B<modules>
 292
 293 this part is generated automatically based on your instructions about which
 294 modules should be bundled.
 295
 296 =item B<body>
 297
 298 this is the body of your script, i.e. what your script is supposed to do.
 299 It will likely contain either C<use>s or C<require>s that need the modules
 300 that are bundled in the C<modules> section.
 301
 302 =back
 303
 304 =head2 Why Another? Use PAR!
 305
 306 L<PAR> is fantastic: lets you bundle all the needed components of your
 307 application inside a single executable, and ship it. But... there's a
 308 niche that it's not able to cover, at least looking at the documentation.
 309
 310 In particular, there seem to be two different operation modes, depending
 311 on your needs
 312
 313 =over
 314
 315 =item *
 316
 317 either you're willing to bundle the interpreter as well, in which case
 318 L<PAR> (or, better, L<pp>) will generate a super-executable bundling all
 319 necessary stuff
 320
 321 =item *
 322
 323 or you have to be sure that L<PAR> is installed in the target directory.
 324
 325 =back
 326
 327 My need was somewhere in between: on the one side I wasn't willing to bundle
 328 the interpreter, on the other I couldn't ensure that L<PAR> was available.
 329
 330 In particular, this kind of need arises every time that my programs only need
 331 Pure-Perl modules, that do not need any platform-specific installation
 332 process. In this case, bundling the interpreter means restricting the
 333 applicability to one (or more, at some cost) platform only; the other way
 334 is simply not acceptable in some environments.
 335
 336
 337 =head1 OPTIONS
 338
 339 =over
 340
 341 =item --autoscan | -scan | -a
 342
 343 tries to use L<Module::ScanDeps> to find non-core modules that might be
 344 needed. Note that this is not PAR, so you should be careful of what is
 345 taken in.
 346
 347 For example, L<Archive::Tar> can operate without L<IO::Zlib>, but
 348 L<Module::ScanDeps> will bring it in together with a lot of stuff.
 349
 350 =item --body | -b <body>
 351
 352 turn your one-liner in a self contained script! Just pass the C<body> of your
 353 script and you're done.
 354
 355 =item --body-from | -B <filename>
 356
 357 get the body of the target script from the given filename.
 358
 359 =item --head | -h <head>
 360
 361 the C<head> is the part that will be put at the very beginning of the
 362 resulting script. Can be useful to specify a shabang.
 363
 364 =item --head-from | -H <filename>
 365
 366 get the C<head> from the given filename. See L</head>.
 367
 368 =item --head-from-body | -S <n>
 369
 370 get the C<head> taking it from the first C<n> lines of the body. See
 371 L</head> and L</body>.
 372
 373 =item --head-from-paragraph | -P
 374
 375 get the C<head> from the very first paragraph in the C<body>. See
 376 L</head> and L</body>.
 377
 378 =item --help
 379
 380 print a somewhat more verbose help, showing usage, this description of
 381 the options and some examples from the synopsis.
 382
 383 =item --man
 384
 385 print out the full documentation for the script.
 386
 387 =item --module | -m <name>
 388
 389 include the given module in the final script. You can specify this option
 390 multiple times for multiple modules.
 391
 392 When used with L</--autoscan>, these modules are skipped during the scan.
 393
 394 =item --modules-from | -M <filename>
 395
 396 get a list of modules to bundle from the given filename.
 397
 398 =item --modules-list | -l
 399
 400 print out a list of modules.
 401
 402 =item --usage
 403
 404 print a concise usage line and exit. You can specify this option
 405 multiple times for multiple modules.
 406
 407 When used with L</--autoscan>, these modules are skipped during the scan.
 408
 409 =item --output | -o <filename>
 410
 411 set a filename for output, instead of standard output. When C<-> is given,
 412 standard output is assumed.
 413
 414 =item --standard-head | -s
 415
 416 put a standard header at the beginning of the generated script, i.e.:
 417
 418    #!/usr/bin/env perl
 419
 420 =item --version
 421
 422 print the version of the script.
 423
 424 =back
 425
 426 =head1 CONFIGURATION AND ENVIRONMENT
 427
 428 mobundle requires no configuration files or environment variables.
 429
 430 =head1 DEPENDENCIES
 431
 432 Non-core modules needed:
 433
 434 =over
 435
 436 =item B<< File::Slurp >>
 437
 438 =item B<< Template::Perlish >>
 439
 440 =item B<< Path::Class >>
 441
 442 =item B<< Module::ScanDeps >>
 443
 444 but only if you want to use the L</--autoscan> option.
 445
 446 =back
 447
 448 Did you say that I should I<bundle> them?!?
 449
 450 =head1 BUGS AND LIMITATIONS
 451
 452 No bugs have been reported.
 453
 454 Please report any bugs or feature requests through http://rt.cpan.org/
 455
 456 Undoubtfully there are many bugs, and more limitations.
 457
 458 =head1 AUTHOR
 459
 460 Flavio Poletti C<flavio@polettix.it>
 461
 462 =head1 LICENCE AND COPYRIGHT
 463
 464 Copyright (c) 2008, Flavio Poletti C<flavio@polettix.it>. All rights reserved.
 465
 466 This script is free software; you can redistribute it and/or
 467 modify it under the same terms as Perl itself. See L<perlartistic>
 468 and L<perlgpl>.
 469
 470 Questo script è software libero: potete ridistribuirlo e/o
 471 modificarlo negli stessi termini di Perl stesso. Vedete anche
 472 L<perlartistic> e L<perlgpl>.
 473
 474
 475 =head1 DISCLAIMER OF WARRANTY
 476
 477 BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
 478 FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
 479 OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
 480 PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
 481 EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
 482 WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
 483 ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
 484 YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
 485 NECESSARY SERVICING, REPAIR, OR CORRECTION.
 486
 487 IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
 488 WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
 489 REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE
 490 LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
 491 OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
 492 THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
 493 RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
 494 FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
 495 SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
 496 SUCH DAMAGES.
 497
 498 =head1 NEGAZIONE DELLA GARANZIA
 499
 500 Poiché questo software viene dato con una licenza gratuita, non
 501 c'è alcuna garanzia associata ad esso, ai fini e per quanto permesso
 502 dalle leggi applicabili. A meno di quanto possa essere specificato
 503 altrove, il proprietario e detentore del copyright fornisce questo
 504 software "così com'è" senza garanzia di alcun tipo, sia essa espressa
 505 o implicita, includendo fra l'altro (senza però limitarsi a questo)
 506 eventuali garanzie implicite di commerciabilità e adeguatezza per
 507 uno scopo particolare. L'intero rischio riguardo alla qualità ed
 508 alle prestazioni di questo software rimane a voi. Se il software
 509 dovesse dimostrarsi difettoso, vi assumete tutte le responsabilità
 510 ed i costi per tutti i necessari servizi, riparazioni o correzioni.
 511
 512 In nessun caso, a meno che ciò non sia richiesto dalle leggi vigenti
 513 o sia regolato da un accordo scritto, alcuno dei detentori del diritto
 514 di copyright, o qualunque altra parte che possa modificare, o redistribuire
 515 questo software così come consentito dalla licenza di cui sopra, potrà
 516 essere considerato responsabile nei vostri confronti per danni, ivi
 517 inclusi danni generali, speciali, incidentali o conseguenziali, derivanti
 518 dall'utilizzo o dall'incapacità di utilizzo di questo software. Ciò
 519 include, a puro titolo di esempio e senza limitarsi ad essi, la perdita
 520 di dati, l'alterazione involontaria o indesiderata di dati, le perdite
 521 sostenute da voi o da terze parti o un fallimento del software ad
 522 operare con un qualsivoglia altro software. Tale negazione di garanzia
 523 rimane in essere anche se i dententori del copyright, o qualsiasi altra
 524 parte, è stata avvisata della possibilità di tali danneggiamenti.
 525
 526 Se decidete di utilizzare questo software, lo fate a vostro rischio
 527 e pericolo. Se pensate che i termini di questa negazione di garanzia
 528 non si confacciano alle vostre esigenze, o al vostro modo di
 529 considerare un software, o ancora al modo in cui avete sempre trattato
 530 software di terze parti, non usatelo. Se lo usate, accettate espressamente
 531 questa negazione di garanzia e la piena responsabilità per qualsiasi
 532 tipo di danno, di qualsiasi natura, possa derivarne.
 533
 534 =cut