├── Changes ├── MANIFEST ├── META.json ├── META.yml ├── Makefile.PL ├── README ├── README.markdown ├── examples └── colorize ├── inc └── Module │ ├── AutoInstall.pm │ ├── Install.pm │ └── Install │ ├── AutoInstall.pm │ ├── Base.pm │ ├── Can.pm │ ├── Fetch.pm │ ├── Include.pm │ ├── Makefile.pm │ ├── Metadata.pm │ ├── Win32.pm │ └── WriteAll.pm ├── lib └── DB │ ├── Color.pm │ └── Color │ ├── Config.pm │ └── Highlight.pm ├── script └── perldbsyntax ├── t ├── 00-load.t └── highlight.t └── xt ├── manifest.t ├── pod-coverage.t └── pod.t /Changes: -------------------------------------------------------------------------------- 1 | Revision history for DB-Color 2 | 3 | 0.20 2015/11/21 4 | - Add optional sentinel support to avoid loading DB::Color unless 5 | requested. 6 | - Add an example in examples/colorize of a program which can 7 | continuously colorize your files on the fly. 8 | - Add a "WORKFLOW" section to the docs to explain more efficient usage 9 | of this module. 10 | - Remove Module::Build. RIP :/ 11 | 12 | 0.10 2012/01/08 13 | - Fix "Argument isn't numeric" warnings. 14 | - Assert minimum version of File::Path to fix "make_path is not 15 | exported" build failures. 16 | 17 | 0.09 2012/09/05 18 | - Don't use BRIGHT_BLUE if they have Term::ANSIColor < 3 (Cosimo 19 | Streppone) 20 | 21 | 0.08 2012/04/08 22 | - Fixed bug where two or more package declarations in a single file 23 | would break syntax highlighting. 24 | - Added a perldbsyntax script to pre-generate syntax files. 25 | 26 | 0.07 2012/04/01 27 | - Add a config file to let people control some behavior. 28 | - The afterinit() sub is no longer required in the .perldb file (it's 29 | done internally). 30 | - The md5 sum is now generate with the "format number" and classname. 31 | - Caching can now be disabled by not passing a cache_dir to the 32 | highlighter. 33 | 34 | 0.06 2012/03/31 35 | - Don't highlight if NO_DB_COLOR environment variable is set to a true value. 36 | - Add optional debugging to log file (internal and undocumented. Use 37 | at own risk. 38 | - Naive caching of output files. File deleted after thirty days of 39 | non-use. 40 | - Workaround Syntax::Highlight::Kate POD bug (https://rt.cpan.org/Ticket/Display.html?id=76160) 41 | - Fix broken breakpoints. Thanks to Nick Perez and Liz for the help! 42 | - Fix off-by-one error (Thanks Liz!) 43 | 44 | 0.05 2012/01/04 45 | - Ouch! Add the actual highlighter to the MANIFEST 46 | 47 | 0.04 2012/01/04 48 | - Fix Github link in Build.PL 49 | 50 | 0.03 2012/01/04 51 | - Add Build.PL. List github repo. 52 | - Syntax highlighter requires 5.8.0, so put that in the Makefile.PL 53 | - POD for DB::Color::Highlighter. 54 | 55 | 0.02 2011/12/30 56 | - Quick hack to silence uninit warnings in DB::DB 57 | - Silence warnings from Kate highlighter 58 | - Tried to make the colors easier to work with 59 | 60 | 0.01 2011/12/30 61 | - Debugger syntax highlighting 62 | 63 | -------------------------------------------------------------------------------- /MANIFEST: -------------------------------------------------------------------------------- 1 | Build.PL 2 | Changes 3 | examples/colorize 4 | inc/Module/AutoInstall.pm 5 | inc/Module/Install.pm 6 | inc/Module/Install/AutoInstall.pm 7 | inc/Module/Install/Base.pm 8 | inc/Module/Install/Can.pm 9 | inc/Module/Install/Fetch.pm 10 | inc/Module/Install/Include.pm 11 | inc/Module/Install/Makefile.pm 12 | inc/Module/Install/Metadata.pm 13 | inc/Module/Install/Win32.pm 14 | inc/Module/Install/WriteAll.pm 15 | lib/DB/Color.pm 16 | lib/DB/Color/Config.pm 17 | lib/DB/Color/Highlight.pm 18 | Makefile.PL 19 | MANIFEST This list of files 20 | META.json 21 | META.yml 22 | README 23 | README.markdown 24 | script/perldbsyntax 25 | t/00-load.t 26 | t/highlight.t 27 | xt/manifest.t 28 | xt/pod-coverage.t 29 | xt/pod.t 30 | -------------------------------------------------------------------------------- /META.json: -------------------------------------------------------------------------------- 1 | { 2 | "abstract" : "Colorize your debugger output", 3 | "author" : [ 4 | "Curtis 'Ovid' Poe " 5 | ], 6 | "dynamic_config" : 1, 7 | "generated_by" : "Module::Build version 0.4, CPAN::Meta::Converter version 2.120351", 8 | "license" : [ 9 | "perl_5" 10 | ], 11 | "meta-spec" : { 12 | "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", 13 | "version" : "2" 14 | }, 15 | "name" : "DB-Color", 16 | "prereqs" : { 17 | "build" : { 18 | "requires" : { 19 | "Test::More" : "0" 20 | } 21 | }, 22 | "configure" : { 23 | "requires" : { 24 | "Module::Build" : "0.4" 25 | } 26 | }, 27 | "runtime" : { 28 | "requires" : { 29 | "Digest::MD5" : "0", 30 | "File::Path" : "2.07", 31 | "Syntax::Highlight::Engine::Kate" : "0.06", 32 | "Term::ANSIColor" : "0" 33 | } 34 | } 35 | }, 36 | "provides" : { 37 | "DB::Color" : { 38 | "file" : "lib/DB/Color.pm", 39 | "version" : "0.10" 40 | }, 41 | "DB::Color::Config" : { 42 | "file" : "lib/DB/Color/Config.pm", 43 | "version" : "0.10" 44 | }, 45 | "DB::Color::Highlight" : { 46 | "file" : "lib/DB/Color/Highlight.pm", 47 | "version" : "0.10" 48 | } 49 | }, 50 | "release_status" : "stable", 51 | "resources" : { 52 | "license" : [ 53 | "http://dev.perl.org/licenses/" 54 | ], 55 | "repository" : { 56 | "url" : "https://github.com/Ovid/DB--Color" 57 | } 58 | }, 59 | "version" : "0.10" 60 | } 61 | -------------------------------------------------------------------------------- /META.yml: -------------------------------------------------------------------------------- 1 | --- 2 | abstract: 'Colorize your debugger output' 3 | author: 4 | - "Curtis 'Ovid' Poe " 5 | build_requires: 6 | Test::More: 0 7 | configure_requires: 8 | Module::Build: 0.4 9 | dynamic_config: 1 10 | generated_by: 'Module::Build version 0.4, CPAN::Meta::Converter version 2.120351' 11 | license: perl 12 | meta-spec: 13 | url: http://module-build.sourceforge.net/META-spec-v1.4.html 14 | version: 1.4 15 | name: DB-Color 16 | provides: 17 | DB::Color: 18 | file: lib/DB/Color.pm 19 | version: 0.10 20 | DB::Color::Config: 21 | file: lib/DB/Color/Config.pm 22 | version: 0.10 23 | DB::Color::Highlight: 24 | file: lib/DB/Color/Highlight.pm 25 | version: 0.10 26 | requires: 27 | Digest::MD5: 0 28 | File::Path: 2.07 29 | Syntax::Highlight::Engine::Kate: 0.06 30 | Term::ANSIColor: 0 31 | resources: 32 | license: http://dev.perl.org/licenses/ 33 | repository: https://github.com/Ovid/DB--Color 34 | version: 0.10 35 | -------------------------------------------------------------------------------- /Makefile.PL: -------------------------------------------------------------------------------- 1 | use 5.006; 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | use inc::Module::Install; 5 | 6 | name 'DB-Color'; 7 | all_from 'lib/DB/Color.pm'; 8 | author q{Curtis "Ovid" Poe }; 9 | license 'artistic2'; 10 | 11 | perl_version 5.006; 12 | 13 | tests_recursive('t'); 14 | 15 | resources( 16 | homepage => 'https://github.com/Ovid/DB--Color', 17 | license => 'http://www.perlfoundation.org/artistic_license_2_0', 18 | repository => 'https://github.com/Ovid/DB--Color', 19 | bugtracker => 'https://github.com/Ovid/DB--Color/issues', 20 | ); 21 | 22 | configure_requires( 23 | 'Module::Install' => 0, 24 | ); 25 | 26 | build_requires( 27 | 'Test::More' => '0', 28 | ); 29 | 30 | requires( 31 | 'Syntax::Highlight::Engine::Kate' => 0.06, 32 | 'Digest::MD5' => 0, 33 | 'Term::ANSIColor' => 0, # 3.0 or better to get bright colors 34 | 'File::Path' => '2.07', 35 | ); 36 | 37 | install_as_cpan; 38 | auto_install; 39 | WriteAll; 40 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | DB-Color 2 | 3 | Syntax highlighting for the Perl debugger. 4 | 5 | Want this? 6 | http://blogs.perl.org/users/ovid/2010/11/syntax-highlighting-for-the-perl-debugger.html 7 | 8 | Then add this to your $HOME/.perldb 9 | 10 | use DB::Color; 11 | 12 | Then use your debugger like normal: 13 | 14 | perl -d some_file.pl 15 | 16 | If you don't want a $HOME/.perldb file: 17 | 18 | perl -MDB::Color -d some_file.pl 19 | 20 | See perldoc DB::Color for more information. 21 | 22 | This code is a proof of concept and is buggy. The syntax highlighting is 23 | buggy. Fix it :) 24 | 25 | INSTALLATION 26 | 27 | To install this module, run the following commands: 28 | 29 | perl Makefile.PL 30 | make 31 | make test 32 | make install 33 | 34 | SUPPORT AND DOCUMENTATION 35 | 36 | After installing, you can find documentation for this module with the 37 | perldoc command. 38 | 39 | perldoc DB::Color 40 | 41 | You can also look for information at: 42 | 43 | RT, CPAN's request tracker (report bugs here) 44 | http://rt.cpan.org/NoAuth/Bugs.html?Dist=DB-Color 45 | 46 | AnnoCPAN, Annotated CPAN documentation 47 | http://annocpan.org/dist/DB-Color 48 | 49 | CPAN Ratings 50 | http://cpanratings.perl.org/d/DB-Color 51 | 52 | Search CPAN 53 | http://search.cpan.org/dist/DB-Color/ 54 | 55 | 56 | LICENSE AND COPYRIGHT 57 | 58 | Copyright (C) 2011 Curtis "Ovid" Poe 59 | 60 | This program is free software; you can redistribute it and/or modify it 61 | under the terms of either: the GNU General Public License as published 62 | by the Free Software Foundation; or the Artistic License. 63 | 64 | See http://dev.perl.org/licenses/ for more information. 65 | 66 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | # NAME 2 | 3 | DB::Color - Colorize your debugger output 4 | 5 | # VERSION 6 | 7 | Version 0.08 8 | 9 | # SYNOPSIS 10 | 11 | Put the following in your `$HOME/.perldb` file: 12 | 13 | use DB::Color; 14 | 15 | Then use your debugger like normal: 16 | 17 | perl -d some_file.pl 18 | 19 | If you don't want a `$HOME/.perldb` file, you can do this: 20 | 21 | perl -MDB::Color -d some_file.pl 22 | 23 | # DISABLING COLOR 24 | 25 | If the NO_DB_COLOR environment variable is set to a true value, syntax 26 | highlighting will be disabled. 27 | 28 | # WINDOWS 29 | 30 | No, sorry. It's a combination of bad Windows support for ANSI escape sequences 31 | and bad debugger design. 32 | 33 | # PERFORMANCE 34 | 35 | When using the debugger and when you step into something, or continue to a 36 | breakpoint in a new file, the debugger may appear to hang for a moment 37 | (perhaps a long moment if the file is big) while the file is syntax 38 | highlighted and cached. The next time the debugger enters this file, the 39 | highlighting should be instantaneous. 40 | 41 | You can speed up the debugger by using the [perldbsyntax](http://search.cpan.org/perldoc?perldbsyntax) program which is 42 | included in this distribution. It will pregenerate syntax files for you. 43 | 44 | Syntax highlighting the code is very slow. As a result, we cache the output 45 | files in `$HOME/.perldbcolor`. This is done by calculating the md5 sum of the 46 | file contents. If the file is changed, we get a new sum. This means that 47 | syntax highlighting is very slow at first, but every time you hit the same 48 | file, assuming its unchanged, the cached version is served first. 49 | 50 | Note that the cache files are removed after they become 30 (but see config) 51 | days old without being used. If you use the debugger regularly, commonly 52 | debugged files will load very quickly (assuming they haven't changed). 53 | 54 | # CONFIGURATION 55 | 56 | You can configure `DB::Color` by creating a `$HOME/.perldbcolorrc` 57 | configuration file. It looks like this: 58 | 59 | [core] 60 | 61 | 62 | # the class that will highlight the code 63 | highlighter = DB::Color::Highlight 64 | 65 | 66 | # Any cache file not accessed after this number of days is purged 67 | cache_max_age = 30 68 | 69 | 70 | # where to put the cache dir 71 | cache_dir = /users/ovid/.perldbcolor 72 | 73 | 74 | The above values are more or less the defaults for this module. 75 | 76 | # ALPHA 77 | 78 | This is only a proof of concept. In fact, it's fair to say that this code 79 | sucks. It's not very configurable and has bugs. It's also going to possibly be 80 | a memory hog, as if the debugger wasn't bad enough already. 81 | 82 | # AUTHOR 83 | 84 | Curtis "Ovid" Poe, `` 85 | 86 | # BUGS 87 | 88 | Please report any bugs or feature requests to `bug-db-color at rt.cpan.org`, 89 | or through the web interface at 90 | [http://rt.cpan.org/NoAuth/ReportBug.html?Queue=DB-Color](http://rt.cpan.org/NoAuth/ReportBug.html?Queue=DB-Color). I will be 91 | notified, and then you'll automatically be notified of progress on your bug as 92 | I make changes. 93 | 94 | # SUPPORT 95 | 96 | You can find documentation for this module with the perldoc command. 97 | 98 | perldoc DB::Color 99 | 100 | You can also look for information at: 101 | 102 | - RT: CPAN's request tracker (report bugs here) 103 | 104 | [http://rt.cpan.org/NoAuth/Bugs.html?Dist=DB-Color](http://rt.cpan.org/NoAuth/Bugs.html?Dist=DB-Color) 105 | 106 | - AnnoCPAN: Annotated CPAN documentation 107 | 108 | [http://annocpan.org/dist/DB-Color](http://annocpan.org/dist/DB-Color) 109 | 110 | - CPAN Ratings 111 | 112 | [http://cpanratings.perl.org/d/DB-Color](http://cpanratings.perl.org/d/DB-Color) 113 | 114 | - Search CPAN 115 | 116 | [http://search.cpan.org/dist/DB-Color/](http://search.cpan.org/dist/DB-Color/) 117 | 118 | # ACKNOWLEDGEMENTS 119 | 120 | Thanks to Nick Perez, Liz, and the 2012 Perl Hackathon for helping to overcome 121 | some major hurdles with this module. 122 | 123 | # LICENSE AND COPYRIGHT 124 | 125 | Copyright 2011 Curtis "Ovid" Poe. 126 | 127 | This program is free software; you can redistribute it and/or modify it 128 | under the terms of either: the GNU General Public License as published 129 | by the Free Software Foundation; or the Artistic License. 130 | 131 | See http://dev.perl.org/licenses/ for more information. 132 | 133 | -------------------------------------------------------------------------------- /examples/colorize: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | # vim: filetype=perl 4 | 5 | use 5.18.0; 6 | use lib qw{lib t/lib t/tests}; 7 | use warnings; 8 | use autodie ':all'; 9 | use Capture::Tiny 'capture'; 10 | use Perl6::Junction 'any'; 11 | use DB::Color; 12 | use DB::Color::Highlight; 13 | use Time::HiRes qw/gettimeofday tv_interval/; 14 | use IO::Interactive qw/is_interactive/; 15 | use File::ChangeNotify; 16 | use File::Spec::Functions qw/catfile/; 17 | use Try::Tiny; 18 | 19 | # There's probably a better way to do this, but kqueue isn't very effective on 20 | # OS X 21 | package Do::Not::Load::KQueue { 22 | use Moose; 23 | extends 'File::ChangeNotify::Watcher::Default'; 24 | } 25 | 26 | MAIN(@ARGV); 27 | 28 | sub MAIN { 29 | my @dirs = @_; 30 | 31 | my $watcher = Do::Not::Load::KQueue->new( 32 | directories => \@dirs, 33 | filter => qr/\.(?:pm|pl|t)$/, 34 | ); 35 | 36 | my $highlighter = DB::Color::Highlight->new({ 37 | cache_dir => DB::Color::default_base_dir() 38 | }); 39 | 40 | my $allowed_event_types = any(qw/modify create/); 41 | 42 | while ( my @events = $watcher->wait_for_events() ) { 43 | EVENT: foreach my $event (@events) { 44 | next EVENT unless $event->type eq $allowed_event_types; 45 | highlight_code( $event, \@dirs, $highlighter ); 46 | } 47 | } 48 | } 49 | 50 | sub highlight_code { 51 | my ( $event, $dirs, $highlighter ) = @_; 52 | 53 | my $path = $event->path; 54 | foreach my $dir (@$dirs) { 55 | if ( $path =~ m{^\Q$dir\E/?(?.*)} ) { 56 | my $package = $+{package}; 57 | 58 | unless ( $package =~ /\.t$/ ) { 59 | # don't convert test files to package names 60 | $package =~ s/\.\w+$//; 61 | $package =~ s{/}{::}g; 62 | } 63 | 64 | # I was probably hacking on a file and accidentally saved 65 | # something which did not compile 66 | my $success; 67 | try { 68 | # ignore any output. Just check for success. 69 | capture { system($^X, '-c', $path) }; 70 | $success = 1; 71 | } 72 | catch { 73 | my $error = $@; 74 | say "Could not compile '$package': $error" if is_interactive; 75 | }; 76 | return unless $success; 77 | 78 | open my $fh, '<', $path; 79 | my $code = do { local $/; <$fh> }; 80 | my $start = [gettimeofday]; 81 | $highlighter->highlight_text($code); # this will cache it 82 | my $elapsed = tv_interval( $start, [gettimeofday] ); 83 | say "$elapsed seconds to colorize $package" if is_interactive; 84 | } 85 | } 86 | } 87 | 88 | __END__ 89 | 90 | =head1 NAME 91 | 92 | colorize - watch for file changes and colorize them 93 | 94 | =head1 SYNOPSIS 95 | 96 | colorize /absolute/path/lib /absolute/path/t/tests 97 | 98 | =head1 DESCRIPTION 99 | 100 | This program takes a list of directories and watches for changes to any files 101 | ending in C<.pm>, C<.pl>, or C<.t>. For any of those files, if the change 102 | types (per C is C or C, it will attempt to 103 | syntax highlight that file. Thus, while using the debugger, rather than syntax 104 | highlighting the code when you enter the debugger (and having a huge wait), 105 | this code attempts to syntax highlight your code C you enter the 106 | debugger. 107 | 108 | =head1 EXAMPLE ONLY 109 | 110 | This code is only an example. You'll likely need to customize it for your 111 | situation. 112 | 113 | =head1 AUTHOR 114 | 115 | Curtis "Ovid" Poe, C<< >> 116 | 117 | =head1 BUGS 118 | 119 | Please report any bugs or feature requests through the web interface at 120 | L. I will be notified, and then 121 | you'll automatically be notified of progress on your bug as I make changes. 122 | 123 | =head1 SUPPORT 124 | 125 | You can find documentation for this module with the perldoc command. 126 | 127 | perldoc DB::Color 128 | 129 | You can also look for information at: 130 | 131 | =over 4 132 | 133 | =item * Bug tracker (report bugs here) 134 | 135 | L 136 | 137 | =item * AnnoCPAN: Annotated CPAN documentation 138 | 139 | L 140 | 141 | =item * CPAN Ratings 142 | 143 | L 144 | 145 | =item * Search CPAN 146 | 147 | L 148 | 149 | =back 150 | 151 | =head1 ACKNOWLEDGEMENTS 152 | 153 | Thanks to Nick Perez, Liz, and the 2012 Perl Hackathon for helping to overcome 154 | some major hurdles with this module. 155 | 156 | =head1 LICENSE AND COPYRIGHT 157 | 158 | Copyright 2011 Curtis "Ovid" Poe. 159 | 160 | This program is free software; you can redistribute it and/or modify it 161 | under the terms of either: the GNU General Public License as published 162 | by the Free Software Foundation; or the Artistic License. 163 | 164 | See http://dev.perl.org/licenses/ for more information. 165 | 166 | 167 | =cut 168 | 169 | 1; # End of DB::Color 170 | -------------------------------------------------------------------------------- /inc/Module/AutoInstall.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::AutoInstall; 3 | 4 | use strict; 5 | use Cwd (); 6 | use File::Spec (); 7 | use ExtUtils::MakeMaker (); 8 | 9 | use vars qw{$VERSION}; 10 | BEGIN { 11 | $VERSION = '1.16'; 12 | } 13 | 14 | # special map on pre-defined feature sets 15 | my %FeatureMap = ( 16 | '' => 'Core Features', # XXX: deprecated 17 | '-core' => 'Core Features', 18 | ); 19 | 20 | # various lexical flags 21 | my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $InstallDepsTarget, $HasCPANPLUS ); 22 | my ( 23 | $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps, 24 | $UpgradeDeps 25 | ); 26 | my ( $PostambleActions, $PostambleActionsNoTest, $PostambleActionsUpgradeDeps, 27 | $PostambleActionsUpgradeDepsNoTest, $PostambleActionsListDeps, 28 | $PostambleActionsListAllDeps, $PostambleUsed, $NoTest); 29 | 30 | # See if it's a testing or non-interactive session 31 | _accept_default( $ENV{AUTOMATED_TESTING} or ! -t STDIN ); 32 | _init(); 33 | 34 | sub _accept_default { 35 | $AcceptDefault = shift; 36 | } 37 | 38 | sub _installdeps_target { 39 | $InstallDepsTarget = shift; 40 | } 41 | 42 | sub missing_modules { 43 | return @Missing; 44 | } 45 | 46 | sub do_install { 47 | __PACKAGE__->install( 48 | [ 49 | $Config 50 | ? ( UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) 51 | : () 52 | ], 53 | @Missing, 54 | ); 55 | } 56 | 57 | # initialize various flags, and/or perform install 58 | sub _init { 59 | foreach my $arg ( 60 | @ARGV, 61 | split( 62 | /[\s\t]+/, 63 | $ENV{PERL_AUTOINSTALL} || $ENV{PERL_EXTUTILS_AUTOINSTALL} || '' 64 | ) 65 | ) 66 | { 67 | if ( $arg =~ /^--config=(.*)$/ ) { 68 | $Config = [ split( ',', $1 ) ]; 69 | } 70 | elsif ( $arg =~ /^--installdeps=(.*)$/ ) { 71 | __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) ); 72 | exit 0; 73 | } 74 | elsif ( $arg =~ /^--upgradedeps=(.*)$/ ) { 75 | $UpgradeDeps = 1; 76 | __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) ); 77 | exit 0; 78 | } 79 | elsif ( $arg =~ /^--default(?:deps)?$/ ) { 80 | $AcceptDefault = 1; 81 | } 82 | elsif ( $arg =~ /^--check(?:deps)?$/ ) { 83 | $CheckOnly = 1; 84 | } 85 | elsif ( $arg =~ /^--skip(?:deps)?$/ ) { 86 | $SkipInstall = 1; 87 | } 88 | elsif ( $arg =~ /^--test(?:only)?$/ ) { 89 | $TestOnly = 1; 90 | } 91 | elsif ( $arg =~ /^--all(?:deps)?$/ ) { 92 | $AllDeps = 1; 93 | } 94 | } 95 | } 96 | 97 | # overrides MakeMaker's prompt() to automatically accept the default choice 98 | sub _prompt { 99 | goto &ExtUtils::MakeMaker::prompt unless $AcceptDefault; 100 | 101 | my ( $prompt, $default ) = @_; 102 | my $y = ( $default =~ /^[Yy]/ ); 103 | 104 | print $prompt, ' [', ( $y ? 'Y' : 'y' ), '/', ( $y ? 'n' : 'N' ), '] '; 105 | print "$default\n"; 106 | return $default; 107 | } 108 | 109 | # the workhorse 110 | sub import { 111 | my $class = shift; 112 | my @args = @_ or return; 113 | my $core_all; 114 | 115 | print "*** $class version " . $class->VERSION . "\n"; 116 | print "*** Checking for Perl dependencies...\n"; 117 | 118 | my $cwd = Cwd::getcwd(); 119 | 120 | $Config = []; 121 | 122 | my $maxlen = length( 123 | ( 124 | sort { length($b) <=> length($a) } 125 | grep { /^[^\-]/ } 126 | map { 127 | ref($_) 128 | ? ( ( ref($_) eq 'HASH' ) ? keys(%$_) : @{$_} ) 129 | : '' 130 | } 131 | map { +{@args}->{$_} } 132 | grep { /^[^\-]/ or /^-core$/i } keys %{ +{@args} } 133 | )[0] 134 | ); 135 | 136 | # We want to know if we're under CPAN early to avoid prompting, but 137 | # if we aren't going to try and install anything anyway then skip the 138 | # check entirely since we don't want to have to load (and configure) 139 | # an old CPAN just for a cosmetic message 140 | 141 | $UnderCPAN = _check_lock(1) unless $SkipInstall || $InstallDepsTarget; 142 | 143 | while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) { 144 | my ( @required, @tests, @skiptests ); 145 | my $default = 1; 146 | my $conflict = 0; 147 | 148 | if ( $feature =~ m/^-(\w+)$/ ) { 149 | my $option = lc($1); 150 | 151 | # check for a newer version of myself 152 | _update_to( $modules, @_ ) and return if $option eq 'version'; 153 | 154 | # sets CPAN configuration options 155 | $Config = $modules if $option eq 'config'; 156 | 157 | # promote every features to core status 158 | $core_all = ( $modules =~ /^all$/i ) and next 159 | if $option eq 'core'; 160 | 161 | next unless $option eq 'core'; 162 | } 163 | 164 | print "[" . ( $FeatureMap{ lc($feature) } || $feature ) . "]\n"; 165 | 166 | $modules = [ %{$modules} ] if UNIVERSAL::isa( $modules, 'HASH' ); 167 | 168 | unshift @$modules, -default => &{ shift(@$modules) } 169 | if ( ref( $modules->[0] ) eq 'CODE' ); # XXX: bugward compatibility 170 | 171 | while ( my ( $mod, $arg ) = splice( @$modules, 0, 2 ) ) { 172 | if ( $mod =~ m/^-(\w+)$/ ) { 173 | my $option = lc($1); 174 | 175 | $default = $arg if ( $option eq 'default' ); 176 | $conflict = $arg if ( $option eq 'conflict' ); 177 | @tests = @{$arg} if ( $option eq 'tests' ); 178 | @skiptests = @{$arg} if ( $option eq 'skiptests' ); 179 | 180 | next; 181 | } 182 | 183 | printf( "- %-${maxlen}s ...", $mod ); 184 | 185 | if ( $arg and $arg =~ /^\D/ ) { 186 | unshift @$modules, $arg; 187 | $arg = 0; 188 | } 189 | 190 | # XXX: check for conflicts and uninstalls(!) them. 191 | my $cur = _version_of($mod); 192 | if (_version_cmp ($cur, $arg) >= 0) 193 | { 194 | print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n"; 195 | push @Existing, $mod => $arg; 196 | $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; 197 | } 198 | else { 199 | if (not defined $cur) # indeed missing 200 | { 201 | print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n"; 202 | } 203 | else 204 | { 205 | # no need to check $arg as _version_cmp ($cur, undef) would satisfy >= above 206 | print "too old. ($cur < $arg)\n"; 207 | } 208 | 209 | push @required, $mod => $arg; 210 | } 211 | } 212 | 213 | next unless @required; 214 | 215 | my $mandatory = ( $feature eq '-core' or $core_all ); 216 | 217 | if ( 218 | !$SkipInstall 219 | and ( 220 | $CheckOnly 221 | or ($mandatory and $UnderCPAN) 222 | or $AllDeps 223 | or $InstallDepsTarget 224 | or _prompt( 225 | qq{==> Auto-install the } 226 | . ( @required / 2 ) 227 | . ( $mandatory ? ' mandatory' : ' optional' ) 228 | . qq{ module(s) from CPAN?}, 229 | $default ? 'y' : 'n', 230 | ) =~ /^[Yy]/ 231 | ) 232 | ) 233 | { 234 | push( @Missing, @required ); 235 | $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; 236 | } 237 | 238 | elsif ( !$SkipInstall 239 | and $default 240 | and $mandatory 241 | and 242 | _prompt( qq{==> The module(s) are mandatory! Really skip?}, 'n', ) 243 | =~ /^[Nn]/ ) 244 | { 245 | push( @Missing, @required ); 246 | $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; 247 | } 248 | 249 | else { 250 | $DisabledTests{$_} = 1 for map { glob($_) } @tests; 251 | } 252 | } 253 | 254 | if ( @Missing and not( $CheckOnly or $UnderCPAN) ) { 255 | require Config; 256 | my $make = $Config::Config{make}; 257 | if ($InstallDepsTarget) { 258 | print 259 | "*** To install dependencies type '$make installdeps' or '$make installdeps_notest'.\n"; 260 | } 261 | else { 262 | print 263 | "*** Dependencies will be installed the next time you type '$make'.\n"; 264 | } 265 | 266 | # make an educated guess of whether we'll need root permission. 267 | print " (You may need to do that as the 'root' user.)\n" 268 | if eval '$>'; 269 | } 270 | print "*** $class configuration finished.\n"; 271 | 272 | chdir $cwd; 273 | 274 | # import to main:: 275 | no strict 'refs'; 276 | *{'main::WriteMakefile'} = \&Write if caller(0) eq 'main'; 277 | 278 | return (@Existing, @Missing); 279 | } 280 | 281 | sub _running_under { 282 | my $thing = shift; 283 | print <<"END_MESSAGE"; 284 | *** Since we're running under ${thing}, I'll just let it take care 285 | of the dependency's installation later. 286 | END_MESSAGE 287 | return 1; 288 | } 289 | 290 | # Check to see if we are currently running under CPAN.pm and/or CPANPLUS; 291 | # if we are, then we simply let it taking care of our dependencies 292 | sub _check_lock { 293 | return unless @Missing or @_; 294 | 295 | if ($ENV{PERL5_CPANM_IS_RUNNING}) { 296 | return _running_under('cpanminus'); 297 | } 298 | 299 | my $cpan_env = $ENV{PERL5_CPAN_IS_RUNNING}; 300 | 301 | if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) { 302 | return _running_under($cpan_env ? 'CPAN' : 'CPANPLUS'); 303 | } 304 | 305 | require CPAN; 306 | 307 | if ($CPAN::VERSION > '1.89') { 308 | if ($cpan_env) { 309 | return _running_under('CPAN'); 310 | } 311 | return; # CPAN.pm new enough, don't need to check further 312 | } 313 | 314 | # last ditch attempt, this -will- configure CPAN, very sorry 315 | 316 | _load_cpan(1); # force initialize even though it's already loaded 317 | 318 | # Find the CPAN lock-file 319 | my $lock = MM->catfile( $CPAN::Config->{cpan_home}, ".lock" ); 320 | return unless -f $lock; 321 | 322 | # Check the lock 323 | local *LOCK; 324 | return unless open(LOCK, $lock); 325 | 326 | if ( 327 | ( $^O eq 'MSWin32' ? _under_cpan() : == getppid() ) 328 | and ( $CPAN::Config->{prerequisites_policy} || '' ) ne 'ignore' 329 | ) { 330 | print <<'END_MESSAGE'; 331 | 332 | *** Since we're running under CPAN, I'll just let it take care 333 | of the dependency's installation later. 334 | END_MESSAGE 335 | return 1; 336 | } 337 | 338 | close LOCK; 339 | return; 340 | } 341 | 342 | sub install { 343 | my $class = shift; 344 | 345 | my $i; # used below to strip leading '-' from config keys 346 | my @config = ( map { s/^-// if ++$i; $_ } @{ +shift } ); 347 | 348 | my ( @modules, @installed, @modules_to_upgrade ); 349 | while (my ($pkg, $ver) = splice(@_, 0, 2)) { 350 | 351 | # grep out those already installed 352 | if (_version_cmp(_version_of($pkg), $ver) >= 0) { 353 | push @installed, $pkg; 354 | if ($UpgradeDeps) { 355 | push @modules_to_upgrade, $pkg, $ver; 356 | } 357 | } 358 | else { 359 | push @modules, $pkg, $ver; 360 | } 361 | } 362 | 363 | if ($UpgradeDeps) { 364 | push @modules, @modules_to_upgrade; 365 | @installed = (); 366 | @modules_to_upgrade = (); 367 | } 368 | 369 | return @installed unless @modules; # nothing to do 370 | return @installed if _check_lock(); # defer to the CPAN shell 371 | 372 | print "*** Installing dependencies...\n"; 373 | 374 | return unless _connected_to('cpan.org'); 375 | 376 | my %args = @config; 377 | my %failed; 378 | local *FAILED; 379 | if ( $args{do_once} and open( FAILED, '.#autoinstall.failed' ) ) { 380 | while () { chomp; $failed{$_}++ } 381 | close FAILED; 382 | 383 | my @newmod; 384 | while ( my ( $k, $v ) = splice( @modules, 0, 2 ) ) { 385 | push @newmod, ( $k => $v ) unless $failed{$k}; 386 | } 387 | @modules = @newmod; 388 | } 389 | 390 | if ( _has_cpanplus() and not $ENV{PERL_AUTOINSTALL_PREFER_CPAN} ) { 391 | _install_cpanplus( \@modules, \@config ); 392 | } else { 393 | _install_cpan( \@modules, \@config ); 394 | } 395 | 396 | print "*** $class installation finished.\n"; 397 | 398 | # see if we have successfully installed them 399 | while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { 400 | if ( _version_cmp( _version_of($pkg), $ver ) >= 0 ) { 401 | push @installed, $pkg; 402 | } 403 | elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) { 404 | print FAILED "$pkg\n"; 405 | } 406 | } 407 | 408 | close FAILED if $args{do_once}; 409 | 410 | return @installed; 411 | } 412 | 413 | sub _install_cpanplus { 414 | my @modules = @{ +shift }; 415 | my @config = _cpanplus_config( @{ +shift } ); 416 | my $installed = 0; 417 | 418 | require CPANPLUS::Backend; 419 | my $cp = CPANPLUS::Backend->new; 420 | my $conf = $cp->configure_object; 421 | 422 | return unless $conf->can('conf') # 0.05x+ with "sudo" support 423 | or _can_write($conf->_get_build('base')); # 0.04x 424 | 425 | # if we're root, set UNINST=1 to avoid trouble unless user asked for it. 426 | my $makeflags = $conf->get_conf('makeflags') || ''; 427 | if ( UNIVERSAL::isa( $makeflags, 'HASH' ) ) { 428 | # 0.03+ uses a hashref here 429 | $makeflags->{UNINST} = 1 unless exists $makeflags->{UNINST}; 430 | 431 | } else { 432 | # 0.02 and below uses a scalar 433 | $makeflags = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) 434 | if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); 435 | 436 | } 437 | $conf->set_conf( makeflags => $makeflags ); 438 | $conf->set_conf( prereqs => 1 ); 439 | 440 | 441 | 442 | while ( my ( $key, $val ) = splice( @config, 0, 2 ) ) { 443 | $conf->set_conf( $key, $val ); 444 | } 445 | 446 | my $modtree = $cp->module_tree; 447 | while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { 448 | print "*** Installing $pkg...\n"; 449 | 450 | MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; 451 | 452 | my $success; 453 | my $obj = $modtree->{$pkg}; 454 | 455 | if ( $obj and _version_cmp( $obj->{version}, $ver ) >= 0 ) { 456 | my $pathname = $pkg; 457 | $pathname =~ s/::/\\W/; 458 | 459 | foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { 460 | delete $INC{$inc}; 461 | } 462 | 463 | my $rv = $cp->install( modules => [ $obj->{module} ] ); 464 | 465 | if ( $rv and ( $rv->{ $obj->{module} } or $rv->{ok} ) ) { 466 | print "*** $pkg successfully installed.\n"; 467 | $success = 1; 468 | } else { 469 | print "*** $pkg installation cancelled.\n"; 470 | $success = 0; 471 | } 472 | 473 | $installed += $success; 474 | } else { 475 | print << "."; 476 | *** Could not find a version $ver or above for $pkg; skipping. 477 | . 478 | } 479 | 480 | MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; 481 | } 482 | 483 | return $installed; 484 | } 485 | 486 | sub _cpanplus_config { 487 | my @config = (); 488 | while ( @_ ) { 489 | my ($key, $value) = (shift(), shift()); 490 | if ( $key eq 'prerequisites_policy' ) { 491 | if ( $value eq 'follow' ) { 492 | $value = CPANPLUS::Internals::Constants::PREREQ_INSTALL(); 493 | } elsif ( $value eq 'ask' ) { 494 | $value = CPANPLUS::Internals::Constants::PREREQ_ASK(); 495 | } elsif ( $value eq 'ignore' ) { 496 | $value = CPANPLUS::Internals::Constants::PREREQ_IGNORE(); 497 | } else { 498 | die "*** Cannot convert option $key = '$value' to CPANPLUS version.\n"; 499 | } 500 | push @config, 'prereqs', $value; 501 | } elsif ( $key eq 'force' ) { 502 | push @config, $key, $value; 503 | } elsif ( $key eq 'notest' ) { 504 | push @config, 'skiptest', $value; 505 | } else { 506 | die "*** Cannot convert option $key to CPANPLUS version.\n"; 507 | } 508 | } 509 | return @config; 510 | } 511 | 512 | sub _install_cpan { 513 | my @modules = @{ +shift }; 514 | my @config = @{ +shift }; 515 | my $installed = 0; 516 | my %args; 517 | 518 | _load_cpan(); 519 | require Config; 520 | 521 | if (CPAN->VERSION < 1.80) { 522 | # no "sudo" support, probe for writableness 523 | return unless _can_write( MM->catfile( $CPAN::Config->{cpan_home}, 'sources' ) ) 524 | and _can_write( $Config::Config{sitelib} ); 525 | } 526 | 527 | # if we're root, set UNINST=1 to avoid trouble unless user asked for it. 528 | my $makeflags = $CPAN::Config->{make_install_arg} || ''; 529 | $CPAN::Config->{make_install_arg} = 530 | join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) 531 | if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); 532 | 533 | # don't show start-up info 534 | $CPAN::Config->{inhibit_startup_message} = 1; 535 | 536 | # set additional options 537 | while ( my ( $opt, $arg ) = splice( @config, 0, 2 ) ) { 538 | ( $args{$opt} = $arg, next ) 539 | if $opt =~ /^(?:force|notest)$/; # pseudo-option 540 | $CPAN::Config->{$opt} = $opt eq 'urllist' ? [$arg] : $arg; 541 | } 542 | 543 | if ($args{notest} && (not CPAN::Shell->can('notest'))) { 544 | die "Your version of CPAN is too old to support the 'notest' pragma"; 545 | } 546 | 547 | local $CPAN::Config->{prerequisites_policy} = 'follow'; 548 | 549 | while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { 550 | MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; 551 | 552 | print "*** Installing $pkg...\n"; 553 | 554 | my $obj = CPAN::Shell->expand( Module => $pkg ); 555 | my $success = 0; 556 | 557 | if ( $obj and _version_cmp( $obj->cpan_version, $ver ) >= 0 ) { 558 | my $pathname = $pkg; 559 | $pathname =~ s/::/\\W/; 560 | 561 | foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { 562 | delete $INC{$inc}; 563 | } 564 | 565 | my $rv = do { 566 | if ($args{force}) { 567 | CPAN::Shell->force( install => $pkg ) 568 | } elsif ($args{notest}) { 569 | CPAN::Shell->notest( install => $pkg ) 570 | } else { 571 | CPAN::Shell->install($pkg) 572 | } 573 | }; 574 | 575 | $rv ||= eval { 576 | $CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, ) 577 | ->{install} 578 | if $CPAN::META; 579 | }; 580 | 581 | if ( $rv eq 'YES' ) { 582 | print "*** $pkg successfully installed.\n"; 583 | $success = 1; 584 | } 585 | else { 586 | print "*** $pkg installation failed.\n"; 587 | $success = 0; 588 | } 589 | 590 | $installed += $success; 591 | } 592 | else { 593 | print << "."; 594 | *** Could not find a version $ver or above for $pkg; skipping. 595 | . 596 | } 597 | 598 | MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; 599 | } 600 | 601 | return $installed; 602 | } 603 | 604 | sub _has_cpanplus { 605 | return ( 606 | $HasCPANPLUS = ( 607 | $INC{'CPANPLUS/Config.pm'} 608 | or _load('CPANPLUS::Shell::Default') 609 | ) 610 | ); 611 | } 612 | 613 | # make guesses on whether we're under the CPAN installation directory 614 | sub _under_cpan { 615 | require Cwd; 616 | require File::Spec; 617 | 618 | my $cwd = File::Spec->canonpath( Cwd::getcwd() ); 619 | my $cpan = File::Spec->canonpath( $CPAN::Config->{cpan_home} ); 620 | 621 | return ( index( $cwd, $cpan ) > -1 ); 622 | } 623 | 624 | sub _update_to { 625 | my $class = __PACKAGE__; 626 | my $ver = shift; 627 | 628 | return 629 | if _version_cmp( _version_of($class), $ver ) >= 0; # no need to upgrade 630 | 631 | if ( 632 | _prompt( "==> A newer version of $class ($ver) is required. Install?", 633 | 'y' ) =~ /^[Nn]/ 634 | ) 635 | { 636 | die "*** Please install $class $ver manually.\n"; 637 | } 638 | 639 | print << "."; 640 | *** Trying to fetch it from CPAN... 641 | . 642 | 643 | # install ourselves 644 | _load($class) and return $class->import(@_) 645 | if $class->install( [], $class, $ver ); 646 | 647 | print << '.'; exit 1; 648 | 649 | *** Cannot bootstrap myself. :-( Installation terminated. 650 | . 651 | } 652 | 653 | # check if we're connected to some host, using inet_aton 654 | sub _connected_to { 655 | my $site = shift; 656 | 657 | return ( 658 | ( _load('Socket') and Socket::inet_aton($site) ) or _prompt( 659 | qq( 660 | *** Your host cannot resolve the domain name '$site', which 661 | probably means the Internet connections are unavailable. 662 | ==> Should we try to install the required module(s) anyway?), 'n' 663 | ) =~ /^[Yy]/ 664 | ); 665 | } 666 | 667 | # check if a directory is writable; may create it on demand 668 | sub _can_write { 669 | my $path = shift; 670 | mkdir( $path, 0755 ) unless -e $path; 671 | 672 | return 1 if -w $path; 673 | 674 | print << "."; 675 | *** You are not allowed to write to the directory '$path'; 676 | the installation may fail due to insufficient permissions. 677 | . 678 | 679 | if ( 680 | eval '$>' and lc(`sudo -V`) =~ /version/ and _prompt( 681 | qq( 682 | ==> Should we try to re-execute the autoinstall process with 'sudo'?), 683 | ((-t STDIN) ? 'y' : 'n') 684 | ) =~ /^[Yy]/ 685 | ) 686 | { 687 | 688 | # try to bootstrap ourselves from sudo 689 | print << "."; 690 | *** Trying to re-execute the autoinstall process with 'sudo'... 691 | . 692 | my $missing = join( ',', @Missing ); 693 | my $config = join( ',', 694 | UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) 695 | if $Config; 696 | 697 | return 698 | unless system( 'sudo', $^X, $0, "--config=$config", 699 | "--installdeps=$missing" ); 700 | 701 | print << "."; 702 | *** The 'sudo' command exited with error! Resuming... 703 | . 704 | } 705 | 706 | return _prompt( 707 | qq( 708 | ==> Should we try to install the required module(s) anyway?), 'n' 709 | ) =~ /^[Yy]/; 710 | } 711 | 712 | # load a module and return the version it reports 713 | sub _load { 714 | my $mod = pop; # method/function doesn't matter 715 | my $file = $mod; 716 | $file =~ s|::|/|g; 717 | $file .= '.pm'; 718 | local $@; 719 | return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 ); 720 | } 721 | 722 | # report version without loading a module 723 | sub _version_of { 724 | my $mod = pop; # method/function doesn't matter 725 | my $file = $mod; 726 | $file =~ s|::|/|g; 727 | $file .= '.pm'; 728 | foreach my $dir ( @INC ) { 729 | next if ref $dir; 730 | my $path = File::Spec->catfile($dir, $file); 731 | next unless -e $path; 732 | require ExtUtils::MM_Unix; 733 | return ExtUtils::MM_Unix->parse_version($path); 734 | } 735 | return undef; 736 | } 737 | 738 | # Load CPAN.pm and it's configuration 739 | sub _load_cpan { 740 | return if $CPAN::VERSION and $CPAN::Config and not @_; 741 | require CPAN; 742 | 743 | # CPAN-1.82+ adds CPAN::Config::AUTOLOAD to redirect to 744 | # CPAN::HandleConfig->load. CPAN reports that the redirection 745 | # is deprecated in a warning printed at the user. 746 | 747 | # CPAN-1.81 expects CPAN::HandleConfig->load, does not have 748 | # $CPAN::HandleConfig::VERSION but cannot handle 749 | # CPAN::Config->load 750 | 751 | # Which "versions expect CPAN::Config->load? 752 | 753 | if ( $CPAN::HandleConfig::VERSION 754 | || CPAN::HandleConfig->can('load') 755 | ) { 756 | # Newer versions of CPAN have a HandleConfig module 757 | CPAN::HandleConfig->load; 758 | } else { 759 | # Older versions had the load method in Config directly 760 | CPAN::Config->load; 761 | } 762 | } 763 | 764 | # compare two versions, either use Sort::Versions or plain comparison 765 | # return values same as <=> 766 | sub _version_cmp { 767 | my ( $cur, $min ) = @_; 768 | return -1 unless defined $cur; # if 0 keep comparing 769 | return 1 unless $min; 770 | 771 | $cur =~ s/\s+$//; 772 | 773 | # check for version numbers that are not in decimal format 774 | if ( ref($cur) or ref($min) or $cur =~ /v|\..*\./ or $min =~ /v|\..*\./ ) { 775 | if ( ( $version::VERSION or defined( _load('version') )) and 776 | version->can('new') 777 | ) { 778 | 779 | # use version.pm if it is installed. 780 | return version->new($cur) <=> version->new($min); 781 | } 782 | elsif ( $Sort::Versions::VERSION or defined( _load('Sort::Versions') ) ) 783 | { 784 | 785 | # use Sort::Versions as the sorting algorithm for a.b.c versions 786 | return Sort::Versions::versioncmp( $cur, $min ); 787 | } 788 | 789 | warn "Cannot reliably compare non-decimal formatted versions.\n" 790 | . "Please install version.pm or Sort::Versions.\n"; 791 | } 792 | 793 | # plain comparison 794 | local $^W = 0; # shuts off 'not numeric' bugs 795 | return $cur <=> $min; 796 | } 797 | 798 | # nothing; this usage is deprecated. 799 | sub main::PREREQ_PM { return {}; } 800 | 801 | sub _make_args { 802 | my %args = @_; 803 | 804 | $args{PREREQ_PM} = { %{ $args{PREREQ_PM} || {} }, @Existing, @Missing } 805 | if $UnderCPAN or $TestOnly; 806 | 807 | if ( $args{EXE_FILES} and -e 'MANIFEST' ) { 808 | require ExtUtils::Manifest; 809 | my $manifest = ExtUtils::Manifest::maniread('MANIFEST'); 810 | 811 | $args{EXE_FILES} = 812 | [ grep { exists $manifest->{$_} } @{ $args{EXE_FILES} } ]; 813 | } 814 | 815 | $args{test}{TESTS} ||= 't/*.t'; 816 | $args{test}{TESTS} = join( ' ', 817 | grep { !exists( $DisabledTests{$_} ) } 818 | map { glob($_) } split( /\s+/, $args{test}{TESTS} ) ); 819 | 820 | my $missing = join( ',', @Missing ); 821 | my $config = 822 | join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) 823 | if $Config; 824 | 825 | $PostambleActions = ( 826 | ($missing and not $UnderCPAN) 827 | ? "\$(PERL) $0 --config=$config --installdeps=$missing" 828 | : "\$(NOECHO) \$(NOOP)" 829 | ); 830 | 831 | my $deps_list = join( ',', @Missing, @Existing ); 832 | 833 | $PostambleActionsUpgradeDeps = 834 | "\$(PERL) $0 --config=$config --upgradedeps=$deps_list"; 835 | 836 | my $config_notest = 837 | join( ',', (UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config}), 838 | 'notest', 1 ) 839 | if $Config; 840 | 841 | $PostambleActionsNoTest = ( 842 | ($missing and not $UnderCPAN) 843 | ? "\$(PERL) $0 --config=$config_notest --installdeps=$missing" 844 | : "\$(NOECHO) \$(NOOP)" 845 | ); 846 | 847 | $PostambleActionsUpgradeDepsNoTest = 848 | "\$(PERL) $0 --config=$config_notest --upgradedeps=$deps_list"; 849 | 850 | $PostambleActionsListDeps = 851 | '@$(PERL) -le "print for @ARGV" ' 852 | . join(' ', map $Missing[$_], grep $_ % 2 == 0, 0..$#Missing); 853 | 854 | my @all = (@Missing, @Existing); 855 | 856 | $PostambleActionsListAllDeps = 857 | '@$(PERL) -le "print for @ARGV" ' 858 | . join(' ', map $all[$_], grep $_ % 2 == 0, 0..$#all); 859 | 860 | return %args; 861 | } 862 | 863 | # a wrapper to ExtUtils::MakeMaker::WriteMakefile 864 | sub Write { 865 | require Carp; 866 | Carp::croak "WriteMakefile: Need even number of args" if @_ % 2; 867 | 868 | if ($CheckOnly) { 869 | print << "."; 870 | *** Makefile not written in check-only mode. 871 | . 872 | return; 873 | } 874 | 875 | my %args = _make_args(@_); 876 | 877 | no strict 'refs'; 878 | 879 | $PostambleUsed = 0; 880 | local *MY::postamble = \&postamble unless defined &MY::postamble; 881 | ExtUtils::MakeMaker::WriteMakefile(%args); 882 | 883 | print << "." unless $PostambleUsed; 884 | *** WARNING: Makefile written with customized MY::postamble() without 885 | including contents from Module::AutoInstall::postamble() -- 886 | auto installation features disabled. Please contact the author. 887 | . 888 | 889 | return 1; 890 | } 891 | 892 | sub postamble { 893 | $PostambleUsed = 1; 894 | my $fragment; 895 | 896 | $fragment .= <<"AUTO_INSTALL" if !$InstallDepsTarget; 897 | 898 | config :: installdeps 899 | \t\$(NOECHO) \$(NOOP) 900 | AUTO_INSTALL 901 | 902 | $fragment .= <<"END_MAKE"; 903 | 904 | checkdeps :: 905 | \t\$(PERL) $0 --checkdeps 906 | 907 | installdeps :: 908 | \t$PostambleActions 909 | 910 | installdeps_notest :: 911 | \t$PostambleActionsNoTest 912 | 913 | upgradedeps :: 914 | \t$PostambleActionsUpgradeDeps 915 | 916 | upgradedeps_notest :: 917 | \t$PostambleActionsUpgradeDepsNoTest 918 | 919 | listdeps :: 920 | \t$PostambleActionsListDeps 921 | 922 | listalldeps :: 923 | \t$PostambleActionsListAllDeps 924 | 925 | END_MAKE 926 | 927 | return $fragment; 928 | } 929 | 930 | 1; 931 | 932 | __END__ 933 | 934 | #line 1197 935 | -------------------------------------------------------------------------------- /inc/Module/Install.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install; 3 | 4 | # For any maintainers: 5 | # The load order for Module::Install is a bit magic. 6 | # It goes something like this... 7 | # 8 | # IF ( host has Module::Install installed, creating author mode ) { 9 | # 1. Makefile.PL calls "use inc::Module::Install" 10 | # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install 11 | # 3. The installed version of inc::Module::Install loads 12 | # 4. inc::Module::Install calls "require Module::Install" 13 | # 5. The ./inc/ version of Module::Install loads 14 | # } ELSE { 15 | # 1. Makefile.PL calls "use inc::Module::Install" 16 | # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install 17 | # 3. The ./inc/ version of Module::Install loads 18 | # } 19 | 20 | use 5.006; 21 | use strict 'vars'; 22 | use Cwd (); 23 | use File::Find (); 24 | use File::Path (); 25 | 26 | use vars qw{$VERSION $MAIN}; 27 | BEGIN { 28 | # All Module::Install core packages now require synchronised versions. 29 | # This will be used to ensure we don't accidentally load old or 30 | # different versions of modules. 31 | # This is not enforced yet, but will be some time in the next few 32 | # releases once we can make sure it won't clash with custom 33 | # Module::Install extensions. 34 | $VERSION = '1.16'; 35 | 36 | # Storage for the pseudo-singleton 37 | $MAIN = undef; 38 | 39 | *inc::Module::Install::VERSION = *VERSION; 40 | @inc::Module::Install::ISA = __PACKAGE__; 41 | 42 | } 43 | 44 | sub import { 45 | my $class = shift; 46 | my $self = $class->new(@_); 47 | my $who = $self->_caller; 48 | 49 | #------------------------------------------------------------- 50 | # all of the following checks should be included in import(), 51 | # to allow "eval 'require Module::Install; 1' to test 52 | # installation of Module::Install. (RT #51267) 53 | #------------------------------------------------------------- 54 | 55 | # Whether or not inc::Module::Install is actually loaded, the 56 | # $INC{inc/Module/Install.pm} is what will still get set as long as 57 | # the caller loaded module this in the documented manner. 58 | # If not set, the caller may NOT have loaded the bundled version, and thus 59 | # they may not have a MI version that works with the Makefile.PL. This would 60 | # result in false errors or unexpected behaviour. And we don't want that. 61 | my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; 62 | unless ( $INC{$file} ) { die <<"END_DIE" } 63 | 64 | Please invoke ${\__PACKAGE__} with: 65 | 66 | use inc::${\__PACKAGE__}; 67 | 68 | not: 69 | 70 | use ${\__PACKAGE__}; 71 | 72 | END_DIE 73 | 74 | # This reportedly fixes a rare Win32 UTC file time issue, but 75 | # as this is a non-cross-platform XS module not in the core, 76 | # we shouldn't really depend on it. See RT #24194 for detail. 77 | # (Also, this module only supports Perl 5.6 and above). 78 | eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; 79 | 80 | # If the script that is loading Module::Install is from the future, 81 | # then make will detect this and cause it to re-run over and over 82 | # again. This is bad. Rather than taking action to touch it (which 83 | # is unreliable on some platforms and requires write permissions) 84 | # for now we should catch this and refuse to run. 85 | if ( -f $0 ) { 86 | my $s = (stat($0))[9]; 87 | 88 | # If the modification time is only slightly in the future, 89 | # sleep briefly to remove the problem. 90 | my $a = $s - time; 91 | if ( $a > 0 and $a < 5 ) { sleep 5 } 92 | 93 | # Too far in the future, throw an error. 94 | my $t = time; 95 | if ( $s > $t ) { die <<"END_DIE" } 96 | 97 | Your installer $0 has a modification time in the future ($s > $t). 98 | 99 | This is known to create infinite loops in make. 100 | 101 | Please correct this, then run $0 again. 102 | 103 | END_DIE 104 | } 105 | 106 | 107 | # Build.PL was formerly supported, but no longer is due to excessive 108 | # difficulty in implementing every single feature twice. 109 | if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } 110 | 111 | Module::Install no longer supports Build.PL. 112 | 113 | It was impossible to maintain duel backends, and has been deprecated. 114 | 115 | Please remove all Build.PL files and only use the Makefile.PL installer. 116 | 117 | END_DIE 118 | 119 | #------------------------------------------------------------- 120 | 121 | # To save some more typing in Module::Install installers, every... 122 | # use inc::Module::Install 123 | # ...also acts as an implicit use strict. 124 | $^H |= strict::bits(qw(refs subs vars)); 125 | 126 | #------------------------------------------------------------- 127 | 128 | unless ( -f $self->{file} ) { 129 | foreach my $key (keys %INC) { 130 | delete $INC{$key} if $key =~ /Module\/Install/; 131 | } 132 | 133 | local $^W; 134 | require "$self->{path}/$self->{dispatch}.pm"; 135 | File::Path::mkpath("$self->{prefix}/$self->{author}"); 136 | $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); 137 | $self->{admin}->init; 138 | @_ = ($class, _self => $self); 139 | goto &{"$self->{name}::import"}; 140 | } 141 | 142 | local $^W; 143 | *{"${who}::AUTOLOAD"} = $self->autoload; 144 | $self->preload; 145 | 146 | # Unregister loader and worker packages so subdirs can use them again 147 | delete $INC{'inc/Module/Install.pm'}; 148 | delete $INC{'Module/Install.pm'}; 149 | 150 | # Save to the singleton 151 | $MAIN = $self; 152 | 153 | return 1; 154 | } 155 | 156 | sub autoload { 157 | my $self = shift; 158 | my $who = $self->_caller; 159 | my $cwd = Cwd::getcwd(); 160 | my $sym = "${who}::AUTOLOAD"; 161 | $sym->{$cwd} = sub { 162 | my $pwd = Cwd::getcwd(); 163 | if ( my $code = $sym->{$pwd} ) { 164 | # Delegate back to parent dirs 165 | goto &$code unless $cwd eq $pwd; 166 | } 167 | unless ($$sym =~ s/([^:]+)$//) { 168 | # XXX: it looks like we can't retrieve the missing function 169 | # via $$sym (usually $main::AUTOLOAD) in this case. 170 | # I'm still wondering if we should slurp Makefile.PL to 171 | # get some context or not ... 172 | my ($package, $file, $line) = caller; 173 | die <<"EOT"; 174 | Unknown function is found at $file line $line. 175 | Execution of $file aborted due to runtime errors. 176 | 177 | If you're a contributor to a project, you may need to install 178 | some Module::Install extensions from CPAN (or other repository). 179 | If you're a user of a module, please contact the author. 180 | EOT 181 | } 182 | my $method = $1; 183 | if ( uc($method) eq $method ) { 184 | # Do nothing 185 | return; 186 | } elsif ( $method =~ /^_/ and $self->can($method) ) { 187 | # Dispatch to the root M:I class 188 | return $self->$method(@_); 189 | } 190 | 191 | # Dispatch to the appropriate plugin 192 | unshift @_, ( $self, $1 ); 193 | goto &{$self->can('call')}; 194 | }; 195 | } 196 | 197 | sub preload { 198 | my $self = shift; 199 | unless ( $self->{extensions} ) { 200 | $self->load_extensions( 201 | "$self->{prefix}/$self->{path}", $self 202 | ); 203 | } 204 | 205 | my @exts = @{$self->{extensions}}; 206 | unless ( @exts ) { 207 | @exts = $self->{admin}->load_all_extensions; 208 | } 209 | 210 | my %seen; 211 | foreach my $obj ( @exts ) { 212 | while (my ($method, $glob) = each %{ref($obj) . '::'}) { 213 | next unless $obj->can($method); 214 | next if $method =~ /^_/; 215 | next if $method eq uc($method); 216 | $seen{$method}++; 217 | } 218 | } 219 | 220 | my $who = $self->_caller; 221 | foreach my $name ( sort keys %seen ) { 222 | local $^W; 223 | *{"${who}::$name"} = sub { 224 | ${"${who}::AUTOLOAD"} = "${who}::$name"; 225 | goto &{"${who}::AUTOLOAD"}; 226 | }; 227 | } 228 | } 229 | 230 | sub new { 231 | my ($class, %args) = @_; 232 | 233 | delete $INC{'FindBin.pm'}; 234 | { 235 | # to suppress the redefine warning 236 | local $SIG{__WARN__} = sub {}; 237 | require FindBin; 238 | } 239 | 240 | # ignore the prefix on extension modules built from top level. 241 | my $base_path = Cwd::abs_path($FindBin::Bin); 242 | unless ( Cwd::abs_path(Cwd::getcwd()) eq $base_path ) { 243 | delete $args{prefix}; 244 | } 245 | return $args{_self} if $args{_self}; 246 | 247 | $args{dispatch} ||= 'Admin'; 248 | $args{prefix} ||= 'inc'; 249 | $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); 250 | $args{bundle} ||= 'inc/BUNDLES'; 251 | $args{base} ||= $base_path; 252 | $class =~ s/^\Q$args{prefix}\E:://; 253 | $args{name} ||= $class; 254 | $args{version} ||= $class->VERSION; 255 | unless ( $args{path} ) { 256 | $args{path} = $args{name}; 257 | $args{path} =~ s!::!/!g; 258 | } 259 | $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; 260 | $args{wrote} = 0; 261 | 262 | bless( \%args, $class ); 263 | } 264 | 265 | sub call { 266 | my ($self, $method) = @_; 267 | my $obj = $self->load($method) or return; 268 | splice(@_, 0, 2, $obj); 269 | goto &{$obj->can($method)}; 270 | } 271 | 272 | sub load { 273 | my ($self, $method) = @_; 274 | 275 | $self->load_extensions( 276 | "$self->{prefix}/$self->{path}", $self 277 | ) unless $self->{extensions}; 278 | 279 | foreach my $obj (@{$self->{extensions}}) { 280 | return $obj if $obj->can($method); 281 | } 282 | 283 | my $admin = $self->{admin} or die <<"END_DIE"; 284 | The '$method' method does not exist in the '$self->{prefix}' path! 285 | Please remove the '$self->{prefix}' directory and run $0 again to load it. 286 | END_DIE 287 | 288 | my $obj = $admin->load($method, 1); 289 | push @{$self->{extensions}}, $obj; 290 | 291 | $obj; 292 | } 293 | 294 | sub load_extensions { 295 | my ($self, $path, $top) = @_; 296 | 297 | my $should_reload = 0; 298 | unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { 299 | unshift @INC, $self->{prefix}; 300 | $should_reload = 1; 301 | } 302 | 303 | foreach my $rv ( $self->find_extensions($path) ) { 304 | my ($file, $pkg) = @{$rv}; 305 | next if $self->{pathnames}{$pkg}; 306 | 307 | local $@; 308 | my $new = eval { local $^W; require $file; $pkg->can('new') }; 309 | unless ( $new ) { 310 | warn $@ if $@; 311 | next; 312 | } 313 | $self->{pathnames}{$pkg} = 314 | $should_reload ? delete $INC{$file} : $INC{$file}; 315 | push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); 316 | } 317 | 318 | $self->{extensions} ||= []; 319 | } 320 | 321 | sub find_extensions { 322 | my ($self, $path) = @_; 323 | 324 | my @found; 325 | File::Find::find( sub { 326 | my $file = $File::Find::name; 327 | return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; 328 | my $subpath = $1; 329 | return if lc($subpath) eq lc($self->{dispatch}); 330 | 331 | $file = "$self->{path}/$subpath.pm"; 332 | my $pkg = "$self->{name}::$subpath"; 333 | $pkg =~ s!/!::!g; 334 | 335 | # If we have a mixed-case package name, assume case has been preserved 336 | # correctly. Otherwise, root through the file to locate the case-preserved 337 | # version of the package name. 338 | if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { 339 | my $content = Module::Install::_read($subpath . '.pm'); 340 | my $in_pod = 0; 341 | foreach ( split /\n/, $content ) { 342 | $in_pod = 1 if /^=\w/; 343 | $in_pod = 0 if /^=cut/; 344 | next if ($in_pod || /^=cut/); # skip pod text 345 | next if /^\s*#/; # and comments 346 | if ( m/^\s*package\s+($pkg)\s*;/i ) { 347 | $pkg = $1; 348 | last; 349 | } 350 | } 351 | } 352 | 353 | push @found, [ $file, $pkg ]; 354 | }, $path ) if -d $path; 355 | 356 | @found; 357 | } 358 | 359 | 360 | 361 | 362 | 363 | ##################################################################### 364 | # Common Utility Functions 365 | 366 | sub _caller { 367 | my $depth = 0; 368 | my $call = caller($depth); 369 | while ( $call eq __PACKAGE__ ) { 370 | $depth++; 371 | $call = caller($depth); 372 | } 373 | return $call; 374 | } 375 | 376 | # Done in evals to avoid confusing Perl::MinimumVersion 377 | eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; 378 | sub _read { 379 | local *FH; 380 | open( FH, '<', $_[0] ) or die "open($_[0]): $!"; 381 | binmode FH; 382 | my $string = do { local $/; }; 383 | close FH or die "close($_[0]): $!"; 384 | return $string; 385 | } 386 | END_NEW 387 | sub _read { 388 | local *FH; 389 | open( FH, "< $_[0]" ) or die "open($_[0]): $!"; 390 | binmode FH; 391 | my $string = do { local $/; }; 392 | close FH or die "close($_[0]): $!"; 393 | return $string; 394 | } 395 | END_OLD 396 | 397 | sub _readperl { 398 | my $string = Module::Install::_read($_[0]); 399 | $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; 400 | $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; 401 | $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; 402 | return $string; 403 | } 404 | 405 | sub _readpod { 406 | my $string = Module::Install::_read($_[0]); 407 | $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; 408 | return $string if $_[0] =~ /\.pod\z/; 409 | $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; 410 | $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; 411 | $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; 412 | $string =~ s/^\n+//s; 413 | return $string; 414 | } 415 | 416 | # Done in evals to avoid confusing Perl::MinimumVersion 417 | eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; 418 | sub _write { 419 | local *FH; 420 | open( FH, '>', $_[0] ) or die "open($_[0]): $!"; 421 | binmode FH; 422 | foreach ( 1 .. $#_ ) { 423 | print FH $_[$_] or die "print($_[0]): $!"; 424 | } 425 | close FH or die "close($_[0]): $!"; 426 | } 427 | END_NEW 428 | sub _write { 429 | local *FH; 430 | open( FH, "> $_[0]" ) or die "open($_[0]): $!"; 431 | binmode FH; 432 | foreach ( 1 .. $#_ ) { 433 | print FH $_[$_] or die "print($_[0]): $!"; 434 | } 435 | close FH or die "close($_[0]): $!"; 436 | } 437 | END_OLD 438 | 439 | # _version is for processing module versions (eg, 1.03_05) not 440 | # Perl versions (eg, 5.8.1). 441 | sub _version { 442 | my $s = shift || 0; 443 | my $d =()= $s =~ /(\.)/g; 444 | if ( $d >= 2 ) { 445 | # Normalise multipart versions 446 | $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; 447 | } 448 | $s =~ s/^(\d+)\.?//; 449 | my $l = $1 || 0; 450 | my @v = map { 451 | $_ . '0' x (3 - length $_) 452 | } $s =~ /(\d{1,3})\D?/g; 453 | $l = $l . '.' . join '', @v if @v; 454 | return $l + 0; 455 | } 456 | 457 | sub _cmp { 458 | _version($_[1]) <=> _version($_[2]); 459 | } 460 | 461 | # Cloned from Params::Util::_CLASS 462 | sub _CLASS { 463 | ( 464 | defined $_[0] 465 | and 466 | ! ref $_[0] 467 | and 468 | $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s 469 | ) ? $_[0] : undef; 470 | } 471 | 472 | 1; 473 | 474 | # Copyright 2008 - 2012 Adam Kennedy. 475 | -------------------------------------------------------------------------------- /inc/Module/Install/AutoInstall.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::AutoInstall; 3 | 4 | use strict; 5 | use Module::Install::Base (); 6 | 7 | use vars qw{$VERSION @ISA $ISCORE}; 8 | BEGIN { 9 | $VERSION = '1.16'; 10 | @ISA = 'Module::Install::Base'; 11 | $ISCORE = 1; 12 | } 13 | 14 | sub AutoInstall { $_[0] } 15 | 16 | sub run { 17 | my $self = shift; 18 | $self->auto_install_now(@_); 19 | } 20 | 21 | sub write { 22 | my $self = shift; 23 | $self->auto_install(@_); 24 | } 25 | 26 | sub auto_install { 27 | my $self = shift; 28 | return if $self->{done}++; 29 | 30 | # Flatten array of arrays into a single array 31 | my @core = map @$_, map @$_, grep ref, 32 | $self->build_requires, $self->requires; 33 | 34 | my @config = @_; 35 | 36 | # We'll need Module::AutoInstall 37 | $self->include('Module::AutoInstall'); 38 | require Module::AutoInstall; 39 | 40 | my @features_require = Module::AutoInstall->import( 41 | (@config ? (-config => \@config) : ()), 42 | (@core ? (-core => \@core) : ()), 43 | $self->features, 44 | ); 45 | 46 | my %seen; 47 | my @requires = map @$_, map @$_, grep ref, $self->requires; 48 | while (my ($mod, $ver) = splice(@requires, 0, 2)) { 49 | $seen{$mod}{$ver}++; 50 | } 51 | my @build_requires = map @$_, map @$_, grep ref, $self->build_requires; 52 | while (my ($mod, $ver) = splice(@build_requires, 0, 2)) { 53 | $seen{$mod}{$ver}++; 54 | } 55 | my @configure_requires = map @$_, map @$_, grep ref, $self->configure_requires; 56 | while (my ($mod, $ver) = splice(@configure_requires, 0, 2)) { 57 | $seen{$mod}{$ver}++; 58 | } 59 | 60 | my @deduped; 61 | while (my ($mod, $ver) = splice(@features_require, 0, 2)) { 62 | push @deduped, $mod => $ver unless $seen{$mod}{$ver}++; 63 | } 64 | 65 | $self->requires(@deduped); 66 | 67 | $self->makemaker_args( Module::AutoInstall::_make_args() ); 68 | 69 | my $class = ref($self); 70 | $self->postamble( 71 | "# --- $class section:\n" . 72 | Module::AutoInstall::postamble() 73 | ); 74 | } 75 | 76 | sub installdeps_target { 77 | my ($self, @args) = @_; 78 | 79 | $self->include('Module::AutoInstall'); 80 | require Module::AutoInstall; 81 | 82 | Module::AutoInstall::_installdeps_target(1); 83 | 84 | $self->auto_install(@args); 85 | } 86 | 87 | sub auto_install_now { 88 | my $self = shift; 89 | $self->auto_install(@_); 90 | Module::AutoInstall::do_install(); 91 | } 92 | 93 | 1; 94 | -------------------------------------------------------------------------------- /inc/Module/Install/Base.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::Base; 3 | 4 | use strict 'vars'; 5 | use vars qw{$VERSION}; 6 | BEGIN { 7 | $VERSION = '1.16'; 8 | } 9 | 10 | # Suspend handler for "redefined" warnings 11 | BEGIN { 12 | my $w = $SIG{__WARN__}; 13 | $SIG{__WARN__} = sub { $w }; 14 | } 15 | 16 | #line 42 17 | 18 | sub new { 19 | my $class = shift; 20 | unless ( defined &{"${class}::call"} ) { 21 | *{"${class}::call"} = sub { shift->_top->call(@_) }; 22 | } 23 | unless ( defined &{"${class}::load"} ) { 24 | *{"${class}::load"} = sub { shift->_top->load(@_) }; 25 | } 26 | bless { @_ }, $class; 27 | } 28 | 29 | #line 61 30 | 31 | sub AUTOLOAD { 32 | local $@; 33 | my $func = eval { shift->_top->autoload } or return; 34 | goto &$func; 35 | } 36 | 37 | #line 75 38 | 39 | sub _top { 40 | $_[0]->{_top}; 41 | } 42 | 43 | #line 90 44 | 45 | sub admin { 46 | $_[0]->_top->{admin} 47 | or 48 | Module::Install::Base::FakeAdmin->new; 49 | } 50 | 51 | #line 106 52 | 53 | sub is_admin { 54 | ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); 55 | } 56 | 57 | sub DESTROY {} 58 | 59 | package Module::Install::Base::FakeAdmin; 60 | 61 | use vars qw{$VERSION}; 62 | BEGIN { 63 | $VERSION = $Module::Install::Base::VERSION; 64 | } 65 | 66 | my $fake; 67 | 68 | sub new { 69 | $fake ||= bless(\@_, $_[0]); 70 | } 71 | 72 | sub AUTOLOAD {} 73 | 74 | sub DESTROY {} 75 | 76 | # Restore warning handler 77 | BEGIN { 78 | $SIG{__WARN__} = $SIG{__WARN__}->(); 79 | } 80 | 81 | 1; 82 | 83 | #line 159 84 | -------------------------------------------------------------------------------- /inc/Module/Install/Can.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::Can; 3 | 4 | use strict; 5 | use Config (); 6 | use ExtUtils::MakeMaker (); 7 | use Module::Install::Base (); 8 | 9 | use vars qw{$VERSION @ISA $ISCORE}; 10 | BEGIN { 11 | $VERSION = '1.16'; 12 | @ISA = 'Module::Install::Base'; 13 | $ISCORE = 1; 14 | } 15 | 16 | # check if we can load some module 17 | ### Upgrade this to not have to load the module if possible 18 | sub can_use { 19 | my ($self, $mod, $ver) = @_; 20 | $mod =~ s{::|\\}{/}g; 21 | $mod .= '.pm' unless $mod =~ /\.pm$/i; 22 | 23 | my $pkg = $mod; 24 | $pkg =~ s{/}{::}g; 25 | $pkg =~ s{\.pm$}{}i; 26 | 27 | local $@; 28 | eval { require $mod; $pkg->VERSION($ver || 0); 1 }; 29 | } 30 | 31 | # Check if we can run some command 32 | sub can_run { 33 | my ($self, $cmd) = @_; 34 | 35 | my $_cmd = $cmd; 36 | return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); 37 | 38 | for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { 39 | next if $dir eq ''; 40 | require File::Spec; 41 | my $abs = File::Spec->catfile($dir, $cmd); 42 | return $abs if (-x $abs or $abs = MM->maybe_command($abs)); 43 | } 44 | 45 | return; 46 | } 47 | 48 | # Can our C compiler environment build XS files 49 | sub can_xs { 50 | my $self = shift; 51 | 52 | # Ensure we have the CBuilder module 53 | $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 ); 54 | 55 | # Do we have the configure_requires checker? 56 | local $@; 57 | eval "require ExtUtils::CBuilder;"; 58 | if ( $@ ) { 59 | # They don't obey configure_requires, so it is 60 | # someone old and delicate. Try to avoid hurting 61 | # them by falling back to an older simpler test. 62 | return $self->can_cc(); 63 | } 64 | 65 | # Do we have a working C compiler 66 | my $builder = ExtUtils::CBuilder->new( 67 | quiet => 1, 68 | ); 69 | unless ( $builder->have_compiler ) { 70 | # No working C compiler 71 | return 0; 72 | } 73 | 74 | # Write a C file representative of what XS becomes 75 | require File::Temp; 76 | my ( $FH, $tmpfile ) = File::Temp::tempfile( 77 | "compilexs-XXXXX", 78 | SUFFIX => '.c', 79 | ); 80 | binmode $FH; 81 | print $FH <<'END_C'; 82 | #include "EXTERN.h" 83 | #include "perl.h" 84 | #include "XSUB.h" 85 | 86 | int main(int argc, char **argv) { 87 | return 0; 88 | } 89 | 90 | int boot_sanexs() { 91 | return 1; 92 | } 93 | 94 | END_C 95 | close $FH; 96 | 97 | # Can the C compiler access the same headers XS does 98 | my @libs = (); 99 | my $object = undef; 100 | eval { 101 | local $^W = 0; 102 | $object = $builder->compile( 103 | source => $tmpfile, 104 | ); 105 | @libs = $builder->link( 106 | objects => $object, 107 | module_name => 'sanexs', 108 | ); 109 | }; 110 | my $result = $@ ? 0 : 1; 111 | 112 | # Clean up all the build files 113 | foreach ( $tmpfile, $object, @libs ) { 114 | next unless defined $_; 115 | 1 while unlink; 116 | } 117 | 118 | return $result; 119 | } 120 | 121 | # Can we locate a (the) C compiler 122 | sub can_cc { 123 | my $self = shift; 124 | my @chunks = split(/ /, $Config::Config{cc}) or return; 125 | 126 | # $Config{cc} may contain args; try to find out the program part 127 | while (@chunks) { 128 | return $self->can_run("@chunks") || (pop(@chunks), next); 129 | } 130 | 131 | return; 132 | } 133 | 134 | # Fix Cygwin bug on maybe_command(); 135 | if ( $^O eq 'cygwin' ) { 136 | require ExtUtils::MM_Cygwin; 137 | require ExtUtils::MM_Win32; 138 | if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { 139 | *ExtUtils::MM_Cygwin::maybe_command = sub { 140 | my ($self, $file) = @_; 141 | if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { 142 | ExtUtils::MM_Win32->maybe_command($file); 143 | } else { 144 | ExtUtils::MM_Unix->maybe_command($file); 145 | } 146 | } 147 | } 148 | } 149 | 150 | 1; 151 | 152 | __END__ 153 | 154 | #line 236 155 | -------------------------------------------------------------------------------- /inc/Module/Install/Fetch.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::Fetch; 3 | 4 | use strict; 5 | use Module::Install::Base (); 6 | 7 | use vars qw{$VERSION @ISA $ISCORE}; 8 | BEGIN { 9 | $VERSION = '1.16'; 10 | @ISA = 'Module::Install::Base'; 11 | $ISCORE = 1; 12 | } 13 | 14 | sub get_file { 15 | my ($self, %args) = @_; 16 | my ($scheme, $host, $path, $file) = 17 | $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; 18 | 19 | if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { 20 | $args{url} = $args{ftp_url} 21 | or (warn("LWP support unavailable!\n"), return); 22 | ($scheme, $host, $path, $file) = 23 | $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; 24 | } 25 | 26 | $|++; 27 | print "Fetching '$file' from $host... "; 28 | 29 | unless (eval { require Socket; Socket::inet_aton($host) }) { 30 | warn "'$host' resolve failed!\n"; 31 | return; 32 | } 33 | 34 | return unless $scheme eq 'ftp' or $scheme eq 'http'; 35 | 36 | require Cwd; 37 | my $dir = Cwd::getcwd(); 38 | chdir $args{local_dir} or return if exists $args{local_dir}; 39 | 40 | if (eval { require LWP::Simple; 1 }) { 41 | LWP::Simple::mirror($args{url}, $file); 42 | } 43 | elsif (eval { require Net::FTP; 1 }) { eval { 44 | # use Net::FTP to get past firewall 45 | my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); 46 | $ftp->login("anonymous", 'anonymous@example.com'); 47 | $ftp->cwd($path); 48 | $ftp->binary; 49 | $ftp->get($file) or (warn("$!\n"), return); 50 | $ftp->quit; 51 | } } 52 | elsif (my $ftp = $self->can_run('ftp')) { eval { 53 | # no Net::FTP, fallback to ftp.exe 54 | require FileHandle; 55 | my $fh = FileHandle->new; 56 | 57 | local $SIG{CHLD} = 'IGNORE'; 58 | unless ($fh->open("|$ftp -n")) { 59 | warn "Couldn't open ftp: $!\n"; 60 | chdir $dir; return; 61 | } 62 | 63 | my @dialog = split(/\n/, <<"END_FTP"); 64 | open $host 65 | user anonymous anonymous\@example.com 66 | cd $path 67 | binary 68 | get $file $file 69 | quit 70 | END_FTP 71 | foreach (@dialog) { $fh->print("$_\n") } 72 | $fh->close; 73 | } } 74 | else { 75 | warn "No working 'ftp' program available!\n"; 76 | chdir $dir; return; 77 | } 78 | 79 | unless (-f $file) { 80 | warn "Fetching failed: $@\n"; 81 | chdir $dir; return; 82 | } 83 | 84 | return if exists $args{size} and -s $file != $args{size}; 85 | system($args{run}) if exists $args{run}; 86 | unlink($file) if $args{remove}; 87 | 88 | print(((!exists $args{check_for} or -e $args{check_for}) 89 | ? "done!" : "failed! ($!)"), "\n"); 90 | chdir $dir; return !$?; 91 | } 92 | 93 | 1; 94 | -------------------------------------------------------------------------------- /inc/Module/Install/Include.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::Include; 3 | 4 | use strict; 5 | use Module::Install::Base (); 6 | 7 | use vars qw{$VERSION @ISA $ISCORE}; 8 | BEGIN { 9 | $VERSION = '1.16'; 10 | @ISA = 'Module::Install::Base'; 11 | $ISCORE = 1; 12 | } 13 | 14 | sub include { 15 | shift()->admin->include(@_); 16 | } 17 | 18 | sub include_deps { 19 | shift()->admin->include_deps(@_); 20 | } 21 | 22 | sub auto_include { 23 | shift()->admin->auto_include(@_); 24 | } 25 | 26 | sub auto_include_deps { 27 | shift()->admin->auto_include_deps(@_); 28 | } 29 | 30 | sub auto_include_dependent_dists { 31 | shift()->admin->auto_include_dependent_dists(@_); 32 | } 33 | 34 | 1; 35 | -------------------------------------------------------------------------------- /inc/Module/Install/Makefile.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::Makefile; 3 | 4 | use strict 'vars'; 5 | use ExtUtils::MakeMaker (); 6 | use Module::Install::Base (); 7 | use Fcntl qw/:flock :seek/; 8 | 9 | use vars qw{$VERSION @ISA $ISCORE}; 10 | BEGIN { 11 | $VERSION = '1.16'; 12 | @ISA = 'Module::Install::Base'; 13 | $ISCORE = 1; 14 | } 15 | 16 | sub Makefile { $_[0] } 17 | 18 | my %seen = (); 19 | 20 | sub prompt { 21 | shift; 22 | 23 | # Infinite loop protection 24 | my @c = caller(); 25 | if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { 26 | die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; 27 | } 28 | 29 | # In automated testing or non-interactive session, always use defaults 30 | if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { 31 | local $ENV{PERL_MM_USE_DEFAULT} = 1; 32 | goto &ExtUtils::MakeMaker::prompt; 33 | } else { 34 | goto &ExtUtils::MakeMaker::prompt; 35 | } 36 | } 37 | 38 | # Store a cleaned up version of the MakeMaker version, 39 | # since we need to behave differently in a variety of 40 | # ways based on the MM version. 41 | my $makemaker = eval $ExtUtils::MakeMaker::VERSION; 42 | 43 | # If we are passed a param, do a "newer than" comparison. 44 | # Otherwise, just return the MakeMaker version. 45 | sub makemaker { 46 | ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 47 | } 48 | 49 | # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified 50 | # as we only need to know here whether the attribute is an array 51 | # or a hash or something else (which may or may not be appendable). 52 | my %makemaker_argtype = ( 53 | C => 'ARRAY', 54 | CONFIG => 'ARRAY', 55 | # CONFIGURE => 'CODE', # ignore 56 | DIR => 'ARRAY', 57 | DL_FUNCS => 'HASH', 58 | DL_VARS => 'ARRAY', 59 | EXCLUDE_EXT => 'ARRAY', 60 | EXE_FILES => 'ARRAY', 61 | FUNCLIST => 'ARRAY', 62 | H => 'ARRAY', 63 | IMPORTS => 'HASH', 64 | INCLUDE_EXT => 'ARRAY', 65 | LIBS => 'ARRAY', # ignore '' 66 | MAN1PODS => 'HASH', 67 | MAN3PODS => 'HASH', 68 | META_ADD => 'HASH', 69 | META_MERGE => 'HASH', 70 | PL_FILES => 'HASH', 71 | PM => 'HASH', 72 | PMLIBDIRS => 'ARRAY', 73 | PMLIBPARENTDIRS => 'ARRAY', 74 | PREREQ_PM => 'HASH', 75 | CONFIGURE_REQUIRES => 'HASH', 76 | SKIP => 'ARRAY', 77 | TYPEMAPS => 'ARRAY', 78 | XS => 'HASH', 79 | # VERSION => ['version',''], # ignore 80 | # _KEEP_AFTER_FLUSH => '', 81 | 82 | clean => 'HASH', 83 | depend => 'HASH', 84 | dist => 'HASH', 85 | dynamic_lib=> 'HASH', 86 | linkext => 'HASH', 87 | macro => 'HASH', 88 | postamble => 'HASH', 89 | realclean => 'HASH', 90 | test => 'HASH', 91 | tool_autosplit => 'HASH', 92 | 93 | # special cases where you can use makemaker_append 94 | CCFLAGS => 'APPENDABLE', 95 | DEFINE => 'APPENDABLE', 96 | INC => 'APPENDABLE', 97 | LDDLFLAGS => 'APPENDABLE', 98 | LDFROM => 'APPENDABLE', 99 | ); 100 | 101 | sub makemaker_args { 102 | my ($self, %new_args) = @_; 103 | my $args = ( $self->{makemaker_args} ||= {} ); 104 | foreach my $key (keys %new_args) { 105 | if ($makemaker_argtype{$key}) { 106 | if ($makemaker_argtype{$key} eq 'ARRAY') { 107 | $args->{$key} = [] unless defined $args->{$key}; 108 | unless (ref $args->{$key} eq 'ARRAY') { 109 | $args->{$key} = [$args->{$key}] 110 | } 111 | push @{$args->{$key}}, 112 | ref $new_args{$key} eq 'ARRAY' 113 | ? @{$new_args{$key}} 114 | : $new_args{$key}; 115 | } 116 | elsif ($makemaker_argtype{$key} eq 'HASH') { 117 | $args->{$key} = {} unless defined $args->{$key}; 118 | foreach my $skey (keys %{ $new_args{$key} }) { 119 | $args->{$key}{$skey} = $new_args{$key}{$skey}; 120 | } 121 | } 122 | elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { 123 | $self->makemaker_append($key => $new_args{$key}); 124 | } 125 | } 126 | else { 127 | if (defined $args->{$key}) { 128 | warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; 129 | } 130 | $args->{$key} = $new_args{$key}; 131 | } 132 | } 133 | return $args; 134 | } 135 | 136 | # For mm args that take multiple space-separated args, 137 | # append an argument to the current list. 138 | sub makemaker_append { 139 | my $self = shift; 140 | my $name = shift; 141 | my $args = $self->makemaker_args; 142 | $args->{$name} = defined $args->{$name} 143 | ? join( ' ', $args->{$name}, @_ ) 144 | : join( ' ', @_ ); 145 | } 146 | 147 | sub build_subdirs { 148 | my $self = shift; 149 | my $subdirs = $self->makemaker_args->{DIR} ||= []; 150 | for my $subdir (@_) { 151 | push @$subdirs, $subdir; 152 | } 153 | } 154 | 155 | sub clean_files { 156 | my $self = shift; 157 | my $clean = $self->makemaker_args->{clean} ||= {}; 158 | %$clean = ( 159 | %$clean, 160 | FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), 161 | ); 162 | } 163 | 164 | sub realclean_files { 165 | my $self = shift; 166 | my $realclean = $self->makemaker_args->{realclean} ||= {}; 167 | %$realclean = ( 168 | %$realclean, 169 | FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), 170 | ); 171 | } 172 | 173 | sub libs { 174 | my $self = shift; 175 | my $libs = ref $_[0] ? shift : [ shift ]; 176 | $self->makemaker_args( LIBS => $libs ); 177 | } 178 | 179 | sub inc { 180 | my $self = shift; 181 | $self->makemaker_args( INC => shift ); 182 | } 183 | 184 | sub _wanted_t { 185 | } 186 | 187 | sub tests_recursive { 188 | my $self = shift; 189 | my $dir = shift || 't'; 190 | unless ( -d $dir ) { 191 | die "tests_recursive dir '$dir' does not exist"; 192 | } 193 | my %tests = map { $_ => 1 } split / /, ($self->tests || ''); 194 | require File::Find; 195 | File::Find::find( 196 | sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, 197 | $dir 198 | ); 199 | $self->tests( join ' ', sort keys %tests ); 200 | } 201 | 202 | sub write { 203 | my $self = shift; 204 | die "&Makefile->write() takes no arguments\n" if @_; 205 | 206 | # Check the current Perl version 207 | my $perl_version = $self->perl_version; 208 | if ( $perl_version ) { 209 | eval "use $perl_version; 1" 210 | or die "ERROR: perl: Version $] is installed, " 211 | . "but we need version >= $perl_version"; 212 | } 213 | 214 | # Make sure we have a new enough MakeMaker 215 | require ExtUtils::MakeMaker; 216 | 217 | if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { 218 | # This previous attempted to inherit the version of 219 | # ExtUtils::MakeMaker in use by the module author, but this 220 | # was found to be untenable as some authors build releases 221 | # using future dev versions of EU:MM that nobody else has. 222 | # Instead, #toolchain suggests we use 6.59 which is the most 223 | # stable version on CPAN at time of writing and is, to quote 224 | # ribasushi, "not terminally fucked, > and tested enough". 225 | # TODO: We will now need to maintain this over time to push 226 | # the version up as new versions are released. 227 | $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); 228 | $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); 229 | } else { 230 | # Allow legacy-compatibility with 5.005 by depending on the 231 | # most recent EU:MM that supported 5.005. 232 | $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 ); 233 | $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); 234 | } 235 | 236 | # Generate the MakeMaker params 237 | my $args = $self->makemaker_args; 238 | $args->{DISTNAME} = $self->name; 239 | $args->{NAME} = $self->module_name || $self->name; 240 | $args->{NAME} =~ s/-/::/g; 241 | $args->{VERSION} = $self->version or die <<'EOT'; 242 | ERROR: Can't determine distribution version. Please specify it 243 | explicitly via 'version' in Makefile.PL, or set a valid $VERSION 244 | in a module, and provide its file path via 'version_from' (or 245 | 'all_from' if you prefer) in Makefile.PL. 246 | EOT 247 | 248 | if ( $self->tests ) { 249 | my @tests = split ' ', $self->tests; 250 | my %seen; 251 | $args->{test} = { 252 | TESTS => (join ' ', grep {!$seen{$_}++} @tests), 253 | }; 254 | } elsif ( $Module::Install::ExtraTests::use_extratests ) { 255 | # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. 256 | # So, just ignore our xt tests here. 257 | } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { 258 | $args->{test} = { 259 | TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), 260 | }; 261 | } 262 | if ( $] >= 5.005 ) { 263 | $args->{ABSTRACT} = $self->abstract; 264 | $args->{AUTHOR} = join ', ', @{$self->author || []}; 265 | } 266 | if ( $self->makemaker(6.10) ) { 267 | $args->{NO_META} = 1; 268 | #$args->{NO_MYMETA} = 1; 269 | } 270 | if ( $self->makemaker(6.17) and $self->sign ) { 271 | $args->{SIGN} = 1; 272 | } 273 | unless ( $self->is_admin ) { 274 | delete $args->{SIGN}; 275 | } 276 | if ( $self->makemaker(6.31) and $self->license ) { 277 | $args->{LICENSE} = $self->license; 278 | } 279 | 280 | my $prereq = ($args->{PREREQ_PM} ||= {}); 281 | %$prereq = ( %$prereq, 282 | map { @$_ } # flatten [module => version] 283 | map { @$_ } 284 | grep $_, 285 | ($self->requires) 286 | ); 287 | 288 | # Remove any reference to perl, PREREQ_PM doesn't support it 289 | delete $args->{PREREQ_PM}->{perl}; 290 | 291 | # Merge both kinds of requires into BUILD_REQUIRES 292 | my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); 293 | %$build_prereq = ( %$build_prereq, 294 | map { @$_ } # flatten [module => version] 295 | map { @$_ } 296 | grep $_, 297 | ($self->configure_requires, $self->build_requires) 298 | ); 299 | 300 | # Remove any reference to perl, BUILD_REQUIRES doesn't support it 301 | delete $args->{BUILD_REQUIRES}->{perl}; 302 | 303 | # Delete bundled dists from prereq_pm, add it to Makefile DIR 304 | my $subdirs = ($args->{DIR} || []); 305 | if ($self->bundles) { 306 | my %processed; 307 | foreach my $bundle (@{ $self->bundles }) { 308 | my ($mod_name, $dist_dir) = @$bundle; 309 | delete $prereq->{$mod_name}; 310 | $dist_dir = File::Basename::basename($dist_dir); # dir for building this module 311 | if (not exists $processed{$dist_dir}) { 312 | if (-d $dist_dir) { 313 | # List as sub-directory to be processed by make 314 | push @$subdirs, $dist_dir; 315 | } 316 | # Else do nothing: the module is already present on the system 317 | $processed{$dist_dir} = undef; 318 | } 319 | } 320 | } 321 | 322 | unless ( $self->makemaker('6.55_03') ) { 323 | %$prereq = (%$prereq,%$build_prereq); 324 | delete $args->{BUILD_REQUIRES}; 325 | } 326 | 327 | if ( my $perl_version = $self->perl_version ) { 328 | eval "use $perl_version; 1" 329 | or die "ERROR: perl: Version $] is installed, " 330 | . "but we need version >= $perl_version"; 331 | 332 | if ( $self->makemaker(6.48) ) { 333 | $args->{MIN_PERL_VERSION} = $perl_version; 334 | } 335 | } 336 | 337 | if ($self->installdirs) { 338 | warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; 339 | $args->{INSTALLDIRS} = $self->installdirs; 340 | } 341 | 342 | my %args = map { 343 | ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) 344 | } keys %$args; 345 | 346 | my $user_preop = delete $args{dist}->{PREOP}; 347 | if ( my $preop = $self->admin->preop($user_preop) ) { 348 | foreach my $key ( keys %$preop ) { 349 | $args{dist}->{$key} = $preop->{$key}; 350 | } 351 | } 352 | 353 | my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); 354 | $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); 355 | } 356 | 357 | sub fix_up_makefile { 358 | my $self = shift; 359 | my $makefile_name = shift; 360 | my $top_class = ref($self->_top) || ''; 361 | my $top_version = $self->_top->VERSION || ''; 362 | 363 | my $preamble = $self->preamble 364 | ? "# Preamble by $top_class $top_version\n" 365 | . $self->preamble 366 | : ''; 367 | my $postamble = "# Postamble by $top_class $top_version\n" 368 | . ($self->postamble || ''); 369 | 370 | local *MAKEFILE; 371 | open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; 372 | eval { flock MAKEFILE, LOCK_EX }; 373 | my $makefile = do { local $/; }; 374 | 375 | $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; 376 | $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; 377 | $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; 378 | $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; 379 | $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; 380 | 381 | # Module::Install will never be used to build the Core Perl 382 | # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks 383 | # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist 384 | $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; 385 | #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; 386 | 387 | # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. 388 | $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; 389 | 390 | # XXX - This is currently unused; not sure if it breaks other MM-users 391 | # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; 392 | 393 | seek MAKEFILE, 0, SEEK_SET; 394 | truncate MAKEFILE, 0; 395 | print MAKEFILE "$preamble$makefile$postamble" or die $!; 396 | close MAKEFILE or die $!; 397 | 398 | 1; 399 | } 400 | 401 | sub preamble { 402 | my ($self, $text) = @_; 403 | $self->{preamble} = $text . $self->{preamble} if defined $text; 404 | $self->{preamble}; 405 | } 406 | 407 | sub postamble { 408 | my ($self, $text) = @_; 409 | $self->{postamble} ||= $self->admin->postamble; 410 | $self->{postamble} .= $text if defined $text; 411 | $self->{postamble} 412 | } 413 | 414 | 1; 415 | 416 | __END__ 417 | 418 | #line 544 419 | -------------------------------------------------------------------------------- /inc/Module/Install/Metadata.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::Metadata; 3 | 4 | use strict 'vars'; 5 | use Module::Install::Base (); 6 | 7 | use vars qw{$VERSION @ISA $ISCORE}; 8 | BEGIN { 9 | $VERSION = '1.16'; 10 | @ISA = 'Module::Install::Base'; 11 | $ISCORE = 1; 12 | } 13 | 14 | my @boolean_keys = qw{ 15 | sign 16 | }; 17 | 18 | my @scalar_keys = qw{ 19 | name 20 | module_name 21 | abstract 22 | version 23 | distribution_type 24 | tests 25 | installdirs 26 | }; 27 | 28 | my @tuple_keys = qw{ 29 | configure_requires 30 | build_requires 31 | requires 32 | recommends 33 | bundles 34 | resources 35 | }; 36 | 37 | my @resource_keys = qw{ 38 | homepage 39 | bugtracker 40 | repository 41 | }; 42 | 43 | my @array_keys = qw{ 44 | keywords 45 | author 46 | }; 47 | 48 | *authors = \&author; 49 | 50 | sub Meta { shift } 51 | sub Meta_BooleanKeys { @boolean_keys } 52 | sub Meta_ScalarKeys { @scalar_keys } 53 | sub Meta_TupleKeys { @tuple_keys } 54 | sub Meta_ResourceKeys { @resource_keys } 55 | sub Meta_ArrayKeys { @array_keys } 56 | 57 | foreach my $key ( @boolean_keys ) { 58 | *$key = sub { 59 | my $self = shift; 60 | if ( defined wantarray and not @_ ) { 61 | return $self->{values}->{$key}; 62 | } 63 | $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); 64 | return $self; 65 | }; 66 | } 67 | 68 | foreach my $key ( @scalar_keys ) { 69 | *$key = sub { 70 | my $self = shift; 71 | return $self->{values}->{$key} if defined wantarray and !@_; 72 | $self->{values}->{$key} = shift; 73 | return $self; 74 | }; 75 | } 76 | 77 | foreach my $key ( @array_keys ) { 78 | *$key = sub { 79 | my $self = shift; 80 | return $self->{values}->{$key} if defined wantarray and !@_; 81 | $self->{values}->{$key} ||= []; 82 | push @{$self->{values}->{$key}}, @_; 83 | return $self; 84 | }; 85 | } 86 | 87 | foreach my $key ( @resource_keys ) { 88 | *$key = sub { 89 | my $self = shift; 90 | unless ( @_ ) { 91 | return () unless $self->{values}->{resources}; 92 | return map { $_->[1] } 93 | grep { $_->[0] eq $key } 94 | @{ $self->{values}->{resources} }; 95 | } 96 | return $self->{values}->{resources}->{$key} unless @_; 97 | my $uri = shift or die( 98 | "Did not provide a value to $key()" 99 | ); 100 | $self->resources( $key => $uri ); 101 | return 1; 102 | }; 103 | } 104 | 105 | foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { 106 | *$key = sub { 107 | my $self = shift; 108 | return $self->{values}->{$key} unless @_; 109 | my @added; 110 | while ( @_ ) { 111 | my $module = shift or last; 112 | my $version = shift || 0; 113 | push @added, [ $module, $version ]; 114 | } 115 | push @{ $self->{values}->{$key} }, @added; 116 | return map {@$_} @added; 117 | }; 118 | } 119 | 120 | # Resource handling 121 | my %lc_resource = map { $_ => 1 } qw{ 122 | homepage 123 | license 124 | bugtracker 125 | repository 126 | }; 127 | 128 | sub resources { 129 | my $self = shift; 130 | while ( @_ ) { 131 | my $name = shift or last; 132 | my $value = shift or next; 133 | if ( $name eq lc $name and ! $lc_resource{$name} ) { 134 | die("Unsupported reserved lowercase resource '$name'"); 135 | } 136 | $self->{values}->{resources} ||= []; 137 | push @{ $self->{values}->{resources} }, [ $name, $value ]; 138 | } 139 | $self->{values}->{resources}; 140 | } 141 | 142 | # Aliases for build_requires that will have alternative 143 | # meanings in some future version of META.yml. 144 | sub test_requires { shift->build_requires(@_) } 145 | sub install_requires { shift->build_requires(@_) } 146 | 147 | # Aliases for installdirs options 148 | sub install_as_core { $_[0]->installdirs('perl') } 149 | sub install_as_cpan { $_[0]->installdirs('site') } 150 | sub install_as_site { $_[0]->installdirs('site') } 151 | sub install_as_vendor { $_[0]->installdirs('vendor') } 152 | 153 | sub dynamic_config { 154 | my $self = shift; 155 | my $value = @_ ? shift : 1; 156 | if ( $self->{values}->{dynamic_config} ) { 157 | # Once dynamic we never change to static, for safety 158 | return 0; 159 | } 160 | $self->{values}->{dynamic_config} = $value ? 1 : 0; 161 | return 1; 162 | } 163 | 164 | # Convenience command 165 | sub static_config { 166 | shift->dynamic_config(0); 167 | } 168 | 169 | sub perl_version { 170 | my $self = shift; 171 | return $self->{values}->{perl_version} unless @_; 172 | my $version = shift or die( 173 | "Did not provide a value to perl_version()" 174 | ); 175 | 176 | # Normalize the version 177 | $version = $self->_perl_version($version); 178 | 179 | # We don't support the really old versions 180 | unless ( $version >= 5.005 ) { 181 | die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; 182 | } 183 | 184 | $self->{values}->{perl_version} = $version; 185 | } 186 | 187 | sub all_from { 188 | my ( $self, $file ) = @_; 189 | 190 | unless ( defined($file) ) { 191 | my $name = $self->name or die( 192 | "all_from called with no args without setting name() first" 193 | ); 194 | $file = join('/', 'lib', split(/-/, $name)) . '.pm'; 195 | $file =~ s{.*/}{} unless -e $file; 196 | unless ( -e $file ) { 197 | die("all_from cannot find $file from $name"); 198 | } 199 | } 200 | unless ( -f $file ) { 201 | die("The path '$file' does not exist, or is not a file"); 202 | } 203 | 204 | $self->{values}{all_from} = $file; 205 | 206 | # Some methods pull from POD instead of code. 207 | # If there is a matching .pod, use that instead 208 | my $pod = $file; 209 | $pod =~ s/\.pm$/.pod/i; 210 | $pod = $file unless -e $pod; 211 | 212 | # Pull the different values 213 | $self->name_from($file) unless $self->name; 214 | $self->version_from($file) unless $self->version; 215 | $self->perl_version_from($file) unless $self->perl_version; 216 | $self->author_from($pod) unless @{$self->author || []}; 217 | $self->license_from($pod) unless $self->license; 218 | $self->abstract_from($pod) unless $self->abstract; 219 | 220 | return 1; 221 | } 222 | 223 | sub provides { 224 | my $self = shift; 225 | my $provides = ( $self->{values}->{provides} ||= {} ); 226 | %$provides = (%$provides, @_) if @_; 227 | return $provides; 228 | } 229 | 230 | sub auto_provides { 231 | my $self = shift; 232 | return $self unless $self->is_admin; 233 | unless (-e 'MANIFEST') { 234 | warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; 235 | return $self; 236 | } 237 | # Avoid spurious warnings as we are not checking manifest here. 238 | local $SIG{__WARN__} = sub {1}; 239 | require ExtUtils::Manifest; 240 | local *ExtUtils::Manifest::manicheck = sub { return }; 241 | 242 | require Module::Build; 243 | my $build = Module::Build->new( 244 | dist_name => $self->name, 245 | dist_version => $self->version, 246 | license => $self->license, 247 | ); 248 | $self->provides( %{ $build->find_dist_packages || {} } ); 249 | } 250 | 251 | sub feature { 252 | my $self = shift; 253 | my $name = shift; 254 | my $features = ( $self->{values}->{features} ||= [] ); 255 | my $mods; 256 | 257 | if ( @_ == 1 and ref( $_[0] ) ) { 258 | # The user used ->feature like ->features by passing in the second 259 | # argument as a reference. Accomodate for that. 260 | $mods = $_[0]; 261 | } else { 262 | $mods = \@_; 263 | } 264 | 265 | my $count = 0; 266 | push @$features, ( 267 | $name => [ 268 | map { 269 | ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ 270 | } @$mods 271 | ] 272 | ); 273 | 274 | return @$features; 275 | } 276 | 277 | sub features { 278 | my $self = shift; 279 | while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { 280 | $self->feature( $name, @$mods ); 281 | } 282 | return $self->{values}->{features} 283 | ? @{ $self->{values}->{features} } 284 | : (); 285 | } 286 | 287 | sub no_index { 288 | my $self = shift; 289 | my $type = shift; 290 | push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; 291 | return $self->{values}->{no_index}; 292 | } 293 | 294 | sub read { 295 | my $self = shift; 296 | $self->include_deps( 'YAML::Tiny', 0 ); 297 | 298 | require YAML::Tiny; 299 | my $data = YAML::Tiny::LoadFile('META.yml'); 300 | 301 | # Call methods explicitly in case user has already set some values. 302 | while ( my ( $key, $value ) = each %$data ) { 303 | next unless $self->can($key); 304 | if ( ref $value eq 'HASH' ) { 305 | while ( my ( $module, $version ) = each %$value ) { 306 | $self->can($key)->($self, $module => $version ); 307 | } 308 | } else { 309 | $self->can($key)->($self, $value); 310 | } 311 | } 312 | return $self; 313 | } 314 | 315 | sub write { 316 | my $self = shift; 317 | return $self unless $self->is_admin; 318 | $self->admin->write_meta; 319 | return $self; 320 | } 321 | 322 | sub version_from { 323 | require ExtUtils::MM_Unix; 324 | my ( $self, $file ) = @_; 325 | $self->version( ExtUtils::MM_Unix->parse_version($file) ); 326 | 327 | # for version integrity check 328 | $self->makemaker_args( VERSION_FROM => $file ); 329 | } 330 | 331 | sub abstract_from { 332 | require ExtUtils::MM_Unix; 333 | my ( $self, $file ) = @_; 334 | $self->abstract( 335 | bless( 336 | { DISTNAME => $self->name }, 337 | 'ExtUtils::MM_Unix' 338 | )->parse_abstract($file) 339 | ); 340 | } 341 | 342 | # Add both distribution and module name 343 | sub name_from { 344 | my ($self, $file) = @_; 345 | if ( 346 | Module::Install::_read($file) =~ m/ 347 | ^ \s* 348 | package \s* 349 | ([\w:]+) 350 | [\s|;]* 351 | /ixms 352 | ) { 353 | my ($name, $module_name) = ($1, $1); 354 | $name =~ s{::}{-}g; 355 | $self->name($name); 356 | unless ( $self->module_name ) { 357 | $self->module_name($module_name); 358 | } 359 | } else { 360 | die("Cannot determine name from $file\n"); 361 | } 362 | } 363 | 364 | sub _extract_perl_version { 365 | if ( 366 | $_[0] =~ m/ 367 | ^\s* 368 | (?:use|require) \s* 369 | v? 370 | ([\d_\.]+) 371 | \s* ; 372 | /ixms 373 | ) { 374 | my $perl_version = $1; 375 | $perl_version =~ s{_}{}g; 376 | return $perl_version; 377 | } else { 378 | return; 379 | } 380 | } 381 | 382 | sub perl_version_from { 383 | my $self = shift; 384 | my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); 385 | if ($perl_version) { 386 | $self->perl_version($perl_version); 387 | } else { 388 | warn "Cannot determine perl version info from $_[0]\n"; 389 | return; 390 | } 391 | } 392 | 393 | sub author_from { 394 | my $self = shift; 395 | my $content = Module::Install::_read($_[0]); 396 | if ($content =~ m/ 397 | =head \d \s+ (?:authors?)\b \s* 398 | ([^\n]*) 399 | | 400 | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* 401 | .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* 402 | ([^\n]*) 403 | /ixms) { 404 | my $author = $1 || $2; 405 | 406 | # XXX: ugly but should work anyway... 407 | if (eval "require Pod::Escapes; 1") { 408 | # Pod::Escapes has a mapping table. 409 | # It's in core of perl >= 5.9.3, and should be installed 410 | # as one of the Pod::Simple's prereqs, which is a prereq 411 | # of Pod::Text 3.x (see also below). 412 | $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } 413 | { 414 | defined $2 415 | ? chr($2) 416 | : defined $Pod::Escapes::Name2character_number{$1} 417 | ? chr($Pod::Escapes::Name2character_number{$1}) 418 | : do { 419 | warn "Unknown escape: E<$1>"; 420 | "E<$1>"; 421 | }; 422 | }gex; 423 | } 424 | elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { 425 | # Pod::Text < 3.0 has yet another mapping table, 426 | # though the table name of 2.x and 1.x are different. 427 | # (1.x is in core of Perl < 5.6, 2.x is in core of 428 | # Perl < 5.9.3) 429 | my $mapping = ($Pod::Text::VERSION < 2) 430 | ? \%Pod::Text::HTML_Escapes 431 | : \%Pod::Text::ESCAPES; 432 | $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } 433 | { 434 | defined $2 435 | ? chr($2) 436 | : defined $mapping->{$1} 437 | ? $mapping->{$1} 438 | : do { 439 | warn "Unknown escape: E<$1>"; 440 | "E<$1>"; 441 | }; 442 | }gex; 443 | } 444 | else { 445 | $author =~ s{E}{<}g; 446 | $author =~ s{E}{>}g; 447 | } 448 | $self->author($author); 449 | } else { 450 | warn "Cannot determine author info from $_[0]\n"; 451 | } 452 | } 453 | 454 | #Stolen from M::B 455 | my %license_urls = ( 456 | perl => 'http://dev.perl.org/licenses/', 457 | apache => 'http://apache.org/licenses/LICENSE-2.0', 458 | apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', 459 | artistic => 'http://opensource.org/licenses/artistic-license.php', 460 | artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', 461 | lgpl => 'http://opensource.org/licenses/lgpl-license.php', 462 | lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', 463 | lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', 464 | bsd => 'http://opensource.org/licenses/bsd-license.php', 465 | gpl => 'http://opensource.org/licenses/gpl-license.php', 466 | gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', 467 | gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', 468 | mit => 'http://opensource.org/licenses/mit-license.php', 469 | mozilla => 'http://opensource.org/licenses/mozilla1.1.php', 470 | open_source => undef, 471 | unrestricted => undef, 472 | restrictive => undef, 473 | unknown => undef, 474 | ); 475 | 476 | sub license { 477 | my $self = shift; 478 | return $self->{values}->{license} unless @_; 479 | my $license = shift or die( 480 | 'Did not provide a value to license()' 481 | ); 482 | $license = __extract_license($license) || lc $license; 483 | $self->{values}->{license} = $license; 484 | 485 | # Automatically fill in license URLs 486 | if ( $license_urls{$license} ) { 487 | $self->resources( license => $license_urls{$license} ); 488 | } 489 | 490 | return 1; 491 | } 492 | 493 | sub _extract_license { 494 | my $pod = shift; 495 | my $matched; 496 | return __extract_license( 497 | ($matched) = $pod =~ m/ 498 | (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) 499 | (=head \d.*|=cut.*|)\z 500 | /xms 501 | ) || __extract_license( 502 | ($matched) = $pod =~ m/ 503 | (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) 504 | (=head \d.*|=cut.*|)\z 505 | /xms 506 | ); 507 | } 508 | 509 | sub __extract_license { 510 | my $license_text = shift or return; 511 | my @phrases = ( 512 | '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, 513 | '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 514 | 'Artistic and GPL' => 'perl', 1, 515 | 'GNU general public license' => 'gpl', 1, 516 | 'GNU public license' => 'gpl', 1, 517 | 'GNU lesser general public license' => 'lgpl', 1, 518 | 'GNU lesser public license' => 'lgpl', 1, 519 | 'GNU library general public license' => 'lgpl', 1, 520 | 'GNU library public license' => 'lgpl', 1, 521 | 'GNU Free Documentation license' => 'unrestricted', 1, 522 | 'GNU Affero General Public License' => 'open_source', 1, 523 | '(?:Free)?BSD license' => 'bsd', 1, 524 | 'Artistic license 2\.0' => 'artistic_2', 1, 525 | 'Artistic license' => 'artistic', 1, 526 | 'Apache (?:Software )?license' => 'apache', 1, 527 | 'GPL' => 'gpl', 1, 528 | 'LGPL' => 'lgpl', 1, 529 | 'BSD' => 'bsd', 1, 530 | 'Artistic' => 'artistic', 1, 531 | 'MIT' => 'mit', 1, 532 | 'Mozilla Public License' => 'mozilla', 1, 533 | 'Q Public License' => 'open_source', 1, 534 | 'OpenSSL License' => 'unrestricted', 1, 535 | 'SSLeay License' => 'unrestricted', 1, 536 | 'zlib License' => 'open_source', 1, 537 | 'proprietary' => 'proprietary', 0, 538 | ); 539 | while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { 540 | $pattern =~ s#\s+#\\s+#gs; 541 | if ( $license_text =~ /\b$pattern\b/i ) { 542 | return $license; 543 | } 544 | } 545 | return ''; 546 | } 547 | 548 | sub license_from { 549 | my $self = shift; 550 | if (my $license=_extract_license(Module::Install::_read($_[0]))) { 551 | $self->license($license); 552 | } else { 553 | warn "Cannot determine license info from $_[0]\n"; 554 | return 'unknown'; 555 | } 556 | } 557 | 558 | sub _extract_bugtracker { 559 | my @links = $_[0] =~ m#L<( 560 | https?\Q://rt.cpan.org/\E[^>]+| 561 | https?\Q://github.com/\E[\w_]+/[\w_]+/issues| 562 | https?\Q://code.google.com/p/\E[\w_\-]+/issues/list 563 | )>#gx; 564 | my %links; 565 | @links{@links}=(); 566 | @links=keys %links; 567 | return @links; 568 | } 569 | 570 | sub bugtracker_from { 571 | my $self = shift; 572 | my $content = Module::Install::_read($_[0]); 573 | my @links = _extract_bugtracker($content); 574 | unless ( @links ) { 575 | warn "Cannot determine bugtracker info from $_[0]\n"; 576 | return 0; 577 | } 578 | if ( @links > 1 ) { 579 | warn "Found more than one bugtracker link in $_[0]\n"; 580 | return 0; 581 | } 582 | 583 | # Set the bugtracker 584 | bugtracker( $links[0] ); 585 | return 1; 586 | } 587 | 588 | sub requires_from { 589 | my $self = shift; 590 | my $content = Module::Install::_readperl($_[0]); 591 | my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; 592 | while ( @requires ) { 593 | my $module = shift @requires; 594 | my $version = shift @requires; 595 | $self->requires( $module => $version ); 596 | } 597 | } 598 | 599 | sub test_requires_from { 600 | my $self = shift; 601 | my $content = Module::Install::_readperl($_[0]); 602 | my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; 603 | while ( @requires ) { 604 | my $module = shift @requires; 605 | my $version = shift @requires; 606 | $self->test_requires( $module => $version ); 607 | } 608 | } 609 | 610 | # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to 611 | # numbers (eg, 5.006001 or 5.008009). 612 | # Also, convert double-part versions (eg, 5.8) 613 | sub _perl_version { 614 | my $v = $_[-1]; 615 | $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; 616 | $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; 617 | $v =~ s/(\.\d\d\d)000$/$1/; 618 | $v =~ s/_.+$//; 619 | if ( ref($v) ) { 620 | # Numify 621 | $v = $v + 0; 622 | } 623 | return $v; 624 | } 625 | 626 | sub add_metadata { 627 | my $self = shift; 628 | my %hash = @_; 629 | for my $key (keys %hash) { 630 | warn "add_metadata: $key is not prefixed with 'x_'.\n" . 631 | "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; 632 | $self->{values}->{$key} = $hash{$key}; 633 | } 634 | } 635 | 636 | 637 | ###################################################################### 638 | # MYMETA Support 639 | 640 | sub WriteMyMeta { 641 | die "WriteMyMeta has been deprecated"; 642 | } 643 | 644 | sub write_mymeta_yaml { 645 | my $self = shift; 646 | 647 | # We need YAML::Tiny to write the MYMETA.yml file 648 | unless ( eval { require YAML::Tiny; 1; } ) { 649 | return 1; 650 | } 651 | 652 | # Generate the data 653 | my $meta = $self->_write_mymeta_data or return 1; 654 | 655 | # Save as the MYMETA.yml file 656 | print "Writing MYMETA.yml\n"; 657 | YAML::Tiny::DumpFile('MYMETA.yml', $meta); 658 | } 659 | 660 | sub write_mymeta_json { 661 | my $self = shift; 662 | 663 | # We need JSON to write the MYMETA.json file 664 | unless ( eval { require JSON; 1; } ) { 665 | return 1; 666 | } 667 | 668 | # Generate the data 669 | my $meta = $self->_write_mymeta_data or return 1; 670 | 671 | # Save as the MYMETA.yml file 672 | print "Writing MYMETA.json\n"; 673 | Module::Install::_write( 674 | 'MYMETA.json', 675 | JSON->new->pretty(1)->canonical->encode($meta), 676 | ); 677 | } 678 | 679 | sub _write_mymeta_data { 680 | my $self = shift; 681 | 682 | # If there's no existing META.yml there is nothing we can do 683 | return undef unless -f 'META.yml'; 684 | 685 | # We need Parse::CPAN::Meta to load the file 686 | unless ( eval { require Parse::CPAN::Meta; 1; } ) { 687 | return undef; 688 | } 689 | 690 | # Merge the perl version into the dependencies 691 | my $val = $self->Meta->{values}; 692 | my $perl = delete $val->{perl_version}; 693 | if ( $perl ) { 694 | $val->{requires} ||= []; 695 | my $requires = $val->{requires}; 696 | 697 | # Canonize to three-dot version after Perl 5.6 698 | if ( $perl >= 5.006 ) { 699 | $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e 700 | } 701 | unshift @$requires, [ perl => $perl ]; 702 | } 703 | 704 | # Load the advisory META.yml file 705 | my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); 706 | my $meta = $yaml[0]; 707 | 708 | # Overwrite the non-configure dependency hashes 709 | delete $meta->{requires}; 710 | delete $meta->{build_requires}; 711 | delete $meta->{recommends}; 712 | if ( exists $val->{requires} ) { 713 | $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; 714 | } 715 | if ( exists $val->{build_requires} ) { 716 | $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; 717 | } 718 | 719 | return $meta; 720 | } 721 | 722 | 1; 723 | -------------------------------------------------------------------------------- /inc/Module/Install/Win32.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::Win32; 3 | 4 | use strict; 5 | use Module::Install::Base (); 6 | 7 | use vars qw{$VERSION @ISA $ISCORE}; 8 | BEGIN { 9 | $VERSION = '1.16'; 10 | @ISA = 'Module::Install::Base'; 11 | $ISCORE = 1; 12 | } 13 | 14 | # determine if the user needs nmake, and download it if needed 15 | sub check_nmake { 16 | my $self = shift; 17 | $self->load('can_run'); 18 | $self->load('get_file'); 19 | 20 | require Config; 21 | return unless ( 22 | $^O eq 'MSWin32' and 23 | $Config::Config{make} and 24 | $Config::Config{make} =~ /^nmake\b/i and 25 | ! $self->can_run('nmake') 26 | ); 27 | 28 | print "The required 'nmake' executable not found, fetching it...\n"; 29 | 30 | require File::Basename; 31 | my $rv = $self->get_file( 32 | url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', 33 | ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', 34 | local_dir => File::Basename::dirname($^X), 35 | size => 51928, 36 | run => 'Nmake15.exe /o > nul', 37 | check_for => 'Nmake.exe', 38 | remove => 1, 39 | ); 40 | 41 | die <<'END_MESSAGE' unless $rv; 42 | 43 | ------------------------------------------------------------------------------- 44 | 45 | Since you are using Microsoft Windows, you will need the 'nmake' utility 46 | before installation. It's available at: 47 | 48 | http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe 49 | or 50 | ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe 51 | 52 | Please download the file manually, save it to a directory in %PATH% (e.g. 53 | C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to 54 | that directory, and run "Nmake15.exe" from there; that will create the 55 | 'nmake.exe' file needed by this module. 56 | 57 | You may then resume the installation process described in README. 58 | 59 | ------------------------------------------------------------------------------- 60 | END_MESSAGE 61 | 62 | } 63 | 64 | 1; 65 | -------------------------------------------------------------------------------- /inc/Module/Install/WriteAll.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::WriteAll; 3 | 4 | use strict; 5 | use Module::Install::Base (); 6 | 7 | use vars qw{$VERSION @ISA $ISCORE}; 8 | BEGIN { 9 | $VERSION = '1.16'; 10 | @ISA = qw{Module::Install::Base}; 11 | $ISCORE = 1; 12 | } 13 | 14 | sub WriteAll { 15 | my $self = shift; 16 | my %args = ( 17 | meta => 1, 18 | sign => 0, 19 | inline => 0, 20 | check_nmake => 1, 21 | @_, 22 | ); 23 | 24 | $self->sign(1) if $args{sign}; 25 | $self->admin->WriteAll(%args) if $self->is_admin; 26 | 27 | $self->check_nmake if $args{check_nmake}; 28 | unless ( $self->makemaker_args->{PL_FILES} ) { 29 | # XXX: This still may be a bit over-defensive... 30 | unless ($self->makemaker(6.25)) { 31 | $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; 32 | } 33 | } 34 | 35 | # Until ExtUtils::MakeMaker support MYMETA.yml, make sure 36 | # we clean it up properly ourself. 37 | $self->realclean_files('MYMETA.yml'); 38 | 39 | if ( $args{inline} ) { 40 | $self->Inline->write; 41 | } else { 42 | $self->Makefile->write; 43 | } 44 | 45 | # The Makefile write process adds a couple of dependencies, 46 | # so write the META.yml files after the Makefile. 47 | if ( $args{meta} ) { 48 | $self->Meta->write; 49 | } 50 | 51 | # Experimental support for MYMETA 52 | if ( $ENV{X_MYMETA} ) { 53 | if ( $ENV{X_MYMETA} eq 'JSON' ) { 54 | $self->Meta->write_mymeta_json; 55 | } else { 56 | $self->Meta->write_mymeta_yaml; 57 | } 58 | } 59 | 60 | return 1; 61 | } 62 | 63 | 1; 64 | -------------------------------------------------------------------------------- /lib/DB/Color.pm: -------------------------------------------------------------------------------- 1 | package DB::Color; 2 | 3 | use 5.008; 4 | use strict; 5 | use warnings; 6 | use DB::Color::Highlight; 7 | use DB::Color::Config; 8 | 9 | use IO::Handle; 10 | use File::Spec::Functions qw(catfile catdir); 11 | use Scalar::Util 'dualvar'; 12 | use File::Find; 13 | 14 | =head1 NAME 15 | 16 | DB::Color - Colorize your debugger output 17 | 18 | =head1 VERSION 19 | 20 | Version 0.20 21 | 22 | =cut 23 | 24 | our $VERSION = '0.20'; 25 | 26 | =head1 SYNOPSIS 27 | 28 | Put the following in your F<$HOME/.perldb> file: 29 | 30 | use DB::Color; 31 | 32 | Then use your debugger like normal: 33 | 34 | perl -d some_file.pl 35 | 36 | If you don't want a F<$HOME/.perldb> file, you can do this: 37 | 38 | perl -MDB::Color -d some_file.pl 39 | 40 | =head1 DISABLING COLOR 41 | 42 | If the NO_DB_COLOR environment variable is set to a true value, syntax 43 | highlighting will be disabled. 44 | 45 | =head1 WINDOWS 46 | 47 | No, sorry. It's a combination of bad Windows support for ANSI escape sequences 48 | and bad debugger design. 49 | 50 | =head1 PERFORMANCE 51 | 52 | When using the debugger and when you step into something, or continue to a 53 | breakpoint in a new file, the debugger may appear to hang for a moment 54 | (perhaps a long moment if the file is big) while the file is syntax 55 | highlighted and cached. The next time the debugger enters this file, the 56 | highlighting should be instantaneous. 57 | 58 | You can speed up the debugger by using the L program which is 59 | included in this distribution. It will pregenerate syntax files for you. 60 | 61 | Syntax highlighting the code is very slow. As a result, we cache the output 62 | files in F<$HOME/.perldbcolor>. This is done by calculating the md5 sum of the 63 | file contents. If the file is changed, we get a new sum. This means that 64 | syntax highlighting is very slow at first, but every time you hit the same 65 | file, assuming its unchanged, the cached version is served first. 66 | 67 | Note that the cache files are removed after they become 30 (but see config) 68 | days old without being used. If you use the debugger regularly, commonly 69 | debugged files will load very quickly (assuming they haven't changed). 70 | 71 | =head1 CONDITIONAL LOADING 72 | 73 | If you prefer, you may only want to have I of your projects "colorized". 74 | If so, you can do something like this: 75 | 76 | use DB::Color sentinel => '.colorize'; 77 | 78 | If an if the C<.colorize> sentinel (or whatever you named it) does not exist, 79 | C will not be used. 80 | 81 | =head1 WORKFLOW 82 | 83 | To use C effectively, I recommend the following: 84 | 85 | $ cpanm DB::Color 86 | $ echo "use DB::Color sentinel => '.colorize'" >> ~/.perldb 87 | # cd to project you want to colorize and create the sentinel 88 | $ touch .colorize 89 | # colorize the project. This will likely take a long time 90 | $ PERL5LIB=lib:t/tests perldbsyntax 91 | 92 | At that point, you're almost good to go. However, as you're rapidly changing 93 | files, the debugger will still probably be very slow. Instead, create a 94 | watcher to watch your project directories and rehighlight any files which have 95 | been created or modified. An example of a watcher program is the 96 | F program included with this distribution. 97 | 98 | =head1 CONFIGURATION 99 | 100 | You can optionally configure C by creating a 101 | F<$HOME/.perldbcolorrc> configuration file. It looks like this: 102 | 103 | [core] 104 | 105 | # the class that will highlight the code 106 | highlighter = DB::Color::Highlight 107 | 108 | # Any cache file not accessed after this number of days is purged 109 | cache_max_age = 30 110 | 111 | # where to put the cache dir 112 | cache_dir = /users/ovid/.perldbcolor 113 | 114 | The above values are more or less the defaults for this module. They are all 115 | optional. 116 | 117 | =head1 ALPHA 118 | 119 | This is only a proof of concept. In fact, it's fair to say that this code 120 | sucks. It's not very configurable and has bugs. It's also going to possibly be 121 | a memory hog, as if the debugger wasn't bad enough already. 122 | 123 | =cut 124 | 125 | my $config = DB::Color::Config->read( default_rcfile() ); 126 | 127 | my %COLORED; 128 | my $DB_BASE_DIR = $config->{core}{cache_dir} || default_base_dir(); 129 | 130 | my $DB_LOG = catfile( $DB_BASE_DIR, 'debug.log' ); 131 | my $CACHE_MAX_AGE = $config->{core}{cache_max_age} || 30; 132 | my $DEBUG; 133 | 134 | # Not documenting this because I don't guarantee stability, but you can play 135 | # with it if you want. 136 | if ( $ENV{DB_COLOR_DEBUG} ) { 137 | open $DEBUG, '>>', $DB_LOG 138 | or die "Cannot open $DB_LOG for appending: $!"; 139 | $DEBUG->autoflush(1); 140 | } 141 | 142 | my $HIGHLIGHTER_CLASS = $config->{core}{highlighter} || 'DB::Color::Highlight'; 143 | eval "use $HIGHLIGHTER_CLASS"; 144 | die $@ if $@; 145 | 146 | my $HIGHLIGHTER = $HIGHLIGHTER_CLASS->new( 147 | { 148 | cache_dir => $DB_BASE_DIR, 149 | debug_fh => $DEBUG, 150 | } 151 | ); 152 | 153 | sub DB::afterinit { 154 | no warnings 'once'; 155 | push @DB::typeahead => "{{v" 156 | unless $DB::already_curly_curly_v++; 157 | } 158 | 159 | sub default_rcfile { catfile( $ENV{HOME}, '.perldbcolorrc' ) } 160 | sub default_base_dir { catfile( $ENV{HOME}, '.perldbcolor' ) } 161 | 162 | sub import { 163 | my ( $package, %arg_for ) = @_; 164 | my $sentinel = $arg_for{sentinel}; 165 | 166 | if ( defined $sentinel && !-e $sentinel ) { 167 | warn "DB::Color not running because '$sentinel' was requested, but not found\n"; 168 | return; 169 | } 170 | return if $ENV{NO_DB_COLOR}; 171 | if ( 'MSWin32' eq $^O ) { 172 | warn <<"END"; 173 | DB::Color does not run under Windows because the Windows terminal is too 174 | broken to understand terminal color code. 175 | 176 | DB::Color does not use Win32::Console because the debugger is too broken to be 177 | properly extensible. 178 | END 179 | return; 180 | } 181 | my $old_db = \&DB::DB; 182 | 183 | my $new_DB = sub { 184 | my $lvl = 0; 185 | while ( my ($pkg) = caller( $lvl++ ) ) { 186 | return if $pkg eq "DB" or $pkg =~ /^DB::/; 187 | } 188 | my ( $package, $filename ) = caller; 189 | if ($DEBUG) { 190 | print $DEBUG "In package '$package', filename '$filename'\n"; 191 | } 192 | 193 | # syntax highlight everything and cache it 194 | my $lines = $COLORED{$filename} ||= do { 195 | no strict 'refs'; 196 | no warnings 'uninitialized'; 197 | [ 198 | split /(?<=\n)/ => 199 | $HIGHLIGHTER->highlight_text( join "" => @{"::_<$filename"} ) 200 | ]; 201 | }; 202 | 203 | { 204 | 205 | # lie to the debugger about what the lines of code are 206 | no strict 'refs'; 207 | my $line_num = 0; 208 | foreach ( @{"::_<$filename"} ) { 209 | 210 | # uncomment these to blow your f'in mind 211 | #if ( not defined ) { 212 | # use Devel::Peek; 213 | # warn "line number is $line_num"; 214 | # Dump($_); 215 | #} 216 | # The debugger special cases the first value in ::_<$filename. 217 | # It's "undef" but sometimes contains some data about the 218 | # program. I don't know entirely what it is, but this solves 219 | # the "off by one" bug. 220 | next unless defined; # thanks Liz! (why does this work?) 221 | my $line = $lines->[ $line_num++ ]; 222 | next unless defined $line; # happens when $_ = "\n" 223 | 224 | # XXX Cheap hack to fix 225 | # Argument "{\n" isn't numeric in addition (+) at DB/Color.pm line 189. 226 | no warnings 'numeric'; 227 | my $numeric_value = 0 + $_; 228 | 229 | # Internally, the debugger uses dualvars for each line of 230 | # code. If it's numeric value is 0, then the line is not 231 | # breakable. If we don't include this, no lines in the 232 | # debugger are breakable. 233 | $_ = dualvar $numeric_value, $line; 234 | } 235 | } 236 | goto $old_db; 237 | }; 238 | 239 | { 240 | no warnings 'redefine'; 241 | *DB::DB = $new_DB; 242 | } 243 | 244 | return; 245 | } 246 | 247 | END { 248 | find( 249 | sub { 250 | 251 | # delete empty files or files > $CACHE_MAX_AGE days old 252 | if ( -f $_ && ( -z _ || -M _ > $CACHE_MAX_AGE ) ) { 253 | unlink($_) or die "Could not unlink '$File::Find::name': $!"; 254 | } 255 | }, 256 | $DB_BASE_DIR, 257 | ); 258 | # we're not testing for failure as this is a cheap hack to delete empty 259 | # directories 260 | finddepth( sub { rmdir $_ if -d }, $DB_BASE_DIR ); 261 | } 262 | 263 | 1; 264 | 265 | =head1 AUTHOR 266 | 267 | Curtis "Ovid" Poe, C<< >> 268 | 269 | =head1 BUGS 270 | 271 | Please report any bugs or feature requests through the web interface at 272 | L. I will be notified, and then 273 | you'll automatically be notified of progress on your bug as I make changes. 274 | 275 | =head1 SUPPORT 276 | 277 | You can find documentation for this module with the perldoc command. 278 | 279 | perldoc DB::Color 280 | 281 | You can also look for information at: 282 | 283 | =over 4 284 | 285 | =item * Bug tracker (report bugs here) 286 | 287 | L 288 | 289 | =item * AnnoCPAN: Annotated CPAN documentation 290 | 291 | L 292 | 293 | =item * CPAN Ratings 294 | 295 | L 296 | 297 | =item * Search CPAN 298 | 299 | L 300 | 301 | =item * Github 302 | 303 | L 304 | 305 | =back 306 | 307 | =head1 ACKNOWLEDGEMENTS 308 | 309 | Thanks to Nick Perez, Liz, and the 2012 Perl Hackathon for helping to overcome 310 | some major hurdles with this module. 311 | 312 | =head1 LICENSE AND COPYRIGHT 313 | 314 | Copyright 2011 Curtis "Ovid" Poe. 315 | 316 | This program is free software; you can redistribute it and/or modify it 317 | under the terms of either: the GNU General Public License as published 318 | by the Free Software Foundation; or the Artistic License. 319 | 320 | See http://dev.perl.org/licenses/ for more information. 321 | 322 | 323 | =cut 324 | 325 | 1; # End of DB::Color 326 | -------------------------------------------------------------------------------- /lib/DB/Color/Config.pm: -------------------------------------------------------------------------------- 1 | package DB::Color::Config; 2 | 3 | # If you thought Config::Simple was small... 4 | 5 | use strict; 6 | BEGIN { 7 | require 5.004; 8 | $DB::Color::Config::VERSION = '0.20'; 9 | $DB::Color::Config::errstr = ''; 10 | } 11 | 12 | # Create an empty object 13 | sub new { bless {}, shift } 14 | 15 | # Create an object from a file 16 | sub read { 17 | my $class = ref $_[0] ? ref shift : shift; 18 | 19 | # Check the file 20 | my $file = shift or return $class->_error( 'You did not specify a file name' ); 21 | return $class->_error( "File '$file' does not exist" ) unless -e $file; 22 | return $class->_error( "'$file' is a directory, not a file" ) unless -f _; 23 | return $class->_error( "Insufficient permissions to read '$file'" ) unless -r _; 24 | 25 | # Slurp in the file 26 | local $/ = undef; 27 | open( CFG, $file ) or return $class->_error( "Failed to open file '$file': $!" ); 28 | my $contents = ; 29 | close( CFG ); 30 | 31 | $class->read_string( $contents ); 32 | } 33 | 34 | # Create an object from a string 35 | sub read_string { 36 | my $class = ref $_[0] ? ref shift : shift; 37 | my $self = bless {}, $class; 38 | return undef unless defined $_[0]; 39 | 40 | # Parse the file 41 | my $ns = '_'; 42 | my $counter = 0; 43 | foreach ( split /(?:\015{1,2}\012|\015|\012)/, shift ) { 44 | $counter++; 45 | 46 | # Skip comments and empty lines 47 | next if /^\s*(?:\#|\;|$)/; 48 | 49 | # Remove inline comments 50 | s/\s\;\s.+$//g; 51 | 52 | # Handle section headers 53 | if ( /^\s*\[\s*(.+?)\s*\]\s*$/ ) { 54 | # Create the sub-hash if it doesn't exist. 55 | # Without this sections without keys will not 56 | # appear at all in the completed struct. 57 | $self->{$ns = $1} ||= {}; 58 | next; 59 | } 60 | 61 | # Handle properties 62 | if ( /^\s*([^=]+?)\s*=\s*(.*?)\s*$/ ) { 63 | $self->{$ns}->{$1} = $2; 64 | next; 65 | } 66 | 67 | return $self->_error( "Syntax error at line $counter: '$_'" ); 68 | } 69 | 70 | $self; 71 | } 72 | 73 | # Save an object to a file 74 | sub write { 75 | my $self = shift; 76 | my $file = shift or return $self->_error( 77 | 'No file name provided' 78 | ); 79 | 80 | # Write it to the file 81 | my $string = $self->write_string; 82 | return undef unless defined $string; 83 | open( CFG, '>' . $file ) or return $self->_error( 84 | "Failed to open file '$file' for writing: $!" 85 | ); 86 | print CFG $string; 87 | close CFG; 88 | } 89 | 90 | # Save an object to a string 91 | sub write_string { 92 | my $self = shift; 93 | 94 | my $contents = ''; 95 | foreach my $section ( sort { (($b eq '_') <=> ($a eq '_')) || ($a cmp $b) } keys %$self ) { 96 | # Check for several known-bad situations with the section 97 | # 1. Leading whitespace 98 | # 2. Trailing whitespace 99 | # 3. Newlines in section name 100 | return $self->_error( 101 | "Illegal whitespace in section name '$section'" 102 | ) if $section =~ /(?:^\s|\n|\s$)/s; 103 | my $block = $self->{$section}; 104 | $contents .= "\n" if length $contents; 105 | $contents .= "[$section]\n" unless $section eq '_'; 106 | foreach my $property ( sort keys %$block ) { 107 | return $self->_error( 108 | "Illegal newlines in property '$section.$property'" 109 | ) if $block->{$property} =~ /(?:\012|\015)/s; 110 | $contents .= "$property=$block->{$property}\n"; 111 | } 112 | } 113 | 114 | $contents; 115 | } 116 | 117 | # Error handling 118 | sub errstr { $DB::Color::Config::errstr } 119 | sub _error { $DB::Color::Config::errstr = $_[1]; undef } 120 | 121 | 1; 122 | 123 | __END__ 124 | 125 | =pod 126 | 127 | =head1 NAME 128 | 129 | DB::Color::Config - Read/Write .ini style files with as little code as possible 130 | 131 | =head1 NOTE 132 | 133 | This is an embedded fork of L version 2.14. There is no 134 | functional change. 135 | 136 | =head1 SYNOPSIS 137 | 138 | # In your configuration file 139 | rootproperty=blah 140 | 141 | [section] 142 | one=twp 143 | three= four 144 | Foo =Bar 145 | empty= 146 | 147 | # In your program 148 | use DB::Color::Config; 149 | 150 | # Create a config 151 | my $Config = DB::Color::Config->new; 152 | 153 | # Open the config 154 | $Config = DB::Color::Config->read( 'file.conf' ); 155 | 156 | # Reading properties 157 | my $rootproperty = $Config->{_}->{rootproperty}; 158 | my $one = $Config->{section}->{one}; 159 | my $Foo = $Config->{section}->{Foo}; 160 | 161 | # Changing data 162 | $Config->{newsection} = { this => 'that' }; # Add a section 163 | $Config->{section}->{Foo} = 'Not Bar!'; # Change a value 164 | delete $Config->{_}; # Delete a value or section 165 | 166 | # Save a config 167 | $Config->write( 'file.conf' ); 168 | 169 | =head1 DESCRIPTION 170 | 171 | C is a perl class to read and write .ini style configuration 172 | files with as little code as possible, reducing load time and memory 173 | overhead. Most of the time it is accepted that Perl applications use a lot 174 | of memory and modules. The C<::Tiny> family of modules is specifically 175 | intended to provide an ultralight alternative to the standard modules. 176 | 177 | This module is primarily for reading human written files, and anything we 178 | write shouldn't need to have documentation/comments. If you need something 179 | with more power move up to L, L or one of 180 | the many other C modules. To rephrase, L does B 181 | preserve your comments, whitespace, or the order of your config file. 182 | 183 | =head1 CONFIGURATION FILE SYNTAX 184 | 185 | Files are the same format as for windows .ini files. For example: 186 | 187 | [section] 188 | var1=value1 189 | var2=value2 190 | 191 | If a property is outside of a section at the beginning of a file, it will 192 | be assigned to the C<"root section">, available at C<$Config-E{_}>. 193 | 194 | Lines starting with C<'#'> or C<';'> are considered comments and ignored, 195 | as are blank lines. 196 | 197 | When writing back to the config file, all comments, custom whitespace, 198 | and the ordering of your config file elements is discarded. If you need 199 | to keep the human elements of a config when writing back, upgrade to 200 | something better, this module is not for you. 201 | 202 | =head1 METHODS 203 | 204 | =head2 new 205 | 206 | The constructor C creates and returns an empty C object. 207 | 208 | =head2 read $filename 209 | 210 | The C constructor reads a config file, and returns a new 211 | C object containing the properties in the file. 212 | 213 | Returns the object on success, or C on error. 214 | 215 | When C fails, C sets an error message internally 216 | you can recover via Cerrstr>. Although in B 217 | cases a failed C will also set the operating system error 218 | variable C<$!>, not all errors do and you should not rely on using 219 | the C<$!> variable. 220 | 221 | =head2 read_string $string; 222 | 223 | The C method takes as argument the contents of a config file 224 | as a string and returns the C object for it. 225 | 226 | =head2 write $filename 227 | 228 | The C method generates the file content for the properties, and 229 | writes it to disk to the filename specified. 230 | 231 | Returns true on success or C on error. 232 | 233 | =head2 write_string 234 | 235 | Generates the file content for the object and returns it as a string. 236 | 237 | =head2 errstr 238 | 239 | When an error occurs, you can retrieve the error message either from the 240 | C<$DB::Color::Config::errstr> variable, or using the C method. 241 | 242 | =head1 CAVEATS 243 | 244 | =head2 Unsupported Section Headers 245 | 246 | Some edge cases in section headers are not support, and additionally may not 247 | be detected when writing the config file. 248 | 249 | Specifically, section headers with leading whitespace, trailing whitespace, 250 | or newlines anywhere in the section header, will not be written correctly 251 | to the file and may cause file corruption. 252 | 253 | =head1 SUPPORT 254 | 255 | Bugs should be reported via the CPAN bug tracker at 256 | 257 | L 258 | 259 | For other issues, or commercial enhancement or support, contact the author. 260 | 261 | =head1 AUTHOR 262 | 263 | Adam Kennedy Eadamk@cpan.orgE 264 | 265 | =head1 ACKNOWLEGEMENTS 266 | 267 | Thanks to Sherzod Ruzmetov Esherzodr@cpan.orgE for 268 | L, which inspired this module by being not quite 269 | "simple" enough for me :) 270 | 271 | =head1 SEE ALSO 272 | 273 | L, L, L 274 | 275 | =head1 COPYRIGHT 276 | 277 | Copyright 2002 - 2011 Adam Kennedy. 278 | 279 | This program is free software; you can redistribute 280 | it and/or modify it under the same terms as Perl itself. 281 | 282 | The full text of the license can be found in the 283 | LICENSE file included with this module. 284 | 285 | =cut 286 | -------------------------------------------------------------------------------- /lib/DB/Color/Highlight.pm: -------------------------------------------------------------------------------- 1 | package DB::Color::Highlight; 2 | 3 | use strict; 4 | use warnings; 5 | use Term::ANSIColor ':constants'; 6 | use Digest::MD5 'md5_hex'; 7 | use File::Spec::Functions qw(catfile catdir); 8 | use File::Path 'make_path'; 9 | 10 | BEGIN { 11 | if ( !( Term::ANSIColor->VERSION >= 3 ) ) { 12 | no warnings 'redefine'; 13 | *BRIGHT_BLUE = sub { BLUE }; 14 | } 15 | } 16 | 17 | use Syntax::Highlight::Engine::Kate::Perl; 18 | 19 | =head1 NAME 20 | 21 | DB::Color::Highlight - Provides highlighting for DB::Color 22 | 23 | =head1 VERSION 24 | 25 | Version 0.20 26 | 27 | =cut 28 | 29 | our $VERSION = '0.20'; 30 | 31 | # increase this number by one to force the cache to generate new md5 numbers 32 | my $FORMAT_NUMBER = 1; 33 | 34 | BEGIN { 35 | no warnings 'redefine'; 36 | *Syntax::Highlight::Engine::Kate::Template::logwarning = sub { }; 37 | } 38 | 39 | sub new { 40 | my ( $class, $args ) = @_; 41 | my $self = bless {} => $class; 42 | $self->_initialize($args); 43 | return $self; 44 | } 45 | 46 | sub _initialize { 47 | my ( $self, $args ) = @_; 48 | 49 | my $cache_dir = $args->{cache_dir}; 50 | $self->{debug_fh} = $args->{debug_fh}; 51 | $self->{cache_dir} = $cache_dir; 52 | 53 | if ( defined $cache_dir and not -d $cache_dir ) { 54 | mkdir $cache_dir or die "Cannot mkdir ($cache_dir): $!"; 55 | } 56 | 57 | # CLEAR RESET BOLD DARK 58 | # FAINT ITALIC UNDERLINE UNDERSCORE 59 | # BLINK REVERSE CONCEALED 60 | # 61 | # BLACK RED GREEN YELLOW 62 | # BLUE MAGENTA CYAN WHITE 63 | # BRIGHT_BLACK BRIGHT_RED BRIGHT_GREEN BRIGHT_YELLOW 64 | # BRIGHT_BLUE BRIGHT_MAGENTA BRIGHT_CYAN BRIGHT_WHITE 65 | # 66 | # ON_BLACK ON_RED ON_GREEN ON_YELLOW 67 | # ON_BLUE ON_MAGENTA ON_CYAN ON_WHITE 68 | # ON_BRIGHT_BLACK ON_BRIGHT_RED ON_BRIGHT_GREEN ON_BRIGHT_YELLOW 69 | # ON_BRIGHT_BLUE ON_BRIGHT_MAGENTA ON_BRIGHT_CYAN ON_BRIGHT_WHITE 70 | 71 | my $highlighter = Syntax::Highlight::Engine::Kate::Perl->new( 72 | format_table => { 73 | 'Keyword' => [ YELLOW, RESET ], 74 | 'Comment' => [ BRIGHT_BLUE, RESET ], 75 | 'Decimal' => [ YELLOW, RESET ], 76 | 'Float' => [ YELLOW, RESET ], 77 | 'Function' => [ CYAN, RESET ], 78 | 'Identifier' => [ RED, RESET ], 79 | 'Normal' => [ WHITE, RESET ], 80 | 'Operator' => [ CYAN, RESET ], 81 | 'Preprocessor' => [ RED, RESET ], 82 | 'String' => [ MAGENTA, RESET ], 83 | 'String Char' => [ RED, RESET ], 84 | 'Symbol' => [ CYAN, RESET ], 85 | 'DataType' => [ CYAN, RESET ], # variable names 86 | } 87 | ); 88 | $self->{highlighter} = $highlighter; 89 | } 90 | 91 | sub _highlighter { $_[0]->{highlighter} } 92 | sub _cache_dir { $_[0]->{cache_dir} } 93 | sub _should_cache { defined $_[0]->_cache_dir } 94 | 95 | sub _debug { 96 | my ( $self, $message ) = @_; 97 | return unless my $debug = $self->{debug_fh}; 98 | print $debug "$message\n"; 99 | } 100 | 101 | sub highlight_text { 102 | my ( $self, $code ) = @_; 103 | 104 | if ( $self->_should_cache ) { 105 | my ( $path, $file ) = $self->_get_path_and_file($code); 106 | unless ( -d $path ) { 107 | make_path($path); 108 | } 109 | $file = catfile( $path, $file ); 110 | 111 | if ( -e $file ) { 112 | $self->_debug("Cache hit on '$file'"); 113 | 114 | # update the atime, mtime to ensure that our naive cache recognizes 115 | # this as a "recent" file 116 | utime time, time, $file or die "Cannot 'utime atime, mtime $file: $!"; 117 | open my $fh, '<', $file or die "Cannot open '$file' for reading: $!"; 118 | return do { local $/; <$fh> }; 119 | } 120 | else { 121 | $self->_debug("Cache miss on '$file'"); 122 | my $highlighted = $self->_get_highlighted_text($code); 123 | open my $fh, '>', $file or die "Cannot open '$file' for writing: $!"; 124 | print $fh $highlighted; 125 | return $highlighted; 126 | } 127 | } 128 | else { 129 | return $self->_get_highlighted_text($code); 130 | } 131 | } 132 | 133 | sub _get_highlighted_text { 134 | my ( $self, $code ) = @_; 135 | 136 | my @code; 137 | my $line_num = 0; 138 | my $in_pod = 0; 139 | my %pod_lines; 140 | my @pod_line_nums; 141 | foreach ( split /\n/ => $code ) { 142 | if (/^=(?!cut\b)/) { 143 | $in_pod = 1; 144 | } 145 | if ($in_pod) { 146 | $pod_lines{$line_num} = $_; 147 | push @pod_line_nums => $line_num; 148 | push @code => ''; 149 | } 150 | else { 151 | push @code => $_; 152 | } 153 | if (/^=cut\b/) { 154 | $in_pod = 0; 155 | } 156 | $line_num++; 157 | } 158 | $code = join "\n" => @code; 159 | my $highlighted = $self->_highlighter->highlightText($code); 160 | @code = split /\n/ => $highlighted; 161 | @code[@pod_line_nums] = @pod_lines{@pod_line_nums}; 162 | return join "\n" => map { BLUE . $_ . RESET } @code; 163 | } 164 | 165 | sub _get_path_and_file { 166 | my ( $self, $code ) = @_; 167 | unless ( $self->_should_cache ) { 168 | $self->_debug("Caching disabled"); 169 | return; 170 | } 171 | my $md5 = md5_hex( $self->_get_unique_factors, $code ); 172 | my $dir = substr $md5, 0, 2, ''; 173 | my $file = $md5; 174 | 175 | my $path = catdir( $self->_cache_dir, $dir ); 176 | $self->_debug("Cache path is '$path'. Cache file is '$file'"); 177 | return $path, $file; 178 | } 179 | 180 | sub _format_number { 181 | return $FORMAT_NUMBER; 182 | } 183 | 184 | sub _get_unique_factors { 185 | my $self = shift; 186 | return ( $self->_format_number, ref $self ); 187 | } 188 | 189 | 1; 190 | __END__ 191 | 192 | =head1 SYNOPSIS 193 | 194 | use DB::Color::Highlight; 195 | my $highlighter = DB::Color::Highlight::highlighter(); 196 | my $highlighted = $highlighter->highlightText($code); 197 | 198 | =head1 INTERNAL USE ONLY 199 | 200 | Don't touch this. It's subject to change at any time. 201 | 202 | =head1 EXPORT 203 | 204 | Nothing. 205 | 206 | =head1 SUBROUTINES 207 | 208 | =head2 C 209 | 210 | Returns a L object. 211 | 212 | =cut 213 | -------------------------------------------------------------------------------- /script/perldbsyntax: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use DB::Color; 7 | use File::Spec::Functions 'catfile'; 8 | use File::Basename; 9 | 10 | sub uniq (@) { 11 | my %seen = (); 12 | grep { not $seen{$_}++ } @_; 13 | } 14 | 15 | my $program = basename($0); 16 | my $module = shift || die "Ussage $program MODULENAME"; 17 | 18 | my $config = 19 | DB::Color::Config->read( catfile( $ENV{HOME}, DB::Color::default_rcfile() ) ); 20 | my $DB_BASE_DIR = $config->{core}{cache_dir} || DB::Color::default_base_dir(); 21 | 22 | eval "package __ANON__; use $module"; 23 | die $@ if $@; 24 | 25 | my @files = sort uniq map { $INC{$_} } grep { !/^DB\// } keys %INC; 26 | 27 | my $HIGHLIGHTER_CLASS = $config->{core}{highlighter} || 'DB::Color::Highlight'; 28 | eval "use $HIGHLIGHTER_CLASS"; 29 | die $@ if $@; 30 | 31 | my $HIGHLIGHTER = $HIGHLIGHTER_CLASS->new( { cache_dir => $DB_BASE_DIR } ); 32 | 33 | my $total = @files; 34 | my $current = 1; 35 | foreach my $file (@files) { 36 | print "Highlighting $current out of $total: $file\n"; 37 | $current++; 38 | if ( open my $fh, '<', $file ) { 39 | my $code = do { local $/; <$fh> }; 40 | $HIGHLIGHTER->highlight_text($code); # this will cache it 41 | } 42 | else { 43 | warn "Skipping $file. Could not open for reading: $!"; 44 | } 45 | } 46 | 47 | __END__ 48 | 49 | =head1 NAME 50 | 51 | perldbsyntax - Pregenerate syntax highlighting 52 | 53 | =head2 SYNOSPSI 54 | 55 | perldbsyntax DANCER 56 | 57 | =head2 DESCRIPTION 58 | 59 | Run this program, pass it a classname. It will attempt to C that class 60 | and, if successful, will pre-generate the syntax files for everything in 61 | C<%INC>. This helps to avoid the slowdown when debugging code with DB::Color. 62 | 63 | Your C<.perldbcolorrc> file will be respected. 64 | 65 | =head2 SEE ALSO 66 | 67 | L 68 | 69 | =head1 AUTHOR 70 | 71 | Curtis "Ovid" Poe, C<< >> 72 | 73 | =head1 BUGS 74 | 75 | Please report any bugs or feature requests to C, 76 | or through the web interface at 77 | L. I will be 78 | notified, and then you'll automatically be notified of progress on your bug as 79 | I make changes. 80 | 81 | =head1 SUPPORT 82 | 83 | You can find documentation for this module with the perldoc command. 84 | 85 | perldoc DB::Color 86 | 87 | You can also look for information at: 88 | 89 | =over 4 90 | 91 | =item * RT: CPAN's request tracker (report bugs here) 92 | 93 | L 94 | 95 | =item * AnnoCPAN: Annotated CPAN documentation 96 | 97 | L 98 | 99 | =item * CPAN Ratings 100 | 101 | L 102 | 103 | =item * Search CPAN 104 | 105 | L 106 | 107 | =back 108 | 109 | =head1 ACKNOWLEDGEMENTS 110 | 111 | Thanks to Nick Perez, Liz, and the 2012 Perl Hackathon for helping to overcome 112 | some major hurdles with this module. 113 | 114 | =head1 LICENSE AND COPYRIGHT 115 | 116 | Copyright 2011 Curtis "Ovid" Poe. 117 | 118 | This program is free software; you can redistribute it and/or modify it 119 | under the terms of either: the GNU General Public License as published 120 | by the Free Software Foundation; or the Artistic License. 121 | 122 | See http://dev.perl.org/licenses/ for more information. 123 | 124 | 125 | =cut 126 | 127 | 1; # End of DB::Color 128 | -------------------------------------------------------------------------------- /t/00-load.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use Test::More tests => 1; 4 | 5 | BEGIN { 6 | use_ok( 'DB::Color' ) || print "Bail out!\n"; 7 | } 8 | 9 | diag( "Testing DB::Color $DB::Color::VERSION, Perl $], $^X" ); 10 | -------------------------------------------------------------------------------- /t/highlight.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use DB::Color::Highlight; 7 | use File::Temp qw(tempfile tempdir); 8 | 9 | my ( $fh, $file ) = tempfile(); 10 | my $dir = tempdir( CLEANUP => 1 ); 11 | 12 | ok my $highlight = DB::Color::Highlight->new( 13 | { 14 | cache_dir => $dir, 15 | debug_fh => $fh, 16 | } 17 | ), 18 | 'We should be able to create a new DB::Color::Highlight object'; 19 | isa_ok $highlight, 'DB::Color::Highlight', '... and the object it returns'; 20 | 21 | my $test_more_file = $INC{'Test/More.pm'}; 22 | open my $test_fh, '<', $test_more_file 23 | or die "Cannot open '$test_more_file' for reading: $!"; 24 | 25 | my $test_more_code = do { local $/; <$test_fh> }; 26 | close $test_fh; 27 | 28 | can_ok $highlight, '_get_path_and_file'; 29 | my ( $md5_path, $md5_file ) = $highlight->_get_path_and_file($test_more_code); 30 | ok $md5_path, '... and it should return a path'; 31 | ok $md5_file, '... and it should return a md5_filename'; 32 | 33 | my ( $md5_path1, $md5_file1 ) = $highlight->_get_path_and_file($test_more_code); 34 | is $md5_path1, $md5_path, 'Calling it more than once should return the same path'; 35 | is $md5_file1, $md5_file, '... and the same md5_file'; 36 | 37 | can_ok $highlight, '_get_highlighted_text'; 38 | ok my $highlighted = $highlight->_get_highlighted_text($test_more_code), 39 | '... and calling it should highlight our text (*cough*)'; 40 | my @old_lines = split /\n/ => $test_more_code; 41 | my @new_lines = split /\n/ => $highlighted; 42 | 43 | is @old_lines, @new_lines, '... and the number of lines of code should be the same'; 44 | diag @old_lines[165..169]; 45 | diag @new_lines[165..169]; 46 | 47 | done_testing; 48 | -------------------------------------------------------------------------------- /xt/manifest.t: -------------------------------------------------------------------------------- 1 | #!perl -T 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | 7 | unless ( $ENV{RELEASE_TESTING} ) { 8 | plan( skip_all => "Author tests not required for installation" ); 9 | } 10 | 11 | eval "use Test::CheckManifest 0.9"; 12 | plan skip_all => "Test::CheckManifest 0.9 required" if $@; 13 | ok_manifest(); 14 | -------------------------------------------------------------------------------- /xt/pod-coverage.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | 5 | # Ensure a recent version of Test::Pod::Coverage 6 | my $min_tpc = 1.08; 7 | eval "use Test::Pod::Coverage $min_tpc"; 8 | plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage" 9 | if $@; 10 | 11 | # Test::Pod::Coverage doesn't require a minimum Pod::Coverage version, 12 | # but older versions don't recognize some common documentation styles 13 | my $min_pc = 0.18; 14 | eval "use Pod::Coverage $min_pc"; 15 | plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" 16 | if $@; 17 | 18 | all_pod_coverage_ok(); 19 | -------------------------------------------------------------------------------- /xt/pod.t: -------------------------------------------------------------------------------- 1 | #!perl -T 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | 7 | # Ensure a recent version of Test::Pod 8 | my $min_tp = 1.22; 9 | eval "use Test::Pod $min_tp"; 10 | plan skip_all => "Test::Pod $min_tp required for testing POD" if $@; 11 | 12 | all_pod_files_ok(); 13 | --------------------------------------------------------------------------------