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 version; my $VERSION = qv('0.0.1');
   8 use English qw( -no_match_vars );
   9 use File::Slurp ();
  10 use Template::Perlish;
  11 use Path::Class qw( foreign_file dir );
  12 use File::Basename qw( basename );
  13
  14 # Other recommended modules (uncomment to use):
  15 #  use IO::Prompt;
  16 #  use Readonly;
  17 #  use Data::Dumper;
  18
  19 # Integrated logging facility
  20 #  use Log::Log4perl qw( :easy :no_extra_logdie_message );
  21 #  Log::Log4perl->easy_init({level=>$INFO, layout=>'[%d %-5p] %m%n'});
  22
  23 my %config = (output => '-', 'modules-from' => []);
  24 GetOptions(
  25    \%config,
  26    qw(
  27      usage help man version
  28      modules|module|m=s@
  29      modules-from|M=s@
  30      autoscan|scan|a!
  31      head|h=s
  32      head-from|H=s
  33      head-from-body|S:i
  34      head-from-paragraph|P!
  35      body|b=s
  36      body-from|script|program|B=s
  37      output|o=s
  38      standard-head|s!
  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 # Various checks for input parameter consistence and overriding
  49 pod2usage(
  50    message   => "head and standard-head are mutually exclusive",
  51    -verbose  => 99,
  52    -sections => ''
  53 ) if exists($config{head}) && exists($config{'standard-head'});
  54 $config{head} = "#!/usr/bin/env perl\n"
  55   if exists $config{'standard-head'};
  56
  57 pod2usage(
  58    message   => "(standard-)head and head-from are mutually exclusive",
  59    -verbose  => 99,
  60    -sections => ''
  61 ) if exists($config{head}) && exists($config{'head-from'});
  62 $config{head} = read_file($config{'head-from'})
  63   if exists $config{'head-from'};
  64
  65 pod2usage(
  66    message   => "body and body-from are mutually exclusive",
  67    -verbose  => 99,
  68    -sections => ''
  69 ) if exists($config{body}) && exists($config{'body-from'});
  70 $config{body} = read_file($config{'body-from'})
  71   if exists $config{'body-from'};
  72
  73 if (exists $config{'head-from-body'}) {
  74    pod2usage(
  75       message   => "multiple head sources are not allowed",
  76       -verbose  => 99,
  77       -sections => ''
  78    ) if exists($config{head});
  79
  80    my @body = split /\n/, $config{body};
  81    my @header = splice @body, 0, $config{'head-from-body'} || 1;
  82
  83    $config{head} = join "\n", @header;
  84    $config{body} = join "\n", @body;
  85 } ## end if (exists $config{'head-from-body'...
  86
  87 if (exists $config{'head-from-paragraph'}) {
  88    pod2usage(
  89       message   => "multiple head sources are not allowed",
  90       -verbose  => 99,
  91       -sections => ''
  92    ) if exists($config{head});
  93
  94    ($config{head}, $config{body}) = split /\n\s*?\n/, $config{body}, 2;
  95 }
  96
  97 for my $file (@{$config{'modules-from'}}) {
  98    chomp(my @modules = read_file($file));
  99    push @{$config{modules}}, @modules;
 100 }
 101
 102 # Load files for explicitly requested modules
 103 my %modules = map {
 104    (my $filename = $_) =~ s{::}{/}g;
 105    $filename .= '.pm' unless $filename =~ /\./mxs;
 106    $filename => get_module_contents($filename);
 107 } @{$config{modules}};
 108
 109 # Now autoscan if requested. Already-loaded modules will be skipped
 110 if ($config{autoscan}) {
 111    require Module::ScanDeps;
 112    require File::Temp;
 113    require Config;
 114
 115    my $fh = File::Temp->new(UNLINK => 1, SUFFIX => '.pl');
 116    binmode $fh;
 117    print {$fh} $config{body};
 118    $fh->close();
 119
 120    my $filename = $fh->filename();
 121    my $deps_for =
 122      Module::ScanDeps::scan_deps(files => [$filename], skip => {%modules});
 123
 124    my $priv = dir($Config::Config{privlib});
 125    my $arch = dir($Config::Config{archlib});
 126    while (my ($key, $mod) = each %$deps_for) {
 127       # Restrict to modules...
 128       next unless $mod->{type} eq 'module';
 129
 130       my $privPath = $priv->file($key)->as_foreign('Unix');
 131       my $archPath = $arch->file($key)->as_foreign('Unix');
 132       next if $mod->{file} eq $privPath || $mod->{file} eq $archPath;
 133
 134       $modules{$key} = read_file($mod->{file});
 135    } ## end while (my ($key, $mod) = ...
 136 } ## end if ($config{autoscan})
 137
 138 $config{modules} = \%modules;
 139
 140 my $template = <<'END_OF_TEMPLATE';
 141 [% head %]
 142
 143 BEGIN {
 144    my %file_for = (
 145 [% while (my ($filename, $contents) = each %{$variables{modules}}) { %]
 146       '[%= $filename %]' => <<'END_OF_FILE',
 147 [%= $contents =~ s/^/ /gmxs; $contents; %]
 148 END_OF_FILE
 149 [% } %]
 150    );
 151
 152    unshift @INC, sub {
 153       my ($me, $packfile) = @_;
 154       return unless exists $file_for{$packfile};
 155       (my $text = $file_for{$packfile}) =~ s/^\ //gmxs;
 156       chop($text); # added \n at the end
 157       open my $fh, '<', \$text or die "open(): $!\n";
 158       return $fh;
 159    };
 160 } ## end BEGIN
 161
 162 [% body %]
 163 END_OF_TEMPLATE
 164
 165 write_file($config{output},
 166    Template::Perlish->new()->process($template, \%config));
 167
 168 sub read_file {
 169    File::Slurp::read_file $_[0] eq '-' ? \*STDIN : $_[0];
 170 }
 171
 172 sub write_file {
 173    my $f = shift;
 174    File::Slurp::write_file(($f eq '-' ? \*STDOUT : $f), @_);
 175 }
 176
 177 sub get_module_contents {
 178    my ($filename) = @_;
 179    for my $item (@INC) {
 180       my $full_path =
 181         foreign_file('Unix', $item . '/' . $filename)->stringify();
 182       next unless -e $full_path;
 183       return scalar read_file $full_path;
 184    } ## end for my $item (@INC)
 185    carp "could not find module file: '$filename'";
 186 } ## end sub get_module_contents
 187
 188 __END__
 189
 190 =head1 NAME
 191
 192 mcarry - [Una riga di descrizione dello scopo dello script]
 193
 194 =head1 VERSION
 195
 196 Ask the version number to the script itself, calling:
 197
 198    shell$ mcarry --version
 199
 200
 201 =head1 USAGE
 202
 203    mcarry [--usage] [--help] [--man] [--version]
 204
 205    mcarry
 206
 207 =head1 EXAMPLES
 208
 209    shell$ mcarry
 210
 211 =for l'autore, da riempire:
 212    Qualche breve esempio con codice che mostri l'utilizzo più comune.
 213    Questa sezione sarà quella probabilmente più letta, perché molti
 214    utenti si annoiano a leggere tutta la documentazione, per cui
 215    è meglio essere il più educativi ed esplicativi possibile.
 216
 217
 218 =head1 DESCRIPTION
 219
 220 =for l'autore, da riempire:
 221    Fornite una descrizione completa del modulo e delle sue caratteristiche.
 222    Aiutatevi a strutturare il testo con le sottosezioni (=head2, =head3)
 223    se necessario.
 224
 225
 226 =head1 OPTIONS
 227
 228 =for l'autore, da riempire:
 229    Una descrizione di tutte le opzioni possibili nella chiamata allo script
 230
 231 =over
 232
 233 =item --help
 234
 235 print a somewhat more verbose help, showing usage, this description of
 236 the options and some examples from the synopsis.
 237
 238 =item --man
 239
 240 print out the full documentation for the script.
 241
 242 =item --usage
 243
 244 print a concise usage line and exit.
 245
 246 =item --version
 247
 248 print the version of the script.
 249
 250 =back
 251
 252 =head1 DIAGNOSTICS
 253
 254 =for l'autore, da riempire:
 255    Elencate qualunque singolo errore o messaggio di avvertimento che
 256    lo script può generare, anche quelli che non "accadranno mai".
 257    Includete anche una spiegazione completa di ciascuno di questi
 258    problemi, una o più possibili cause e qualunque rimedio
 259    suggerito.
 260
 261
 262 =over
 263
 264 =item C<< Error message here, perhaps with %s placeholders >>
 265
 266 [Descrizione di un errore]
 267
 268 =item C<< Another error message here >>
 269
 270 [Descrizione di un errore]
 271
 272 [E così via...]
 273
 274 =back
 275
 276
 277 =head1 CONFIGURATION AND ENVIRONMENT
 278
 279 =for l'autore, da riempire:
 280    Una spiegazione completa di qualunque sistema di configurazione
 281    utilizzato dallo script, inclusi i nomi e le posizioni dei file di
 282    configurazione, il significato di ciascuna variabile di ambiente
 283    utilizzata e proprietà che può essere impostata. Queste descrizioni
 284    devono anche includere dettagli su eventuali linguaggi di configurazione
 285    utilizzati.
 286
 287 mcarry requires no configuration files or environment variables.
 288
 289
 290 =head1 DEPENDENCIES
 291
 292 =for l'autore, da riempire:
 293    Una lista di tutti i moduli su cui si basa questo script,
 294    incluse eventuali restrizioni sulle relative versioni, ed una
 295    indicazione se il modulo in questione è parte della distribuzione
 296    standard di Perl, parte della distribuzione del modulo o se
 297    deve essere installato separatamente.
 298
 299 None.
 300
 301
 302 =head1 BUGS AND LIMITATIONS
 303
 304 =for l'autore, da riempire:
 305    Una lista di tutti i problemi conosciuti relativi al modulo,
 306    insime a qualche indicazione sul fatto che tali problemi siano
 307    plausibilmente risolti in una versione successiva. Includete anche
 308    una lista delle restrizioni sulle funzionalità fornite dal
 309    modulo: tipi di dati che non si è in grado di gestire, problematiche
 310    relative all'efficienza e le circostanze nelle quali queste possono
 311    sorgere, limitazioni pratiche sugli insiemi dei dati, casi
 312    particolari che non sono (ancora) gestiti, e così via.
 313
 314 No bugs have been reported.
 315
 316 Please report any bugs or feature requests through http://rt.cpan.org/
 317
 318
 319 =head1 AUTHOR
 320
 321 Flavio Poletti C<flavio@polettix.it>
 322
 323
 324 =head1 LICENCE AND COPYRIGHT
 325
 326 Copyright (c) 2008, Flavio Poletti C<flavio@polettix.it>. All rights reserved.
 327
 328 This script is free software; you can redistribute it and/or
 329 modify it under the same terms as Perl itself. See L<perlartistic>
 330 and L<perlgpl>.
 331
 332 Questo script è software libero: potete ridistribuirlo e/o
 333 modificarlo negli stessi termini di Perl stesso. Vedete anche
 334 L<perlartistic> e L<perlgpl>.
 335
 336
 337 =head1 DISCLAIMER OF WARRANTY
 338
 339 BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
 340 FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
 341 OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
 342 PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
 343 EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
 344 WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
 345 ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
 346 YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
 347 NECESSARY SERVICING, REPAIR, OR CORRECTION.
 348
 349 IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
 350 WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
 351 REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE
 352 LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
 353 OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
 354 THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
 355 RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
 356 FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
 357 SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
 358 SUCH DAMAGES.
 359
 360 =head1 NEGAZIONE DELLA GARANZIA
 361
 362 Poiché questo software viene dato con una licenza gratuita, non
 363 c'è alcuna garanzia associata ad esso, ai fini e per quanto permesso
 364 dalle leggi applicabili. A meno di quanto possa essere specificato
 365 altrove, il proprietario e detentore del copyright fornisce questo
 366 software "così com'è" senza garanzia di alcun tipo, sia essa espressa
 367 o implicita, includendo fra l'altro (senza però limitarsi a questo)
 368 eventuali garanzie implicite di commerciabilità e adeguatezza per
 369 uno scopo particolare. L'intero rischio riguardo alla qualità ed
 370 alle prestazioni di questo software rimane a voi. Se il software
 371 dovesse dimostrarsi difettoso, vi assumete tutte le responsabilità
 372 ed i costi per tutti i necessari servizi, riparazioni o correzioni.
 373
 374 In nessun caso, a meno che ciò non sia richiesto dalle leggi vigenti
 375 o sia regolato da un accordo scritto, alcuno dei detentori del diritto
 376 di copyright, o qualunque altra parte che possa modificare, o redistribuire
 377 questo software così come consentito dalla licenza di cui sopra, potrà
 378 essere considerato responsabile nei vostri confronti per danni, ivi
 379 inclusi danni generali, speciali, incidentali o conseguenziali, derivanti
 380 dall'utilizzo o dall'incapacità di utilizzo di questo software. Ciò
 381 include, a puro titolo di esempio e senza limitarsi ad essi, la perdita
 382 di dati, l'alterazione involontaria o indesiderata di dati, le perdite
 383 sostenute da voi o da terze parti o un fallimento del software ad
 384 operare con un qualsivoglia altro software. Tale negazione di garanzia
 385 rimane in essere anche se i dententori del copyright, o qualsiasi altra
 386 parte, è stata avvisata della possibilità di tali danneggiamenti.
 387
 388 Se decidete di utilizzare questo software, lo fate a vostro rischio
 389 e pericolo. Se pensate che i termini di questa negazione di garanzia
 390 non si confacciano alle vostre esigenze, o al vostro modo di
 391 considerare un software, o ancora al modo in cui avete sempre trattato
 392 software di terze parti, non usatelo. Se lo usate, accettate espressamente
 393 questa negazione di garanzia e la piena responsabilità per qualsiasi
 394 tipo di danno, di qualsiasi natura, possa derivarne.
 395
 396 =cut