├── .gitignore ├── Makefile.PL ├── README ├── build.sh ├── config.sh ├── cope_path.pl ├── dependencies ├── depends.sh ├── inc └── Module │ ├── AutoInstall.pm │ ├── Install.pm │ └── Install │ ├── AutoInstall.pm │ ├── Base.pm │ ├── Can.pm │ ├── Fetch.pm │ ├── Include.pm │ ├── Makefile.pm │ ├── Metadata.pm │ ├── Share.pm │ ├── Win32.pm │ └── WriteAll.pm ├── install.sh ├── lib └── App │ ├── Cope.pm │ └── Cope │ ├── Extra.pm │ ├── Manual.pod │ └── Pty.pm ├── scripts ├── acpi ├── aptitude ├── arp ├── blkid ├── cc ├── cope ├── cpanm ├── df ├── diff ├── dprofpp ├── du ├── fdisk ├── free ├── g++ ├── gcc ├── gdf ├── gid ├── gls ├── gmd5sum ├── gsha1sum ├── gsha224sum ├── gsha256sum ├── gsha384sum ├── gsha512sum ├── gstat ├── gwho ├── id ├── ifconfig ├── ip ├── ls ├── lspci ├── lsusb ├── make ├── md5sum ├── mount ├── mpc ├── netstat ├── nm ├── nmap ├── nocope ├── ping ├── pip ├── pmap ├── ps ├── readelf ├── route ├── screen ├── sha1sum ├── sha224sum ├── sha256sum ├── sha384sum ├── sha512sum ├── shasum ├── socklist ├── stat ├── strace ├── tcpdump ├── top ├── tracepath ├── traceroute ├── valgrind ├── w ├── wget ├── who └── xrandr ├── setup.py ├── setup.sh └── t ├── 00-load.t ├── 10-get.t ├── 11-cope.t ├── 12-buffering.t └── 20-scripts.t /.gitignore: -------------------------------------------------------------------------------- 1 | Makefile 2 | blib/ 3 | pm_to_blib 4 | TODO 5 | -------------------------------------------------------------------------------- /Makefile.PL: -------------------------------------------------------------------------------- 1 | use inc::Module::Install; 2 | 3 | # metadata 4 | name 'Cope'; 5 | all_from 'lib/App/Cope.pm'; 6 | 7 | # use 5.10 for given/when construct 8 | perl_version '5.010'; 9 | 10 | # requirements 11 | requires 'Env::Path'; 12 | requires 'File::ShareDir'; 13 | requires 'IO::Handle'; 14 | requires 'IO::Pty'; 15 | requires 'IO::Stty'; 16 | requires 'List::MoreUtils'; 17 | requires 'Regexp::Common'; 18 | requires 'Term::ANSIColor'; 19 | requires 'Regexp::IPv6'; 20 | 21 | # testing 22 | test_requires 'Test::More'; 23 | 24 | # install the scripts 25 | install_share 'scripts'; 26 | 27 | # go go go! 28 | auto_install; 29 | WriteAll; 30 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | 2 | cope is a wrapper around programs that output to a terminal, to give 3 | them colour for utility and aesthetics while still keeping them the 4 | same at the text level. 5 | 6 | Adding colours on top of text makes it easy to see when something's 7 | amiss. For utility, you can stop hunting through your terminal's 8 | scroll buffer to locate an error when it's clearly highlighted in red, 9 | or locating a network address hidden in dense output when they're 10 | marked in yellow and blue (local and foreign, respectively). As for 11 | aesthetics, even the simplest utility can be brightened up by adding a 12 | dash of colour on top. 13 | 14 | cope's scripts are written in Perl, so they're as flexible (and fast) 15 | as Perl allows. 16 | 17 | --- 18 | 19 | You'll need Perl >= 5.10, and a working version of CPAN. 20 | 21 | Installation is the standard procedure: 22 | 23 | $ perl Makefile.PL 24 | $ make 25 | $ make test 26 | $ sudo make install 27 | 28 | Then, find out where perl put the scripts: 29 | 30 | $ perl cope_path.pl 31 | 32 | And add that to your $PATH. 33 | 34 | --- 35 | 36 | Special Commands: 37 | 38 | * `nocope` or `NOCOPE=1 ...`: Disable all colorization 39 | * `cope` or `COPE=1 ...`: Force colorization 40 | -------------------------------------------------------------------------------- /build.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | errors=$(bash depends.sh) 4 | error=$? 5 | #echo $errors 6 | 7 | if [ $error -eq 0 ];then 8 | perl Makefile.PL 9 | make 10 | exit 0 11 | else 12 | echo missing packages: $errors 13 | echo try: sudo apt-get install $errors 14 | exit $error 15 | fi 16 | -------------------------------------------------------------------------------- /config.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | mkdir -p ~/.bash 4 | echo "export PATH=$(perl cope_path.pl):\$PATH" > ~/.bash/cope 5 | 6 | -------------------------------------------------------------------------------- /cope_path.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | use File::ShareDir q[dist_dir]; 5 | 6 | print dist_dir('Cope') . "\n"; 7 | 8 | 9 | 10 | -------------------------------------------------------------------------------- /dependencies: -------------------------------------------------------------------------------- 1 | libenv-path-perl 2 | libfile-sharedir-perl 3 | libio-pty-perl 4 | libio-stty-perl 5 | liblist-moreutils-perl 6 | libregexp-common-perl 7 | libregexp-ipv6-perl 8 | libc6-dev 9 | make 10 | -------------------------------------------------------------------------------- /depends.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | missing=0 4 | for i in $(cat dependencies);do 5 | j=$(dpkg-query -l $i 2>/dev/null| grep "^.i" | wc -l) 6 | if [ "$j" -eq "0" ]; then 7 | echo $i 8 | missing=$(($missing+1)) 9 | fi 10 | done 11 | exit $missing 12 | -------------------------------------------------------------------------------- /inc/Module/AutoInstall.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::AutoInstall; 3 | 4 | use strict; 5 | use Cwd (); 6 | use ExtUtils::MakeMaker (); 7 | 8 | use vars qw{$VERSION}; 9 | BEGIN { 10 | $VERSION = '1.03'; 11 | } 12 | 13 | # special map on pre-defined feature sets 14 | my %FeatureMap = ( 15 | '' => 'Core Features', # XXX: deprecated 16 | '-core' => 'Core Features', 17 | ); 18 | 19 | # various lexical flags 20 | my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $HasCPANPLUS ); 21 | my ( 22 | $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps 23 | ); 24 | my ( $PostambleActions, $PostambleUsed ); 25 | 26 | # See if it's a testing or non-interactive session 27 | _accept_default( $ENV{AUTOMATED_TESTING} or ! -t STDIN ); 28 | _init(); 29 | 30 | sub _accept_default { 31 | $AcceptDefault = shift; 32 | } 33 | 34 | sub missing_modules { 35 | return @Missing; 36 | } 37 | 38 | sub do_install { 39 | __PACKAGE__->install( 40 | [ 41 | $Config 42 | ? ( UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) 43 | : () 44 | ], 45 | @Missing, 46 | ); 47 | } 48 | 49 | # initialize various flags, and/or perform install 50 | sub _init { 51 | foreach my $arg ( 52 | @ARGV, 53 | split( 54 | /[\s\t]+/, 55 | $ENV{PERL_AUTOINSTALL} || $ENV{PERL_EXTUTILS_AUTOINSTALL} || '' 56 | ) 57 | ) 58 | { 59 | if ( $arg =~ /^--config=(.*)$/ ) { 60 | $Config = [ split( ',', $1 ) ]; 61 | } 62 | elsif ( $arg =~ /^--installdeps=(.*)$/ ) { 63 | __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) ); 64 | exit 0; 65 | } 66 | elsif ( $arg =~ /^--default(?:deps)?$/ ) { 67 | $AcceptDefault = 1; 68 | } 69 | elsif ( $arg =~ /^--check(?:deps)?$/ ) { 70 | $CheckOnly = 1; 71 | } 72 | elsif ( $arg =~ /^--skip(?:deps)?$/ ) { 73 | $SkipInstall = 1; 74 | } 75 | elsif ( $arg =~ /^--test(?:only)?$/ ) { 76 | $TestOnly = 1; 77 | } 78 | elsif ( $arg =~ /^--all(?:deps)?$/ ) { 79 | $AllDeps = 1; 80 | } 81 | } 82 | } 83 | 84 | # overrides MakeMaker's prompt() to automatically accept the default choice 85 | sub _prompt { 86 | goto &ExtUtils::MakeMaker::prompt unless $AcceptDefault; 87 | 88 | my ( $prompt, $default ) = @_; 89 | my $y = ( $default =~ /^[Yy]/ ); 90 | 91 | print $prompt, ' [', ( $y ? 'Y' : 'y' ), '/', ( $y ? 'n' : 'N' ), '] '; 92 | print "$default\n"; 93 | return $default; 94 | } 95 | 96 | # the workhorse 97 | sub import { 98 | my $class = shift; 99 | my @args = @_ or return; 100 | my $core_all; 101 | 102 | print "*** $class version " . $class->VERSION . "\n"; 103 | print "*** Checking for Perl dependencies...\n"; 104 | 105 | my $cwd = Cwd::cwd(); 106 | 107 | $Config = []; 108 | 109 | my $maxlen = length( 110 | ( 111 | sort { length($b) <=> length($a) } 112 | grep { /^[^\-]/ } 113 | map { 114 | ref($_) 115 | ? ( ( ref($_) eq 'HASH' ) ? keys(%$_) : @{$_} ) 116 | : '' 117 | } 118 | map { +{@args}->{$_} } 119 | grep { /^[^\-]/ or /^-core$/i } keys %{ +{@args} } 120 | )[0] 121 | ); 122 | 123 | # We want to know if we're under CPAN early to avoid prompting, but 124 | # if we aren't going to try and install anything anyway then skip the 125 | # check entirely since we don't want to have to load (and configure) 126 | # an old CPAN just for a cosmetic message 127 | 128 | $UnderCPAN = _check_lock(1) unless $SkipInstall; 129 | 130 | while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) { 131 | my ( @required, @tests, @skiptests ); 132 | my $default = 1; 133 | my $conflict = 0; 134 | 135 | if ( $feature =~ m/^-(\w+)$/ ) { 136 | my $option = lc($1); 137 | 138 | # check for a newer version of myself 139 | _update_to( $modules, @_ ) and return if $option eq 'version'; 140 | 141 | # sets CPAN configuration options 142 | $Config = $modules if $option eq 'config'; 143 | 144 | # promote every features to core status 145 | $core_all = ( $modules =~ /^all$/i ) and next 146 | if $option eq 'core'; 147 | 148 | next unless $option eq 'core'; 149 | } 150 | 151 | print "[" . ( $FeatureMap{ lc($feature) } || $feature ) . "]\n"; 152 | 153 | $modules = [ %{$modules} ] if UNIVERSAL::isa( $modules, 'HASH' ); 154 | 155 | unshift @$modules, -default => &{ shift(@$modules) } 156 | if ( ref( $modules->[0] ) eq 'CODE' ); # XXX: bugward combatability 157 | 158 | while ( my ( $mod, $arg ) = splice( @$modules, 0, 2 ) ) { 159 | if ( $mod =~ m/^-(\w+)$/ ) { 160 | my $option = lc($1); 161 | 162 | $default = $arg if ( $option eq 'default' ); 163 | $conflict = $arg if ( $option eq 'conflict' ); 164 | @tests = @{$arg} if ( $option eq 'tests' ); 165 | @skiptests = @{$arg} if ( $option eq 'skiptests' ); 166 | 167 | next; 168 | } 169 | 170 | printf( "- %-${maxlen}s ...", $mod ); 171 | 172 | if ( $arg and $arg =~ /^\D/ ) { 173 | unshift @$modules, $arg; 174 | $arg = 0; 175 | } 176 | 177 | # XXX: check for conflicts and uninstalls(!) them. 178 | my $cur = _load($mod); 179 | if (_version_cmp ($cur, $arg) >= 0) 180 | { 181 | print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n"; 182 | push @Existing, $mod => $arg; 183 | $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; 184 | } 185 | else { 186 | if (not defined $cur) # indeed missing 187 | { 188 | print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n"; 189 | } 190 | else 191 | { 192 | # no need to check $arg as _version_cmp ($cur, undef) would satisfy >= above 193 | print "too old. ($cur < $arg)\n"; 194 | } 195 | 196 | push @required, $mod => $arg; 197 | } 198 | } 199 | 200 | next unless @required; 201 | 202 | my $mandatory = ( $feature eq '-core' or $core_all ); 203 | 204 | if ( 205 | !$SkipInstall 206 | and ( 207 | $CheckOnly 208 | or ($mandatory and $UnderCPAN) 209 | or $AllDeps 210 | or _prompt( 211 | qq{==> Auto-install the } 212 | . ( @required / 2 ) 213 | . ( $mandatory ? ' mandatory' : ' optional' ) 214 | . qq{ module(s) from CPAN?}, 215 | $default ? 'y' : 'n', 216 | ) =~ /^[Yy]/ 217 | ) 218 | ) 219 | { 220 | push( @Missing, @required ); 221 | $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; 222 | } 223 | 224 | elsif ( !$SkipInstall 225 | and $default 226 | and $mandatory 227 | and 228 | _prompt( qq{==> The module(s) are mandatory! Really skip?}, 'n', ) 229 | =~ /^[Nn]/ ) 230 | { 231 | push( @Missing, @required ); 232 | $DisabledTests{$_} = 1 for map { glob($_) } @skiptests; 233 | } 234 | 235 | else { 236 | $DisabledTests{$_} = 1 for map { glob($_) } @tests; 237 | } 238 | } 239 | 240 | if ( @Missing and not( $CheckOnly or $UnderCPAN ) ) { 241 | require Config; 242 | print 243 | "*** Dependencies will be installed the next time you type '$Config::Config{make}'.\n"; 244 | 245 | # make an educated guess of whether we'll need root permission. 246 | print " (You may need to do that as the 'root' user.)\n" 247 | if eval '$>'; 248 | } 249 | print "*** $class configuration finished.\n"; 250 | 251 | chdir $cwd; 252 | 253 | # import to main:: 254 | no strict 'refs'; 255 | *{'main::WriteMakefile'} = \&Write if caller(0) eq 'main'; 256 | } 257 | 258 | sub _running_under { 259 | my $thing = shift; 260 | print <<"END_MESSAGE"; 261 | *** Since we're running under ${thing}, I'll just let it take care 262 | of the dependency's installation later. 263 | END_MESSAGE 264 | return 1; 265 | } 266 | 267 | # Check to see if we are currently running under CPAN.pm and/or CPANPLUS; 268 | # if we are, then we simply let it taking care of our dependencies 269 | sub _check_lock { 270 | return unless @Missing or @_; 271 | 272 | my $cpan_env = $ENV{PERL5_CPAN_IS_RUNNING}; 273 | 274 | if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) { 275 | return _running_under($cpan_env ? 'CPAN' : 'CPANPLUS'); 276 | } 277 | 278 | require CPAN; 279 | 280 | if ($CPAN::VERSION > '1.89') { 281 | if ($cpan_env) { 282 | return _running_under('CPAN'); 283 | } 284 | return; # CPAN.pm new enough, don't need to check further 285 | } 286 | 287 | # last ditch attempt, this -will- configure CPAN, very sorry 288 | 289 | _load_cpan(1); # force initialize even though it's already loaded 290 | 291 | # Find the CPAN lock-file 292 | my $lock = MM->catfile( $CPAN::Config->{cpan_home}, ".lock" ); 293 | return unless -f $lock; 294 | 295 | # Check the lock 296 | local *LOCK; 297 | return unless open(LOCK, $lock); 298 | 299 | if ( 300 | ( $^O eq 'MSWin32' ? _under_cpan() : == getppid() ) 301 | and ( $CPAN::Config->{prerequisites_policy} || '' ) ne 'ignore' 302 | ) { 303 | print <<'END_MESSAGE'; 304 | 305 | *** Since we're running under CPAN, I'll just let it take care 306 | of the dependency's installation later. 307 | END_MESSAGE 308 | return 1; 309 | } 310 | 311 | close LOCK; 312 | return; 313 | } 314 | 315 | sub install { 316 | my $class = shift; 317 | 318 | my $i; # used below to strip leading '-' from config keys 319 | my @config = ( map { s/^-// if ++$i; $_ } @{ +shift } ); 320 | 321 | my ( @modules, @installed ); 322 | while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) { 323 | 324 | # grep out those already installed 325 | if ( _version_cmp( _load($pkg), $ver ) >= 0 ) { 326 | push @installed, $pkg; 327 | } 328 | else { 329 | push @modules, $pkg, $ver; 330 | } 331 | } 332 | 333 | return @installed unless @modules; # nothing to do 334 | return @installed if _check_lock(); # defer to the CPAN shell 335 | 336 | print "*** Installing dependencies...\n"; 337 | 338 | return unless _connected_to('cpan.org'); 339 | 340 | my %args = @config; 341 | my %failed; 342 | local *FAILED; 343 | if ( $args{do_once} and open( FAILED, '.#autoinstall.failed' ) ) { 344 | while () { chomp; $failed{$_}++ } 345 | close FAILED; 346 | 347 | my @newmod; 348 | while ( my ( $k, $v ) = splice( @modules, 0, 2 ) ) { 349 | push @newmod, ( $k => $v ) unless $failed{$k}; 350 | } 351 | @modules = @newmod; 352 | } 353 | 354 | if ( _has_cpanplus() and not $ENV{PERL_AUTOINSTALL_PREFER_CPAN} ) { 355 | _install_cpanplus( \@modules, \@config ); 356 | } else { 357 | _install_cpan( \@modules, \@config ); 358 | } 359 | 360 | print "*** $class installation finished.\n"; 361 | 362 | # see if we have successfully installed them 363 | while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { 364 | if ( _version_cmp( _load($pkg), $ver ) >= 0 ) { 365 | push @installed, $pkg; 366 | } 367 | elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) { 368 | print FAILED "$pkg\n"; 369 | } 370 | } 371 | 372 | close FAILED if $args{do_once}; 373 | 374 | return @installed; 375 | } 376 | 377 | sub _install_cpanplus { 378 | my @modules = @{ +shift }; 379 | my @config = _cpanplus_config( @{ +shift } ); 380 | my $installed = 0; 381 | 382 | require CPANPLUS::Backend; 383 | my $cp = CPANPLUS::Backend->new; 384 | my $conf = $cp->configure_object; 385 | 386 | return unless $conf->can('conf') # 0.05x+ with "sudo" support 387 | or _can_write($conf->_get_build('base')); # 0.04x 388 | 389 | # if we're root, set UNINST=1 to avoid trouble unless user asked for it. 390 | my $makeflags = $conf->get_conf('makeflags') || ''; 391 | if ( UNIVERSAL::isa( $makeflags, 'HASH' ) ) { 392 | # 0.03+ uses a hashref here 393 | $makeflags->{UNINST} = 1 unless exists $makeflags->{UNINST}; 394 | 395 | } else { 396 | # 0.02 and below uses a scalar 397 | $makeflags = join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) 398 | if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); 399 | 400 | } 401 | $conf->set_conf( makeflags => $makeflags ); 402 | $conf->set_conf( prereqs => 1 ); 403 | 404 | 405 | 406 | while ( my ( $key, $val ) = splice( @config, 0, 2 ) ) { 407 | $conf->set_conf( $key, $val ); 408 | } 409 | 410 | my $modtree = $cp->module_tree; 411 | while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { 412 | print "*** Installing $pkg...\n"; 413 | 414 | MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; 415 | 416 | my $success; 417 | my $obj = $modtree->{$pkg}; 418 | 419 | if ( $obj and _version_cmp( $obj->{version}, $ver ) >= 0 ) { 420 | my $pathname = $pkg; 421 | $pathname =~ s/::/\\W/; 422 | 423 | foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { 424 | delete $INC{$inc}; 425 | } 426 | 427 | my $rv = $cp->install( modules => [ $obj->{module} ] ); 428 | 429 | if ( $rv and ( $rv->{ $obj->{module} } or $rv->{ok} ) ) { 430 | print "*** $pkg successfully installed.\n"; 431 | $success = 1; 432 | } else { 433 | print "*** $pkg installation cancelled.\n"; 434 | $success = 0; 435 | } 436 | 437 | $installed += $success; 438 | } else { 439 | print << "."; 440 | *** Could not find a version $ver or above for $pkg; skipping. 441 | . 442 | } 443 | 444 | MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; 445 | } 446 | 447 | return $installed; 448 | } 449 | 450 | sub _cpanplus_config { 451 | my @config = (); 452 | while ( @_ ) { 453 | my ($key, $value) = (shift(), shift()); 454 | if ( $key eq 'prerequisites_policy' ) { 455 | if ( $value eq 'follow' ) { 456 | $value = CPANPLUS::Internals::Constants::PREREQ_INSTALL(); 457 | } elsif ( $value eq 'ask' ) { 458 | $value = CPANPLUS::Internals::Constants::PREREQ_ASK(); 459 | } elsif ( $value eq 'ignore' ) { 460 | $value = CPANPLUS::Internals::Constants::PREREQ_IGNORE(); 461 | } else { 462 | die "*** Cannot convert option $key = '$value' to CPANPLUS version.\n"; 463 | } 464 | } else { 465 | die "*** Cannot convert option $key to CPANPLUS version.\n"; 466 | } 467 | } 468 | return @config; 469 | } 470 | 471 | sub _install_cpan { 472 | my @modules = @{ +shift }; 473 | my @config = @{ +shift }; 474 | my $installed = 0; 475 | my %args; 476 | 477 | _load_cpan(); 478 | require Config; 479 | 480 | if (CPAN->VERSION < 1.80) { 481 | # no "sudo" support, probe for writableness 482 | return unless _can_write( MM->catfile( $CPAN::Config->{cpan_home}, 'sources' ) ) 483 | and _can_write( $Config::Config{sitelib} ); 484 | } 485 | 486 | # if we're root, set UNINST=1 to avoid trouble unless user asked for it. 487 | my $makeflags = $CPAN::Config->{make_install_arg} || ''; 488 | $CPAN::Config->{make_install_arg} = 489 | join( ' ', split( ' ', $makeflags ), 'UNINST=1' ) 490 | if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } ); 491 | 492 | # don't show start-up info 493 | $CPAN::Config->{inhibit_startup_message} = 1; 494 | 495 | # set additional options 496 | while ( my ( $opt, $arg ) = splice( @config, 0, 2 ) ) { 497 | ( $args{$opt} = $arg, next ) 498 | if $opt =~ /^force$/; # pseudo-option 499 | $CPAN::Config->{$opt} = $arg; 500 | } 501 | 502 | local $CPAN::Config->{prerequisites_policy} = 'follow'; 503 | 504 | while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) { 505 | MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall; 506 | 507 | print "*** Installing $pkg...\n"; 508 | 509 | my $obj = CPAN::Shell->expand( Module => $pkg ); 510 | my $success = 0; 511 | 512 | if ( $obj and _version_cmp( $obj->cpan_version, $ver ) >= 0 ) { 513 | my $pathname = $pkg; 514 | $pathname =~ s/::/\\W/; 515 | 516 | foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) { 517 | delete $INC{$inc}; 518 | } 519 | 520 | my $rv = $args{force} ? CPAN::Shell->force( install => $pkg ) 521 | : CPAN::Shell->install($pkg); 522 | $rv ||= eval { 523 | $CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, ) 524 | ->{install} 525 | if $CPAN::META; 526 | }; 527 | 528 | if ( $rv eq 'YES' ) { 529 | print "*** $pkg successfully installed.\n"; 530 | $success = 1; 531 | } 532 | else { 533 | print "*** $pkg installation failed.\n"; 534 | $success = 0; 535 | } 536 | 537 | $installed += $success; 538 | } 539 | else { 540 | print << "."; 541 | *** Could not find a version $ver or above for $pkg; skipping. 542 | . 543 | } 544 | 545 | MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall; 546 | } 547 | 548 | return $installed; 549 | } 550 | 551 | sub _has_cpanplus { 552 | return ( 553 | $HasCPANPLUS = ( 554 | $INC{'CPANPLUS/Config.pm'} 555 | or _load('CPANPLUS::Shell::Default') 556 | ) 557 | ); 558 | } 559 | 560 | # make guesses on whether we're under the CPAN installation directory 561 | sub _under_cpan { 562 | require Cwd; 563 | require File::Spec; 564 | 565 | my $cwd = File::Spec->canonpath( Cwd::cwd() ); 566 | my $cpan = File::Spec->canonpath( $CPAN::Config->{cpan_home} ); 567 | 568 | return ( index( $cwd, $cpan ) > -1 ); 569 | } 570 | 571 | sub _update_to { 572 | my $class = __PACKAGE__; 573 | my $ver = shift; 574 | 575 | return 576 | if _version_cmp( _load($class), $ver ) >= 0; # no need to upgrade 577 | 578 | if ( 579 | _prompt( "==> A newer version of $class ($ver) is required. Install?", 580 | 'y' ) =~ /^[Nn]/ 581 | ) 582 | { 583 | die "*** Please install $class $ver manually.\n"; 584 | } 585 | 586 | print << "."; 587 | *** Trying to fetch it from CPAN... 588 | . 589 | 590 | # install ourselves 591 | _load($class) and return $class->import(@_) 592 | if $class->install( [], $class, $ver ); 593 | 594 | print << '.'; exit 1; 595 | 596 | *** Cannot bootstrap myself. :-( Installation terminated. 597 | . 598 | } 599 | 600 | # check if we're connected to some host, using inet_aton 601 | sub _connected_to { 602 | my $site = shift; 603 | 604 | return ( 605 | ( _load('Socket') and Socket::inet_aton($site) ) or _prompt( 606 | qq( 607 | *** Your host cannot resolve the domain name '$site', which 608 | probably means the Internet connections are unavailable. 609 | ==> Should we try to install the required module(s) anyway?), 'n' 610 | ) =~ /^[Yy]/ 611 | ); 612 | } 613 | 614 | # check if a directory is writable; may create it on demand 615 | sub _can_write { 616 | my $path = shift; 617 | mkdir( $path, 0755 ) unless -e $path; 618 | 619 | return 1 if -w $path; 620 | 621 | print << "."; 622 | *** You are not allowed to write to the directory '$path'; 623 | the installation may fail due to insufficient permissions. 624 | . 625 | 626 | if ( 627 | eval '$>' and lc(`sudo -V`) =~ /version/ and _prompt( 628 | qq( 629 | ==> Should we try to re-execute the autoinstall process with 'sudo'?), 630 | ((-t STDIN) ? 'y' : 'n') 631 | ) =~ /^[Yy]/ 632 | ) 633 | { 634 | 635 | # try to bootstrap ourselves from sudo 636 | print << "."; 637 | *** Trying to re-execute the autoinstall process with 'sudo'... 638 | . 639 | my $missing = join( ',', @Missing ); 640 | my $config = join( ',', 641 | UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) 642 | if $Config; 643 | 644 | return 645 | unless system( 'sudo', $^X, $0, "--config=$config", 646 | "--installdeps=$missing" ); 647 | 648 | print << "."; 649 | *** The 'sudo' command exited with error! Resuming... 650 | . 651 | } 652 | 653 | return _prompt( 654 | qq( 655 | ==> Should we try to install the required module(s) anyway?), 'n' 656 | ) =~ /^[Yy]/; 657 | } 658 | 659 | # load a module and return the version it reports 660 | sub _load { 661 | my $mod = pop; # class/instance doesn't matter 662 | my $file = $mod; 663 | 664 | $file =~ s|::|/|g; 665 | $file .= '.pm'; 666 | 667 | local $@; 668 | return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 ); 669 | } 670 | 671 | # Load CPAN.pm and it's configuration 672 | sub _load_cpan { 673 | return if $CPAN::VERSION and $CPAN::Config and not @_; 674 | require CPAN; 675 | if ( $CPAN::HandleConfig::VERSION ) { 676 | # Newer versions of CPAN have a HandleConfig module 677 | CPAN::HandleConfig->load; 678 | } else { 679 | # Older versions had the load method in Config directly 680 | CPAN::Config->load; 681 | } 682 | } 683 | 684 | # compare two versions, either use Sort::Versions or plain comparison 685 | # return values same as <=> 686 | sub _version_cmp { 687 | my ( $cur, $min ) = @_; 688 | return -1 unless defined $cur; # if 0 keep comparing 689 | return 1 unless $min; 690 | 691 | $cur =~ s/\s+$//; 692 | 693 | # check for version numbers that are not in decimal format 694 | if ( ref($cur) or ref($min) or $cur =~ /v|\..*\./ or $min =~ /v|\..*\./ ) { 695 | if ( ( $version::VERSION or defined( _load('version') )) and 696 | version->can('new') 697 | ) { 698 | 699 | # use version.pm if it is installed. 700 | return version->new($cur) <=> version->new($min); 701 | } 702 | elsif ( $Sort::Versions::VERSION or defined( _load('Sort::Versions') ) ) 703 | { 704 | 705 | # use Sort::Versions as the sorting algorithm for a.b.c versions 706 | return Sort::Versions::versioncmp( $cur, $min ); 707 | } 708 | 709 | warn "Cannot reliably compare non-decimal formatted versions.\n" 710 | . "Please install version.pm or Sort::Versions.\n"; 711 | } 712 | 713 | # plain comparison 714 | local $^W = 0; # shuts off 'not numeric' bugs 715 | return $cur <=> $min; 716 | } 717 | 718 | # nothing; this usage is deprecated. 719 | sub main::PREREQ_PM { return {}; } 720 | 721 | sub _make_args { 722 | my %args = @_; 723 | 724 | $args{PREREQ_PM} = { %{ $args{PREREQ_PM} || {} }, @Existing, @Missing } 725 | if $UnderCPAN or $TestOnly; 726 | 727 | if ( $args{EXE_FILES} and -e 'MANIFEST' ) { 728 | require ExtUtils::Manifest; 729 | my $manifest = ExtUtils::Manifest::maniread('MANIFEST'); 730 | 731 | $args{EXE_FILES} = 732 | [ grep { exists $manifest->{$_} } @{ $args{EXE_FILES} } ]; 733 | } 734 | 735 | $args{test}{TESTS} ||= 't/*.t'; 736 | $args{test}{TESTS} = join( ' ', 737 | grep { !exists( $DisabledTests{$_} ) } 738 | map { glob($_) } split( /\s+/, $args{test}{TESTS} ) ); 739 | 740 | my $missing = join( ',', @Missing ); 741 | my $config = 742 | join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} ) 743 | if $Config; 744 | 745 | $PostambleActions = ( 746 | ($missing and not $UnderCPAN) 747 | ? "\$(PERL) $0 --config=$config --installdeps=$missing" 748 | : "\$(NOECHO) \$(NOOP)" 749 | ); 750 | 751 | return %args; 752 | } 753 | 754 | # a wrapper to ExtUtils::MakeMaker::WriteMakefile 755 | sub Write { 756 | require Carp; 757 | Carp::croak "WriteMakefile: Need even number of args" if @_ % 2; 758 | 759 | if ($CheckOnly) { 760 | print << "."; 761 | *** Makefile not written in check-only mode. 762 | . 763 | return; 764 | } 765 | 766 | my %args = _make_args(@_); 767 | 768 | no strict 'refs'; 769 | 770 | $PostambleUsed = 0; 771 | local *MY::postamble = \&postamble unless defined &MY::postamble; 772 | ExtUtils::MakeMaker::WriteMakefile(%args); 773 | 774 | print << "." unless $PostambleUsed; 775 | *** WARNING: Makefile written with customized MY::postamble() without 776 | including contents from Module::AutoInstall::postamble() -- 777 | auto installation features disabled. Please contact the author. 778 | . 779 | 780 | return 1; 781 | } 782 | 783 | sub postamble { 784 | $PostambleUsed = 1; 785 | 786 | return <<"END_MAKE"; 787 | 788 | config :: installdeps 789 | \t\$(NOECHO) \$(NOOP) 790 | 791 | checkdeps :: 792 | \t\$(PERL) $0 --checkdeps 793 | 794 | installdeps :: 795 | \t$PostambleActions 796 | 797 | END_MAKE 798 | 799 | } 800 | 801 | 1; 802 | 803 | __END__ 804 | 805 | #line 1056 806 | -------------------------------------------------------------------------------- /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.005; 21 | use strict 'vars'; 22 | 23 | use vars qw{$VERSION $MAIN}; 24 | BEGIN { 25 | # All Module::Install core packages now require synchronised versions. 26 | # This will be used to ensure we don't accidentally load old or 27 | # different versions of modules. 28 | # This is not enforced yet, but will be some time in the next few 29 | # releases once we can make sure it won't clash with custom 30 | # Module::Install extensions. 31 | $VERSION = '0.91'; 32 | 33 | # Storage for the pseudo-singleton 34 | $MAIN = undef; 35 | 36 | *inc::Module::Install::VERSION = *VERSION; 37 | @inc::Module::Install::ISA = __PACKAGE__; 38 | 39 | } 40 | 41 | 42 | 43 | 44 | 45 | # Whether or not inc::Module::Install is actually loaded, the 46 | # $INC{inc/Module/Install.pm} is what will still get set as long as 47 | # the caller loaded module this in the documented manner. 48 | # If not set, the caller may NOT have loaded the bundled version, and thus 49 | # they may not have a MI version that works with the Makefile.PL. This would 50 | # result in false errors or unexpected behaviour. And we don't want that. 51 | my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; 52 | unless ( $INC{$file} ) { die <<"END_DIE" } 53 | 54 | Please invoke ${\__PACKAGE__} with: 55 | 56 | use inc::${\__PACKAGE__}; 57 | 58 | not: 59 | 60 | use ${\__PACKAGE__}; 61 | 62 | END_DIE 63 | 64 | 65 | 66 | 67 | 68 | # If the script that is loading Module::Install is from the future, 69 | # then make will detect this and cause it to re-run over and over 70 | # again. This is bad. Rather than taking action to touch it (which 71 | # is unreliable on some platforms and requires write permissions) 72 | # for now we should catch this and refuse to run. 73 | if ( -f $0 ) { 74 | my $s = (stat($0))[9]; 75 | 76 | # If the modification time is only slightly in the future, 77 | # sleep briefly to remove the problem. 78 | my $a = $s - time; 79 | if ( $a > 0 and $a < 5 ) { sleep 5 } 80 | 81 | # Too far in the future, throw an error. 82 | my $t = time; 83 | if ( $s > $t ) { die <<"END_DIE" } 84 | 85 | Your installer $0 has a modification time in the future ($s > $t). 86 | 87 | This is known to create infinite loops in make. 88 | 89 | Please correct this, then run $0 again. 90 | 91 | END_DIE 92 | } 93 | 94 | 95 | 96 | 97 | 98 | # Build.PL was formerly supported, but no longer is due to excessive 99 | # difficulty in implementing every single feature twice. 100 | if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } 101 | 102 | Module::Install no longer supports Build.PL. 103 | 104 | It was impossible to maintain duel backends, and has been deprecated. 105 | 106 | Please remove all Build.PL files and only use the Makefile.PL installer. 107 | 108 | END_DIE 109 | 110 | 111 | 112 | 113 | 114 | # To save some more typing in Module::Install installers, every... 115 | # use inc::Module::Install 116 | # ...also acts as an implicit use strict. 117 | $^H |= strict::bits(qw(refs subs vars)); 118 | 119 | 120 | 121 | 122 | 123 | use Cwd (); 124 | use File::Find (); 125 | use File::Path (); 126 | use FindBin; 127 | 128 | sub autoload { 129 | my $self = shift; 130 | my $who = $self->_caller; 131 | my $cwd = Cwd::cwd(); 132 | my $sym = "${who}::AUTOLOAD"; 133 | $sym->{$cwd} = sub { 134 | my $pwd = Cwd::cwd(); 135 | if ( my $code = $sym->{$pwd} ) { 136 | # Delegate back to parent dirs 137 | goto &$code unless $cwd eq $pwd; 138 | } 139 | $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym"; 140 | my $method = $1; 141 | if ( uc($method) eq $method ) { 142 | # Do nothing 143 | return; 144 | } elsif ( $method =~ /^_/ and $self->can($method) ) { 145 | # Dispatch to the root M:I class 146 | return $self->$method(@_); 147 | } 148 | 149 | # Dispatch to the appropriate plugin 150 | unshift @_, ( $self, $1 ); 151 | goto &{$self->can('call')}; 152 | }; 153 | } 154 | 155 | sub import { 156 | my $class = shift; 157 | my $self = $class->new(@_); 158 | my $who = $self->_caller; 159 | 160 | unless ( -f $self->{file} ) { 161 | require "$self->{path}/$self->{dispatch}.pm"; 162 | File::Path::mkpath("$self->{prefix}/$self->{author}"); 163 | $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); 164 | $self->{admin}->init; 165 | @_ = ($class, _self => $self); 166 | goto &{"$self->{name}::import"}; 167 | } 168 | 169 | *{"${who}::AUTOLOAD"} = $self->autoload; 170 | $self->preload; 171 | 172 | # Unregister loader and worker packages so subdirs can use them again 173 | delete $INC{"$self->{file}"}; 174 | delete $INC{"$self->{path}.pm"}; 175 | 176 | # Save to the singleton 177 | $MAIN = $self; 178 | 179 | return 1; 180 | } 181 | 182 | sub preload { 183 | my $self = shift; 184 | unless ( $self->{extensions} ) { 185 | $self->load_extensions( 186 | "$self->{prefix}/$self->{path}", $self 187 | ); 188 | } 189 | 190 | my @exts = @{$self->{extensions}}; 191 | unless ( @exts ) { 192 | @exts = $self->{admin}->load_all_extensions; 193 | } 194 | 195 | my %seen; 196 | foreach my $obj ( @exts ) { 197 | while (my ($method, $glob) = each %{ref($obj) . '::'}) { 198 | next unless $obj->can($method); 199 | next if $method =~ /^_/; 200 | next if $method eq uc($method); 201 | $seen{$method}++; 202 | } 203 | } 204 | 205 | my $who = $self->_caller; 206 | foreach my $name ( sort keys %seen ) { 207 | *{"${who}::$name"} = sub { 208 | ${"${who}::AUTOLOAD"} = "${who}::$name"; 209 | goto &{"${who}::AUTOLOAD"}; 210 | }; 211 | } 212 | } 213 | 214 | sub new { 215 | my ($class, %args) = @_; 216 | 217 | # ignore the prefix on extension modules built from top level. 218 | my $base_path = Cwd::abs_path($FindBin::Bin); 219 | unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { 220 | delete $args{prefix}; 221 | } 222 | 223 | return $args{_self} if $args{_self}; 224 | 225 | $args{dispatch} ||= 'Admin'; 226 | $args{prefix} ||= 'inc'; 227 | $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); 228 | $args{bundle} ||= 'inc/BUNDLES'; 229 | $args{base} ||= $base_path; 230 | $class =~ s/^\Q$args{prefix}\E:://; 231 | $args{name} ||= $class; 232 | $args{version} ||= $class->VERSION; 233 | unless ( $args{path} ) { 234 | $args{path} = $args{name}; 235 | $args{path} =~ s!::!/!g; 236 | } 237 | $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; 238 | $args{wrote} = 0; 239 | 240 | bless( \%args, $class ); 241 | } 242 | 243 | sub call { 244 | my ($self, $method) = @_; 245 | my $obj = $self->load($method) or return; 246 | splice(@_, 0, 2, $obj); 247 | goto &{$obj->can($method)}; 248 | } 249 | 250 | sub load { 251 | my ($self, $method) = @_; 252 | 253 | $self->load_extensions( 254 | "$self->{prefix}/$self->{path}", $self 255 | ) unless $self->{extensions}; 256 | 257 | foreach my $obj (@{$self->{extensions}}) { 258 | return $obj if $obj->can($method); 259 | } 260 | 261 | my $admin = $self->{admin} or die <<"END_DIE"; 262 | The '$method' method does not exist in the '$self->{prefix}' path! 263 | Please remove the '$self->{prefix}' directory and run $0 again to load it. 264 | END_DIE 265 | 266 | my $obj = $admin->load($method, 1); 267 | push @{$self->{extensions}}, $obj; 268 | 269 | $obj; 270 | } 271 | 272 | sub load_extensions { 273 | my ($self, $path, $top) = @_; 274 | 275 | unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { 276 | unshift @INC, $self->{prefix}; 277 | } 278 | 279 | foreach my $rv ( $self->find_extensions($path) ) { 280 | my ($file, $pkg) = @{$rv}; 281 | next if $self->{pathnames}{$pkg}; 282 | 283 | local $@; 284 | my $new = eval { require $file; $pkg->can('new') }; 285 | unless ( $new ) { 286 | warn $@ if $@; 287 | next; 288 | } 289 | $self->{pathnames}{$pkg} = delete $INC{$file}; 290 | push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); 291 | } 292 | 293 | $self->{extensions} ||= []; 294 | } 295 | 296 | sub find_extensions { 297 | my ($self, $path) = @_; 298 | 299 | my @found; 300 | File::Find::find( sub { 301 | my $file = $File::Find::name; 302 | return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; 303 | my $subpath = $1; 304 | return if lc($subpath) eq lc($self->{dispatch}); 305 | 306 | $file = "$self->{path}/$subpath.pm"; 307 | my $pkg = "$self->{name}::$subpath"; 308 | $pkg =~ s!/!::!g; 309 | 310 | # If we have a mixed-case package name, assume case has been preserved 311 | # correctly. Otherwise, root through the file to locate the case-preserved 312 | # version of the package name. 313 | if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { 314 | my $content = Module::Install::_read($subpath . '.pm'); 315 | my $in_pod = 0; 316 | foreach ( split //, $content ) { 317 | $in_pod = 1 if /^=\w/; 318 | $in_pod = 0 if /^=cut/; 319 | next if ($in_pod || /^=cut/); # skip pod text 320 | next if /^\s*#/; # and comments 321 | if ( m/^\s*package\s+($pkg)\s*;/i ) { 322 | $pkg = $1; 323 | last; 324 | } 325 | } 326 | } 327 | 328 | push @found, [ $file, $pkg ]; 329 | }, $path ) if -d $path; 330 | 331 | @found; 332 | } 333 | 334 | 335 | 336 | 337 | 338 | ##################################################################### 339 | # Common Utility Functions 340 | 341 | sub _caller { 342 | my $depth = 0; 343 | my $call = caller($depth); 344 | while ( $call eq __PACKAGE__ ) { 345 | $depth++; 346 | $call = caller($depth); 347 | } 348 | return $call; 349 | } 350 | 351 | sub _read { 352 | local *FH; 353 | if ( $] >= 5.006 ) { 354 | open( FH, '<', $_[0] ) or die "open($_[0]): $!"; 355 | } else { 356 | open( FH, "< $_[0]" ) or die "open($_[0]): $!"; 357 | } 358 | my $string = do { local $/; }; 359 | close FH or die "close($_[0]): $!"; 360 | return $string; 361 | } 362 | 363 | sub _readperl { 364 | my $string = Module::Install::_read($_[0]); 365 | $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; 366 | $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; 367 | $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; 368 | return $string; 369 | } 370 | 371 | sub _readpod { 372 | my $string = Module::Install::_read($_[0]); 373 | $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; 374 | return $string if $_[0] =~ /\.pod\z/; 375 | $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; 376 | $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; 377 | $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; 378 | $string =~ s/^\n+//s; 379 | return $string; 380 | } 381 | 382 | sub _write { 383 | local *FH; 384 | if ( $] >= 5.006 ) { 385 | open( FH, '>', $_[0] ) or die "open($_[0]): $!"; 386 | } else { 387 | open( FH, "> $_[0]" ) or die "open($_[0]): $!"; 388 | } 389 | foreach ( 1 .. $#_ ) { 390 | print FH $_[$_] or die "print($_[0]): $!"; 391 | } 392 | close FH or die "close($_[0]): $!"; 393 | } 394 | 395 | # _version is for processing module versions (eg, 1.03_05) not 396 | # Perl versions (eg, 5.8.1). 397 | sub _version ($) { 398 | my $s = shift || 0; 399 | my $d =()= $s =~ /(\.)/g; 400 | if ( $d >= 2 ) { 401 | # Normalise multipart versions 402 | $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; 403 | } 404 | $s =~ s/^(\d+)\.?//; 405 | my $l = $1 || 0; 406 | my @v = map { 407 | $_ . '0' x (3 - length $_) 408 | } $s =~ /(\d{1,3})\D?/g; 409 | $l = $l . '.' . join '', @v if @v; 410 | return $l + 0; 411 | } 412 | 413 | sub _cmp ($$) { 414 | _version($_[0]) <=> _version($_[1]); 415 | } 416 | 417 | # Cloned from Params::Util::_CLASS 418 | sub _CLASS ($) { 419 | ( 420 | defined $_[0] 421 | and 422 | ! ref $_[0] 423 | and 424 | $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s 425 | ) ? $_[0] : undef; 426 | } 427 | 428 | 1; 429 | 430 | # Copyright 2008 - 2009 Adam Kennedy. 431 | -------------------------------------------------------------------------------- /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 = '0.91'; 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 | Module::AutoInstall->import( 41 | (@config ? (-config => \@config) : ()), 42 | (@core ? (-core => \@core) : ()), 43 | $self->features, 44 | ); 45 | 46 | $self->makemaker_args( Module::AutoInstall::_make_args() ); 47 | 48 | my $class = ref($self); 49 | $self->postamble( 50 | "# --- $class section:\n" . 51 | Module::AutoInstall::postamble() 52 | ); 53 | } 54 | 55 | sub auto_install_now { 56 | my $self = shift; 57 | $self->auto_install(@_); 58 | Module::AutoInstall::do_install(); 59 | } 60 | 61 | 1; 62 | -------------------------------------------------------------------------------- /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 = '0.91'; 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->VERSION; 55 | } 56 | 57 | sub DESTROY {} 58 | 59 | package Module::Install::Base::FakeAdmin; 60 | 61 | my $fake; 62 | 63 | sub new { 64 | $fake ||= bless(\@_, $_[0]); 65 | } 66 | 67 | sub AUTOLOAD {} 68 | 69 | sub DESTROY {} 70 | 71 | # Restore warning handler 72 | BEGIN { 73 | $SIG{__WARN__} = $SIG{__WARN__}->(); 74 | } 75 | 76 | 1; 77 | 78 | #line 154 79 | -------------------------------------------------------------------------------- /inc/Module/Install/Can.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::Can; 3 | 4 | use strict; 5 | use Config (); 6 | use File::Spec (); 7 | use ExtUtils::MakeMaker (); 8 | use Module::Install::Base (); 9 | 10 | use vars qw{$VERSION @ISA $ISCORE}; 11 | BEGIN { 12 | $VERSION = '0.91'; 13 | @ISA = 'Module::Install::Base'; 14 | $ISCORE = 1; 15 | } 16 | 17 | # check if we can load some module 18 | ### Upgrade this to not have to load the module if possible 19 | sub can_use { 20 | my ($self, $mod, $ver) = @_; 21 | $mod =~ s{::|\\}{/}g; 22 | $mod .= '.pm' unless $mod =~ /\.pm$/i; 23 | 24 | my $pkg = $mod; 25 | $pkg =~ s{/}{::}g; 26 | $pkg =~ s{\.pm$}{}i; 27 | 28 | local $@; 29 | eval { require $mod; $pkg->VERSION($ver || 0); 1 }; 30 | } 31 | 32 | # check if we can run some command 33 | sub can_run { 34 | my ($self, $cmd) = @_; 35 | 36 | my $_cmd = $cmd; 37 | return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); 38 | 39 | for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { 40 | next if $dir eq ''; 41 | my $abs = File::Spec->catfile($dir, $_[1]); 42 | return $abs if (-x $abs or $abs = MM->maybe_command($abs)); 43 | } 44 | 45 | return; 46 | } 47 | 48 | # can we locate a (the) C compiler 49 | sub can_cc { 50 | my $self = shift; 51 | my @chunks = split(/ /, $Config::Config{cc}) or return; 52 | 53 | # $Config{cc} may contain args; try to find out the program part 54 | while (@chunks) { 55 | return $self->can_run("@chunks") || (pop(@chunks), next); 56 | } 57 | 58 | return; 59 | } 60 | 61 | # Fix Cygwin bug on maybe_command(); 62 | if ( $^O eq 'cygwin' ) { 63 | require ExtUtils::MM_Cygwin; 64 | require ExtUtils::MM_Win32; 65 | if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { 66 | *ExtUtils::MM_Cygwin::maybe_command = sub { 67 | my ($self, $file) = @_; 68 | if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { 69 | ExtUtils::MM_Win32->maybe_command($file); 70 | } else { 71 | ExtUtils::MM_Unix->maybe_command($file); 72 | } 73 | } 74 | } 75 | } 76 | 77 | 1; 78 | 79 | __END__ 80 | 81 | #line 156 82 | -------------------------------------------------------------------------------- /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 = '0.91'; 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 = '0.91'; 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 | 8 | use vars qw{$VERSION @ISA $ISCORE}; 9 | BEGIN { 10 | $VERSION = '0.91'; 11 | @ISA = 'Module::Install::Base'; 12 | $ISCORE = 1; 13 | } 14 | 15 | sub Makefile { $_[0] } 16 | 17 | my %seen = (); 18 | 19 | sub prompt { 20 | shift; 21 | 22 | # Infinite loop protection 23 | my @c = caller(); 24 | if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { 25 | die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; 26 | } 27 | 28 | # In automated testing, always use defaults 29 | if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) { 30 | local $ENV{PERL_MM_USE_DEFAULT} = 1; 31 | goto &ExtUtils::MakeMaker::prompt; 32 | } else { 33 | goto &ExtUtils::MakeMaker::prompt; 34 | } 35 | } 36 | 37 | sub makemaker_args { 38 | my $self = shift; 39 | my $args = ( $self->{makemaker_args} ||= {} ); 40 | %$args = ( %$args, @_ ); 41 | return $args; 42 | } 43 | 44 | # For mm args that take multiple space-seperated args, 45 | # append an argument to the current list. 46 | sub makemaker_append { 47 | my $self = sShift; 48 | my $name = shift; 49 | my $args = $self->makemaker_args; 50 | $args->{name} = defined $args->{$name} 51 | ? join( ' ', $args->{name}, @_ ) 52 | : join( ' ', @_ ); 53 | } 54 | 55 | sub build_subdirs { 56 | my $self = shift; 57 | my $subdirs = $self->makemaker_args->{DIR} ||= []; 58 | for my $subdir (@_) { 59 | push @$subdirs, $subdir; 60 | } 61 | } 62 | 63 | sub clean_files { 64 | my $self = shift; 65 | my $clean = $self->makemaker_args->{clean} ||= {}; 66 | %$clean = ( 67 | %$clean, 68 | FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), 69 | ); 70 | } 71 | 72 | sub realclean_files { 73 | my $self = shift; 74 | my $realclean = $self->makemaker_args->{realclean} ||= {}; 75 | %$realclean = ( 76 | %$realclean, 77 | FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), 78 | ); 79 | } 80 | 81 | sub libs { 82 | my $self = shift; 83 | my $libs = ref $_[0] ? shift : [ shift ]; 84 | $self->makemaker_args( LIBS => $libs ); 85 | } 86 | 87 | sub inc { 88 | my $self = shift; 89 | $self->makemaker_args( INC => shift ); 90 | } 91 | 92 | my %test_dir = (); 93 | 94 | sub _wanted_t { 95 | /\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1; 96 | } 97 | 98 | sub tests_recursive { 99 | my $self = shift; 100 | if ( $self->tests ) { 101 | die "tests_recursive will not work if tests are already defined"; 102 | } 103 | my $dir = shift || 't'; 104 | unless ( -d $dir ) { 105 | die "tests_recursive dir '$dir' does not exist"; 106 | } 107 | %test_dir = (); 108 | require File::Find; 109 | File::Find::find( \&_wanted_t, $dir ); 110 | $self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir ); 111 | } 112 | 113 | sub write { 114 | my $self = shift; 115 | die "&Makefile->write() takes no arguments\n" if @_; 116 | 117 | # Check the current Perl version 118 | my $perl_version = $self->perl_version; 119 | if ( $perl_version ) { 120 | eval "use $perl_version; 1" 121 | or die "ERROR: perl: Version $] is installed, " 122 | . "but we need version >= $perl_version"; 123 | } 124 | 125 | # Make sure we have a new enough MakeMaker 126 | require ExtUtils::MakeMaker; 127 | 128 | if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { 129 | # MakeMaker can complain about module versions that include 130 | # an underscore, even though its own version may contain one! 131 | # Hence the funny regexp to get rid of it. See RT #35800 132 | # for details. 133 | $self->build_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ ); 134 | $self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ ); 135 | } else { 136 | # Allow legacy-compatibility with 5.005 by depending on the 137 | # most recent EU:MM that supported 5.005. 138 | $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 ); 139 | $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 ); 140 | } 141 | 142 | # Generate the MakeMaker params 143 | my $args = $self->makemaker_args; 144 | $args->{DISTNAME} = $self->name; 145 | $args->{NAME} = $self->module_name || $self->name; 146 | $args->{VERSION} = $self->version; 147 | $args->{NAME} =~ s/-/::/g; 148 | if ( $self->tests ) { 149 | $args->{test} = { TESTS => $self->tests }; 150 | } 151 | if ( $] >= 5.005 ) { 152 | $args->{ABSTRACT} = $self->abstract; 153 | $args->{AUTHOR} = $self->author; 154 | } 155 | if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) { 156 | $args->{NO_META} = 1; 157 | } 158 | if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) { 159 | $args->{SIGN} = 1; 160 | } 161 | unless ( $self->is_admin ) { 162 | delete $args->{SIGN}; 163 | } 164 | 165 | # Merge both kinds of requires into prereq_pm 166 | my $prereq = ($args->{PREREQ_PM} ||= {}); 167 | %$prereq = ( %$prereq, 168 | map { @$_ } 169 | map { @$_ } 170 | grep $_, 171 | ($self->configure_requires, $self->build_requires, $self->requires) 172 | ); 173 | 174 | # Remove any reference to perl, PREREQ_PM doesn't support it 175 | delete $args->{PREREQ_PM}->{perl}; 176 | 177 | # merge both kinds of requires into prereq_pm 178 | my $subdirs = ($args->{DIR} ||= []); 179 | if ($self->bundles) { 180 | foreach my $bundle (@{ $self->bundles }) { 181 | my ($file, $dir) = @$bundle; 182 | push @$subdirs, $dir if -d $dir; 183 | delete $prereq->{$file}; 184 | } 185 | } 186 | 187 | if ( my $perl_version = $self->perl_version ) { 188 | eval "use $perl_version; 1" 189 | or die "ERROR: perl: Version $] is installed, " 190 | . "but we need version >= $perl_version"; 191 | } 192 | 193 | $args->{INSTALLDIRS} = $self->installdirs; 194 | 195 | my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args; 196 | 197 | my $user_preop = delete $args{dist}->{PREOP}; 198 | if (my $preop = $self->admin->preop($user_preop)) { 199 | foreach my $key ( keys %$preop ) { 200 | $args{dist}->{$key} = $preop->{$key}; 201 | } 202 | } 203 | 204 | my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); 205 | $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); 206 | } 207 | 208 | sub fix_up_makefile { 209 | my $self = shift; 210 | my $makefile_name = shift; 211 | my $top_class = ref($self->_top) || ''; 212 | my $top_version = $self->_top->VERSION || ''; 213 | 214 | my $preamble = $self->preamble 215 | ? "# Preamble by $top_class $top_version\n" 216 | . $self->preamble 217 | : ''; 218 | my $postamble = "# Postamble by $top_class $top_version\n" 219 | . ($self->postamble || ''); 220 | 221 | local *MAKEFILE; 222 | open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; 223 | my $makefile = do { local $/; }; 224 | close MAKEFILE or die $!; 225 | 226 | $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; 227 | $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; 228 | $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; 229 | $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; 230 | $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; 231 | 232 | # Module::Install will never be used to build the Core Perl 233 | # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks 234 | # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist 235 | $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; 236 | #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; 237 | 238 | # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. 239 | $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; 240 | 241 | # XXX - This is currently unused; not sure if it breaks other MM-users 242 | # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; 243 | 244 | open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; 245 | print MAKEFILE "$preamble$makefile$postamble" or die $!; 246 | close MAKEFILE or die $!; 247 | 248 | 1; 249 | } 250 | 251 | sub preamble { 252 | my ($self, $text) = @_; 253 | $self->{preamble} = $text . $self->{preamble} if defined $text; 254 | $self->{preamble}; 255 | } 256 | 257 | sub postamble { 258 | my ($self, $text) = @_; 259 | $self->{postamble} ||= $self->admin->postamble; 260 | $self->{postamble} .= $text if defined $text; 261 | $self->{postamble} 262 | } 263 | 264 | 1; 265 | 266 | __END__ 267 | 268 | #line 394 269 | -------------------------------------------------------------------------------- /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 = '0.91'; 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 | author 23 | version 24 | distribution_type 25 | tests 26 | installdirs 27 | }; 28 | 29 | my @tuple_keys = qw{ 30 | configure_requires 31 | build_requires 32 | requires 33 | recommends 34 | bundles 35 | resources 36 | }; 37 | 38 | my @resource_keys = qw{ 39 | homepage 40 | bugtracker 41 | repository 42 | }; 43 | 44 | my @array_keys = qw{ 45 | keywords 46 | }; 47 | 48 | sub Meta { shift } 49 | sub Meta_BooleanKeys { @boolean_keys } 50 | sub Meta_ScalarKeys { @scalar_keys } 51 | sub Meta_TupleKeys { @tuple_keys } 52 | sub Meta_ResourceKeys { @resource_keys } 53 | sub Meta_ArrayKeys { @array_keys } 54 | 55 | foreach my $key ( @boolean_keys ) { 56 | *$key = sub { 57 | my $self = shift; 58 | if ( defined wantarray and not @_ ) { 59 | return $self->{values}->{$key}; 60 | } 61 | $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); 62 | return $self; 63 | }; 64 | } 65 | 66 | foreach my $key ( @scalar_keys ) { 67 | *$key = sub { 68 | my $self = shift; 69 | return $self->{values}->{$key} if defined wantarray and !@_; 70 | $self->{values}->{$key} = shift; 71 | return $self; 72 | }; 73 | } 74 | 75 | foreach my $key ( @array_keys ) { 76 | *$key = sub { 77 | my $self = shift; 78 | return $self->{values}->{$key} if defined wantarray and !@_; 79 | $self->{values}->{$key} ||= []; 80 | push @{$self->{values}->{$key}}, @_; 81 | return $self; 82 | }; 83 | } 84 | 85 | foreach my $key ( @resource_keys ) { 86 | *$key = sub { 87 | my $self = shift; 88 | unless ( @_ ) { 89 | return () unless $self->{values}->{resources}; 90 | return map { $_->[1] } 91 | grep { $_->[0] eq $key } 92 | @{ $self->{values}->{resources} }; 93 | } 94 | return $self->{values}->{resources}->{$key} unless @_; 95 | my $uri = shift or die( 96 | "Did not provide a value to $key()" 97 | ); 98 | $self->resources( $key => $uri ); 99 | return 1; 100 | }; 101 | } 102 | 103 | foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { 104 | *$key = sub { 105 | my $self = shift; 106 | return $self->{values}->{$key} unless @_; 107 | my @added; 108 | while ( @_ ) { 109 | my $module = shift or last; 110 | my $version = shift || 0; 111 | push @added, [ $module, $version ]; 112 | } 113 | push @{ $self->{values}->{$key} }, @added; 114 | return map {@$_} @added; 115 | }; 116 | } 117 | 118 | # Resource handling 119 | my %lc_resource = map { $_ => 1 } qw{ 120 | homepage 121 | license 122 | bugtracker 123 | repository 124 | }; 125 | 126 | sub resources { 127 | my $self = shift; 128 | while ( @_ ) { 129 | my $name = shift or last; 130 | my $value = shift or next; 131 | if ( $name eq lc $name and ! $lc_resource{$name} ) { 132 | die("Unsupported reserved lowercase resource '$name'"); 133 | } 134 | $self->{values}->{resources} ||= []; 135 | push @{ $self->{values}->{resources} }, [ $name, $value ]; 136 | } 137 | $self->{values}->{resources}; 138 | } 139 | 140 | # Aliases for build_requires that will have alternative 141 | # meanings in some future version of META.yml. 142 | sub test_requires { shift->build_requires(@_) } 143 | sub install_requires { shift->build_requires(@_) } 144 | 145 | # Aliases for installdirs options 146 | sub install_as_core { $_[0]->installdirs('perl') } 147 | sub install_as_cpan { $_[0]->installdirs('site') } 148 | sub install_as_site { $_[0]->installdirs('site') } 149 | sub install_as_vendor { $_[0]->installdirs('vendor') } 150 | 151 | sub dynamic_config { 152 | my $self = shift; 153 | unless ( @_ ) { 154 | warn "You MUST provide an explicit true/false value to dynamic_config\n"; 155 | return $self; 156 | } 157 | $self->{values}->{dynamic_config} = $_[0] ? 1 : 0; 158 | return 1; 159 | } 160 | 161 | sub perl_version { 162 | my $self = shift; 163 | return $self->{values}->{perl_version} unless @_; 164 | my $version = shift or die( 165 | "Did not provide a value to perl_version()" 166 | ); 167 | 168 | # Normalize the version 169 | $version = $self->_perl_version($version); 170 | 171 | # We don't support the reall old versions 172 | unless ( $version >= 5.005 ) { 173 | die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; 174 | } 175 | 176 | $self->{values}->{perl_version} = $version; 177 | } 178 | 179 | #Stolen from M::B 180 | my %license_urls = ( 181 | perl => 'http://dev.perl.org/licenses/', 182 | apache => 'http://apache.org/licenses/LICENSE-2.0', 183 | artistic => 'http://opensource.org/licenses/artistic-license.php', 184 | artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', 185 | lgpl => 'http://opensource.org/licenses/lgpl-license.php', 186 | lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', 187 | lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', 188 | bsd => 'http://opensource.org/licenses/bsd-license.php', 189 | gpl => 'http://opensource.org/licenses/gpl-license.php', 190 | gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', 191 | gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', 192 | mit => 'http://opensource.org/licenses/mit-license.php', 193 | mozilla => 'http://opensource.org/licenses/mozilla1.1.php', 194 | open_source => undef, 195 | unrestricted => undef, 196 | restrictive => undef, 197 | unknown => undef, 198 | ); 199 | 200 | sub license { 201 | my $self = shift; 202 | return $self->{values}->{license} unless @_; 203 | my $license = shift or die( 204 | 'Did not provide a value to license()' 205 | ); 206 | $self->{values}->{license} = $license; 207 | 208 | # Automatically fill in license URLs 209 | if ( $license_urls{$license} ) { 210 | $self->resources( license => $license_urls{$license} ); 211 | } 212 | 213 | return 1; 214 | } 215 | 216 | sub all_from { 217 | my ( $self, $file ) = @_; 218 | 219 | unless ( defined($file) ) { 220 | my $name = $self->name or die( 221 | "all_from called with no args without setting name() first" 222 | ); 223 | $file = join('/', 'lib', split(/-/, $name)) . '.pm'; 224 | $file =~ s{.*/}{} unless -e $file; 225 | unless ( -e $file ) { 226 | die("all_from cannot find $file from $name"); 227 | } 228 | } 229 | unless ( -f $file ) { 230 | die("The path '$file' does not exist, or is not a file"); 231 | } 232 | 233 | # Some methods pull from POD instead of code. 234 | # If there is a matching .pod, use that instead 235 | my $pod = $file; 236 | $pod =~ s/\.pm$/.pod/i; 237 | $pod = $file unless -e $pod; 238 | 239 | # Pull the different values 240 | $self->name_from($file) unless $self->name; 241 | $self->version_from($file) unless $self->version; 242 | $self->perl_version_from($file) unless $self->perl_version; 243 | $self->author_from($pod) unless $self->author; 244 | $self->license_from($pod) unless $self->license; 245 | $self->abstract_from($pod) unless $self->abstract; 246 | 247 | return 1; 248 | } 249 | 250 | sub provides { 251 | my $self = shift; 252 | my $provides = ( $self->{values}->{provides} ||= {} ); 253 | %$provides = (%$provides, @_) if @_; 254 | return $provides; 255 | } 256 | 257 | sub auto_provides { 258 | my $self = shift; 259 | return $self unless $self->is_admin; 260 | unless (-e 'MANIFEST') { 261 | warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; 262 | return $self; 263 | } 264 | # Avoid spurious warnings as we are not checking manifest here. 265 | local $SIG{__WARN__} = sub {1}; 266 | require ExtUtils::Manifest; 267 | local *ExtUtils::Manifest::manicheck = sub { return }; 268 | 269 | require Module::Build; 270 | my $build = Module::Build->new( 271 | dist_name => $self->name, 272 | dist_version => $self->version, 273 | license => $self->license, 274 | ); 275 | $self->provides( %{ $build->find_dist_packages || {} } ); 276 | } 277 | 278 | sub feature { 279 | my $self = shift; 280 | my $name = shift; 281 | my $features = ( $self->{values}->{features} ||= [] ); 282 | my $mods; 283 | 284 | if ( @_ == 1 and ref( $_[0] ) ) { 285 | # The user used ->feature like ->features by passing in the second 286 | # argument as a reference. Accomodate for that. 287 | $mods = $_[0]; 288 | } else { 289 | $mods = \@_; 290 | } 291 | 292 | my $count = 0; 293 | push @$features, ( 294 | $name => [ 295 | map { 296 | ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ 297 | } @$mods 298 | ] 299 | ); 300 | 301 | return @$features; 302 | } 303 | 304 | sub features { 305 | my $self = shift; 306 | while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { 307 | $self->feature( $name, @$mods ); 308 | } 309 | return $self->{values}->{features} 310 | ? @{ $self->{values}->{features} } 311 | : (); 312 | } 313 | 314 | sub no_index { 315 | my $self = shift; 316 | my $type = shift; 317 | push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; 318 | return $self->{values}->{no_index}; 319 | } 320 | 321 | sub read { 322 | my $self = shift; 323 | $self->include_deps( 'YAML::Tiny', 0 ); 324 | 325 | require YAML::Tiny; 326 | my $data = YAML::Tiny::LoadFile('META.yml'); 327 | 328 | # Call methods explicitly in case user has already set some values. 329 | while ( my ( $key, $value ) = each %$data ) { 330 | next unless $self->can($key); 331 | if ( ref $value eq 'HASH' ) { 332 | while ( my ( $module, $version ) = each %$value ) { 333 | $self->can($key)->($self, $module => $version ); 334 | } 335 | } else { 336 | $self->can($key)->($self, $value); 337 | } 338 | } 339 | return $self; 340 | } 341 | 342 | sub write { 343 | my $self = shift; 344 | return $self unless $self->is_admin; 345 | $self->admin->write_meta; 346 | return $self; 347 | } 348 | 349 | sub version_from { 350 | require ExtUtils::MM_Unix; 351 | my ( $self, $file ) = @_; 352 | $self->version( ExtUtils::MM_Unix->parse_version($file) ); 353 | } 354 | 355 | sub abstract_from { 356 | require ExtUtils::MM_Unix; 357 | my ( $self, $file ) = @_; 358 | $self->abstract( 359 | bless( 360 | { DISTNAME => $self->name }, 361 | 'ExtUtils::MM_Unix' 362 | )->parse_abstract($file) 363 | ); 364 | } 365 | 366 | # Add both distribution and module name 367 | sub name_from { 368 | my ($self, $file) = @_; 369 | if ( 370 | Module::Install::_read($file) =~ m/ 371 | ^ \s* 372 | package \s* 373 | ([\w:]+) 374 | \s* ; 375 | /ixms 376 | ) { 377 | my ($name, $module_name) = ($1, $1); 378 | $name =~ s{::}{-}g; 379 | $self->name($name); 380 | unless ( $self->module_name ) { 381 | $self->module_name($module_name); 382 | } 383 | } else { 384 | die("Cannot determine name from $file\n"); 385 | } 386 | } 387 | 388 | sub perl_version_from { 389 | my $self = shift; 390 | if ( 391 | Module::Install::_read($_[0]) =~ m/ 392 | ^ 393 | (?:use|require) \s* 394 | v? 395 | ([\d_\.]+) 396 | \s* ; 397 | /ixms 398 | ) { 399 | my $perl_version = $1; 400 | $perl_version =~ s{_}{}g; 401 | $self->perl_version($perl_version); 402 | } else { 403 | warn "Cannot determine perl version info from $_[0]\n"; 404 | return; 405 | } 406 | } 407 | 408 | sub author_from { 409 | my $self = shift; 410 | my $content = Module::Install::_read($_[0]); 411 | if ($content =~ m/ 412 | =head \d \s+ (?:authors?)\b \s* 413 | ([^\n]*) 414 | | 415 | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* 416 | .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* 417 | ([^\n]*) 418 | /ixms) { 419 | my $author = $1 || $2; 420 | $author =~ s{E}{<}g; 421 | $author =~ s{E}{>}g; 422 | $self->author($author); 423 | } else { 424 | warn "Cannot determine author info from $_[0]\n"; 425 | } 426 | } 427 | 428 | sub license_from { 429 | my $self = shift; 430 | if ( 431 | Module::Install::_read($_[0]) =~ m/ 432 | ( 433 | =head \d \s+ 434 | (?:licen[cs]e|licensing|copyright|legal)\b 435 | .*? 436 | ) 437 | (=head\\d.*|=cut.*|) 438 | \z 439 | /ixms ) { 440 | my $license_text = $1; 441 | my @phrases = ( 442 | 'under the same (?:terms|license) as (?:perl|the perl programming language) itself' => 'perl', 1, 443 | 'GNU general public license' => 'gpl', 1, 444 | 'GNU public license' => 'gpl', 1, 445 | 'GNU lesser general public license' => 'lgpl', 1, 446 | 'GNU lesser public license' => 'lgpl', 1, 447 | 'GNU library general public license' => 'lgpl', 1, 448 | 'GNU library public license' => 'lgpl', 1, 449 | 'BSD license' => 'bsd', 1, 450 | 'Artistic license' => 'artistic', 1, 451 | 'GPL' => 'gpl', 1, 452 | 'LGPL' => 'lgpl', 1, 453 | 'BSD' => 'bsd', 1, 454 | 'Artistic' => 'artistic', 1, 455 | 'MIT' => 'mit', 1, 456 | 'proprietary' => 'proprietary', 0, 457 | ); 458 | while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { 459 | $pattern =~ s{\s+}{\\s+}g; 460 | if ( $license_text =~ /\b$pattern\b/i ) { 461 | $self->license($license); 462 | return 1; 463 | } 464 | } 465 | } 466 | 467 | warn "Cannot determine license info from $_[0]\n"; 468 | return 'unknown'; 469 | } 470 | 471 | sub _extract_bugtracker { 472 | my @links = $_[0] =~ m#L<(\Qhttp://rt.cpan.org/\E[^>]+)>#g; 473 | my %links; 474 | @links{@links}=(); 475 | @links=keys %links; 476 | return @links; 477 | } 478 | 479 | sub bugtracker_from { 480 | my $self = shift; 481 | my $content = Module::Install::_read($_[0]); 482 | my @links = _extract_bugtracker($content); 483 | unless ( @links ) { 484 | warn "Cannot determine bugtracker info from $_[0]\n"; 485 | return 0; 486 | } 487 | if ( @links > 1 ) { 488 | warn "Found more than on rt.cpan.org link in $_[0]\n"; 489 | return 0; 490 | } 491 | 492 | # Set the bugtracker 493 | bugtracker( $links[0] ); 494 | return 1; 495 | } 496 | 497 | sub requires_from { 498 | my $self = shift; 499 | my $content = Module::Install::_readperl($_[0]); 500 | my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; 501 | while ( @requires ) { 502 | my $module = shift @requires; 503 | my $version = shift @requires; 504 | $self->requires( $module => $version ); 505 | } 506 | } 507 | 508 | sub test_requires_from { 509 | my $self = shift; 510 | my $content = Module::Install::_readperl($_[0]); 511 | my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; 512 | while ( @requires ) { 513 | my $module = shift @requires; 514 | my $version = shift @requires; 515 | $self->test_requires( $module => $version ); 516 | } 517 | } 518 | 519 | # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to 520 | # numbers (eg, 5.006001 or 5.008009). 521 | # Also, convert double-part versions (eg, 5.8) 522 | sub _perl_version { 523 | my $v = $_[-1]; 524 | $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; 525 | $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; 526 | $v =~ s/(\.\d\d\d)000$/$1/; 527 | $v =~ s/_.+$//; 528 | if ( ref($v) ) { 529 | # Numify 530 | $v = $v + 0; 531 | } 532 | return $v; 533 | } 534 | 535 | 536 | 537 | 538 | 539 | ###################################################################### 540 | # MYMETA Support 541 | 542 | sub WriteMyMeta { 543 | die "WriteMyMeta has been deprecated"; 544 | } 545 | 546 | sub write_mymeta_yaml { 547 | my $self = shift; 548 | 549 | # We need YAML::Tiny to write the MYMETA.yml file 550 | unless ( eval { require YAML::Tiny; 1; } ) { 551 | return 1; 552 | } 553 | 554 | # Generate the data 555 | my $meta = $self->_write_mymeta_data or return 1; 556 | 557 | # Save as the MYMETA.yml file 558 | print "Writing MYMETA.yml\n"; 559 | YAML::Tiny::DumpFile('MYMETA.yml', $meta); 560 | } 561 | 562 | sub write_mymeta_json { 563 | my $self = shift; 564 | 565 | # We need JSON to write the MYMETA.json file 566 | unless ( eval { require JSON; 1; } ) { 567 | return 1; 568 | } 569 | 570 | # Generate the data 571 | my $meta = $self->_write_mymeta_data or return 1; 572 | 573 | # Save as the MYMETA.yml file 574 | print "Writing MYMETA.json\n"; 575 | Module::Install::_write( 576 | 'MYMETA.json', 577 | JSON->new->pretty(1)->canonical->encode($meta), 578 | ); 579 | } 580 | 581 | sub _write_mymeta_data { 582 | my $self = shift; 583 | 584 | # If there's no existing META.yml there is nothing we can do 585 | return undef unless -f 'META.yml'; 586 | 587 | # We need Parse::CPAN::Meta to load the file 588 | unless ( eval { require Parse::CPAN::Meta; 1; } ) { 589 | return undef; 590 | } 591 | 592 | # Merge the perl version into the dependencies 593 | my $val = $self->Meta->{values}; 594 | my $perl = delete $val->{perl_version}; 595 | if ( $perl ) { 596 | $val->{requires} ||= []; 597 | my $requires = $val->{requires}; 598 | 599 | # Canonize to three-dot version after Perl 5.6 600 | if ( $perl >= 5.006 ) { 601 | $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e 602 | } 603 | unshift @$requires, [ perl => $perl ]; 604 | } 605 | 606 | # Load the advisory META.yml file 607 | my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); 608 | my $meta = $yaml[0]; 609 | 610 | # Overwrite the non-configure dependency hashs 611 | delete $meta->{requires}; 612 | delete $meta->{build_requires}; 613 | delete $meta->{recommends}; 614 | if ( exists $val->{requires} ) { 615 | $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; 616 | } 617 | if ( exists $val->{build_requires} ) { 618 | $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; 619 | } 620 | 621 | return $meta; 622 | } 623 | 624 | 1; 625 | -------------------------------------------------------------------------------- /inc/Module/Install/Share.pm: -------------------------------------------------------------------------------- 1 | #line 1 2 | package Module::Install::Share; 3 | 4 | use strict; 5 | use Module::Install::Base (); 6 | 7 | use vars qw{$VERSION @ISA $ISCORE}; 8 | BEGIN { 9 | $VERSION = '0.91'; 10 | @ISA = 'Module::Install::Base'; 11 | $ISCORE = 1; 12 | } 13 | 14 | sub install_share { 15 | my $self = shift; 16 | my $dir = @_ ? pop : 'share'; 17 | my $type = @_ ? shift : 'dist'; 18 | unless ( defined $type and $type eq 'module' or $type eq 'dist' ) { 19 | die "Illegal or invalid share dir type '$type'"; 20 | } 21 | unless ( defined $dir and -d $dir ) { 22 | die "Illegal or missing directory install_share param"; 23 | } 24 | 25 | # Split by type 26 | my $S = ($^O eq 'MSWin32') ? "\\" : "\/"; 27 | if ( $type eq 'dist' ) { 28 | die "Too many parameters to install_share" if @_; 29 | 30 | # Set up the install 31 | $self->postamble(<<"END_MAKEFILE"); 32 | config :: 33 | \t\$(NOECHO) \$(MOD_INSTALL) \\ 34 | \t\t"$dir" \$(INST_LIB)${S}auto${S}share${S}dist${S}\$(DISTNAME) 35 | 36 | END_MAKEFILE 37 | } else { 38 | my $module = Module::Install::_CLASS($_[0]); 39 | unless ( defined $module ) { 40 | die "Missing or invalid module name '$_[0]'"; 41 | } 42 | $module =~ s/::/-/g; 43 | 44 | # Set up the install 45 | $self->postamble(<<"END_MAKEFILE"); 46 | config :: 47 | \t\$(NOECHO) \$(MOD_INSTALL) \\ 48 | \t\t"$dir" \$(INST_LIB)${S}auto${S}share${S}module${S}$module 49 | 50 | END_MAKEFILE 51 | } 52 | 53 | # The above appears to behave incorrectly when used with old versions 54 | # of ExtUtils::Install (known-bad on RHEL 3, with 5.8.0) 55 | # So when we need to install a share directory, make sure we add a 56 | # dependency on a moderately new version of ExtUtils::MakeMaker. 57 | $self->build_requires( 'ExtUtils::MakeMaker' => '6.11' ); 58 | 59 | # 99% of the time we don't want to index a shared dir 60 | $self->no_index( directory => $dir ); 61 | } 62 | 63 | 1; 64 | 65 | __END__ 66 | 67 | #line 125 68 | -------------------------------------------------------------------------------- /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 = '0.91'; 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 = '0.91';; 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 | $self->makemaker_args( PL_FILES => {} ); 30 | } 31 | 32 | # Until ExtUtils::MakeMaker support MYMETA.yml, make sure 33 | # we clean it up properly ourself. 34 | $self->realclean_files('MYMETA.yml'); 35 | 36 | if ( $args{inline} ) { 37 | $self->Inline->write; 38 | } else { 39 | $self->Makefile->write; 40 | } 41 | 42 | # The Makefile write process adds a couple of dependencies, 43 | # so write the META.yml files after the Makefile. 44 | if ( $args{meta} ) { 45 | $self->Meta->write; 46 | } 47 | 48 | # Experimental support for MYMETA 49 | if ( $ENV{X_MYMETA} ) { 50 | if ( $ENV{X_MYMETA} eq 'JSON' ) { 51 | $self->Meta->write_mymeta_json; 52 | } else { 53 | $self->Meta->write_mymeta_yaml; 54 | } 55 | } 56 | 57 | return 1; 58 | } 59 | 60 | 1; 61 | -------------------------------------------------------------------------------- /install.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | sudo make install 4 | -------------------------------------------------------------------------------- /lib/App/Cope.pm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | package App::Cope; 3 | use strict; 4 | use warnings; 5 | use 5.010_000; 6 | use Carp; 7 | 8 | no warnings 'experimental'; 9 | 10 | our $VERSION = '0.99'; 11 | 12 | =head1 NAME 13 | 14 | App::Cope - Functions for the B program 15 | 16 | =head1 SYNOPSIS 17 | 18 | B This file contains functions for L, and documentation 19 | on its internals. If you want to learn how to use or install cope 20 | itself, see L instead. 21 | 22 | =cut 23 | 24 | use App::Cope::Pty; 25 | 26 | use IO::Handle; 27 | use Term::ANSIColor; 28 | use List::MoreUtils qw[each_array firstidx]; 29 | use Env::Path qw[:all]; 30 | use File::Spec; 31 | 32 | use base q[Exporter]; 33 | our @EXPORT = qw[run mark line real_path]; 34 | our @EXPORT_OK = qw[run_with get colourise]; 35 | 36 | sub import { 37 | # Automatically use strictures and warnings and Perl 5.10 features, 38 | # so those three lines don't have to be typed for every script 39 | strict->import; 40 | warnings->import; 41 | feature->import( ':5.10' ); 42 | 43 | # Let Exporter do the rest 44 | App::Cope->export_to_level( 1, @_ ); 45 | } 46 | 47 | =head1 HIGHLIGHTING 48 | 49 | Rather embarrassingly, the technique for highlighting parts of a 50 | string is used by modifying global variables. The process works 51 | something like this: 52 | 53 | 1) cope gets a string from a program's output. 54 | 55 | 2) The L and L functions match against the string, 56 | now in C<$_>, and modify the hash C<%colours> at the start and end 57 | positions of the match with ANSI control codes to turn the colours 58 | on and off. 59 | 60 | 3) The string is colourised, and the control-code-laden string is 61 | printed as output. 62 | 63 | Previously, the two functions modified C<$_> throughout, but then it 64 | was impossible to match against an already-coloured part of the 65 | string, as the control codes would get in the way. 66 | 67 | =head2 Buffering 68 | 69 | The programs run are line-buffered by default - that is, cope waits 70 | for it to output a newline before it starts processing the 71 | string. This is so scripts can't receive half a line and accidentally 72 | treat it as a whole one, instead of matching after all the line has 73 | been received. 74 | 75 | If your program regularly updates without a newline, you can turn this 76 | behaviour off: 77 | 78 | $App::Cope::line_buffered = 0; # or on again with 1 79 | 80 | The side-effect of doing this is that you can no longer rely on 81 | substrings to be processed in the same string, even if they appear 82 | next to each other in the final output. In general, if there is a 83 | pause between successive prints, the two will be treated as different 84 | outputs. 85 | 86 | =head1 MAIN FUNCTIONS 87 | 88 | =head2 run( \&process, @args ) 89 | 90 | The main entry point for scripts to use - checks C<$NOCOPE> and the 91 | resulting terminal, and then passes control to L. 92 | 93 | =cut 94 | 95 | # Information about the path that is used quite often 96 | my ( $vol, $dir, $file ) = File::Spec->splitpath($0); 97 | my $script_path = File::Spec->catpath( $vol, $dir ); 98 | $script_path =~ s{/$}{}; 99 | 100 | sub run { 101 | my ( $process, @args ) = @_; 102 | croak "No arguments" unless @args; 103 | 104 | # Remove ourselves from the $PATH, so other scripts that recurse 105 | # like this don't go into an infinite loop 106 | PATH->Remove( $script_path ); 107 | 108 | # Don't run if told not to, and always run if forced to 109 | if ( $ENV{NOCOPE} or ( not $ENV{COPE} and not POSIX::isatty STDOUT ) ) { 110 | exec @args; 111 | } 112 | else { 113 | my $ret_val = run_with( $process, @args ); 114 | exit $ret_val; 115 | } 116 | } 117 | 118 | =head2 run_with( \&process, @args ) 119 | 120 | The main body of the program, when being run by scripts. It takes a 121 | sub that modifies each line of input, and a list of arguments to pass 122 | to exec to run the program. The first of the args, the program name, 123 | should be absolute. 124 | 125 | =cut 126 | 127 | our %colours; # the variable to modify 128 | our $line_buffered = 1; # keep a buffer of half-lines 129 | our $color_stack = 0; # When applying colors, use a stack 130 | 131 | sub run_with { 132 | my ( $process, @args ) = @_; 133 | 134 | # Initialise handle 135 | my $fh = new IO::Handle or croak "Failed handle: $!"; 136 | $fh->fdopen( fileno STDIN, 'r' ); 137 | $fh->autoflush; 138 | 139 | # Initialise pseudo-terminal 140 | my $pty = App::Cope::Pty->new; 141 | $pty->spawn( @args ); 142 | 143 | # Let any signals be automatically passed to the child process 144 | my @signals = qw[INT QUIT TERM]; 145 | my $dying_early = 0; 146 | for my $sig (@signals) { 147 | $SIG{$sig} = sub { 148 | $dying_early++; 149 | kill $sig => -$pty->{pid}; # kill the entire process group 150 | }; 151 | } 152 | 153 | # No suffering from buffering 154 | local $| = 1; 155 | 156 | # Main loop: continues as long as there's input to receive 157 | receive: 158 | my $buf = ''; 159 | while ( defined ( my $rout = $pty->read ) ) { 160 | my @bits = split /(\r|\n)/, "$buf$rout"; 161 | if ( ( $line_buffered || $pty->more_to_read ) and $bits[-1] !~ /\r|\n/ ) { 162 | $buf = pop @bits; 163 | } 164 | else { 165 | $buf = ''; 166 | } 167 | print colourise( $process, $_ ) for @bits; 168 | } 169 | 170 | if ($dying_early) { 171 | # The call to $pty->read was terminated by a signal! Try to read 172 | # any more output, in case there's any left to read. 173 | $dying_early = 0; 174 | goto receive; 175 | } 176 | 177 | $fh->close or carp "Failed close: $!"; 178 | $pty->close or carp "Failed close: $!"; 179 | 180 | waitpid($pty->{pid}, 0); 181 | return ($? >> 8); 182 | } 183 | 184 | =head2 mark( $regex, $colour ) 185 | 186 | The simpler of the highlighting functions; C takes a regex, and 187 | one colour, and highlights the first part of the string matched in the 188 | given colour. 189 | 190 | mark qr{open} => 'green bold'; 191 | 192 | =cut 193 | 194 | sub mark { 195 | my ( $regex, $colour ) = @_; 196 | if ( m/$regex/p ) { 197 | colour( $-[0], $+[0] => get( $colour, substr $_, $-[0], $+[0] - $-[0] ) ); 198 | return 1; 199 | } 200 | return 0; 201 | } 202 | 203 | =head2 line( $regex, @colours ) 204 | 205 | The more complicated function; C takes a regex, containing 206 | parenthesised captures, and highlights each match with the relevant 207 | colour in the array. 208 | 209 | line qr{^(\d+){/\w+)} => 'cyan bold', 'blue'; 210 | 211 | =cut 212 | 213 | sub line { 214 | my $regex = shift; 215 | 216 | my $offset = 0; 217 | while ( m/$regex/g ) { 218 | 219 | # skip 0th entries - they just contain info about the entire match 220 | my @starts = @-[ 1 .. $#- ]; 221 | my @ends = @+[ 1 .. $#+ ]; 222 | my @colours = @_; 223 | 224 | my $ea = each_array( @starts, @ends, @colours ); 225 | while ( my ( $start, $end, $colour ) = $ea->() ) { 226 | 227 | # either $start or $end being undef means that there was nothing to 228 | # match, e.g. /(?: (\S+) )?/x where the match fails. 229 | if ( defined $start and defined $end ) { 230 | my $before = substr $_, $start, $end - $start; 231 | my $c = get( $colour, $before ); 232 | colour( $start, $end => $c ); 233 | } 234 | } 235 | 236 | $offset += $+[0]; # mark everything up to here as done 237 | } 238 | 239 | return $offset; # still false if nothing's changed 240 | } 241 | 242 | =head1 HELPER FUNCTIONS 243 | 244 | =head2 get( $colour, $str ); 245 | 246 | Returns a colour based on how a reference - an array, a hash, some 247 | code, or just a scalar string - reacts to the text matched by a 248 | regex. Used by C and C. 249 | 250 | # simple scalar usage 251 | line qr/^Count: (\d+)/ => 'green'; 252 | 253 | # passing a subroutine 254 | line qr/^Errors: (\d+)/ => sub { 255 | return 'red' if shift > 0; 256 | } 257 | 258 | # passing a hashref 259 | my %protocols = ( 260 | 'tcp' => 'magenta', 261 | 'udp' => 'red', 262 | 'raw' => 'red bold', 263 | '_else' => 'red', 264 | ); 265 | line qr/^\d+/(\w+)/ => \%protocols; 266 | 267 | =cut 268 | 269 | sub get { 270 | my ( $colour, $str ) = @_; 271 | if (ref($colour) eq 'ARRAY') { 272 | return get( shift @{$colour}, $str ) || ''; 273 | } elsif (ref($colour) eq 'HASH') { 274 | return get( $colour->{$str}, $str ) || get( $colour->{_else} ) || ''; 275 | } elsif (ref($colour) eq 'CODE') { 276 | return get( &$colour($str), $str ) || ''; 277 | } 278 | return $colour; 279 | } 280 | 281 | =head2 colour( $begin, $end, $colour ) 282 | 283 | B the hash C<%colours>, in order to highlight the region 284 | from C<$begin> to C<$end> in $colour. 285 | 286 | =cut 287 | 288 | sub colour { 289 | my ( $begin, $end, $colour ) = @_; 290 | return if !$colour; 291 | if ($color_stack) { 292 | push @{ $colours{$begin}->{push} }, $colour; 293 | push @{ $colours{$end}->{pop} }, $colour; 294 | } else { 295 | $colours{$begin} = $colour; 296 | $colours{$end} = ''; 297 | } 298 | } 299 | 300 | =head2 colourise 301 | 302 | Uses the values in the hash C<%colours> to transform the string in 303 | C<$_> to a colourised version of itself. This string is eventually 304 | printed to stdout. 305 | 306 | =cut 307 | 308 | my $last = ''; 309 | 310 | sub colourise { 311 | ( my $process, local $_ ) = @_; 312 | return $_ if $_ eq "\n"; 313 | 314 | %colours = (); 315 | &$process; 316 | 317 | if ($color_stack) { 318 | # This will break with overlapping regions 319 | my @parts = sort { $a <=> $b } keys %colours; 320 | 321 | if (@parts) { 322 | my @current_colors = (); 323 | my $reset = color("reset"); 324 | my @string = (); 325 | push @string, substr($_, 0, $parts[0]) if $parts[0]; 326 | 327 | # Build up the colorized string 328 | for my $p (0 .. $#parts) { 329 | my $i = $parts[$p]; 330 | while ( $colours{$i}->{pop} and @{$colours{$i}->{pop}} ) { 331 | my $col = shift @{$colours{$i}->{pop}}; 332 | my $c = 0; 333 | for my $c (0 .. $#current_colors) { 334 | if ($col eq $current_colors[$c]) { 335 | splice(@current_colors, $c, 1); 336 | last; 337 | } 338 | } 339 | } 340 | unshift @current_colors, reverse @{$colours{$i}->{push}} if $colours{$i}->{push}; 341 | 342 | my $end = ($p == $#parts ? length($_) : $parts[$p+1]); 343 | if ($end > $i) { 344 | my $col = ($current_colors[0] || ""); 345 | if ($col) { 346 | push @string, color($col); 347 | } 348 | push @string, substr($_, $i, $end - $i); 349 | if ($col) { 350 | push @string, $reset; 351 | } 352 | } 353 | } 354 | $_ = join("", @string); 355 | } 356 | } else { 357 | my @parts = sort { $b <=> $a } keys %colours; 358 | 359 | # Any colour that's /on_/ or /bold/ needs to be reset afterwards, so 360 | # the colours/boldness return to normal values. 361 | 362 | for my $i ( 0 .. $#parts ) { 363 | my ( $last, $part ) = @colours{ @parts[ $i - 1, $i ] }; 364 | carp "Uninitialised value in colourise (try adding more arguments)" 365 | and next unless defined $part; 366 | 367 | if ( $i and ($part =~ m/bold/ and $last !~ m/bold/) 368 | or ($part =~ m/on_/ and $last !~ m/_on/ ) ) { 369 | $colours{ $parts[ $i - 1 ] } = "clear $last"; 370 | } 371 | } 372 | 373 | # Actually apply the changes and update the string (backwards, as to 374 | # not overwrite previous changes) 375 | 376 | for my $i ( @parts ) { 377 | substr $_, $i, 0, color( $colours{$i} || 'reset' ); 378 | } 379 | } 380 | 381 | %colours = (); # just making sure 382 | return $_; 383 | } 384 | 385 | =head2 real_path 386 | 387 | Returns the path to the original program that should be run - that is, 388 | the one not in the scripts directory. 389 | 390 | =cut 391 | 392 | sub real_path { 393 | my @dirs = PATH->Whence($file); 394 | my $index = firstidx { $_ eq $0 } @dirs; 395 | my $path = $dirs[ $index + 1 ] 396 | or croak "Executable not in \$PATH: $file"; 397 | 398 | return $path; 399 | } 400 | 401 | 1; 402 | 403 | __END__ 404 | 405 | =head1 AUTHOR 406 | 407 | Benjamin Sago aka `cytzol' C<< >> 408 | 409 | =head1 COPYRIGHT & LICENSE 410 | 411 | Copyright 2009 Benjamin Sago. 412 | 413 | This program is free software; you can redistribute it and/or modify 414 | it under the same terms as Perl itself. 415 | 416 | =cut 417 | 418 | # Local Variables: 419 | # mode: cperl 420 | # cperl-indent-level: 2 421 | # fill-column: 70; 422 | # indent-tabs-mode: nil 423 | # End: 424 | # vi: set ts=2 sts=2 sw=2 tw=70 et 425 | -------------------------------------------------------------------------------- /lib/App/Cope/Extra.pm: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | package App::Cope::Extra; 3 | use strict; 4 | use warnings; 5 | use 5.010_000; 6 | 7 | no warnings 'experimental'; 8 | 9 | =head1 NAME 10 | 11 | App::Cope::Extra - Pre-defined highlighting syntax for common patterns 12 | 13 | =head2 SYNOPSIS 14 | 15 | use App::Cope::Extra; 16 | 17 | line qr{User: (\S+)} => \&{ user 'yellow' }; 18 | line qr{([0-9.]+ ms)} => \&ping_time; 19 | 20 | =head2 DESCRIPTION 21 | 22 | App::Cope::Extra contains several common patterns to save you from 23 | incessantly defining them. Functions that take a colour parameter 24 | return functions, so you can use them using the consistant C<\&> 25 | syntax. 26 | 27 | No functions are exported by default. 28 | 29 | =cut 30 | 31 | use base q[Exporter]; 32 | our @EXPORT_OK = qw[ %permissions %filetypes 33 | user nonzero ping_time 34 | percent percent_b ]; 35 | 36 | =head1 VARIABLES 37 | 38 | =head2 %permissions 39 | 40 | Describes the single-character UNIX permissions; 41 | 42 | =cut 43 | 44 | our %permissions = ( 45 | 'r' => 'yellow bold', 46 | 'w' => 'red bold', 47 | 'x' => 'green bold', 48 | '-' => 'black bold', 49 | 's' => 'magenta bold', 50 | 'S' => 'magenta', 51 | 't' => 'green', 52 | 'T' => 'green bold', 53 | ); 54 | 55 | =head2 %filetypes 56 | 57 | Describes the single-character file type descriptions. 58 | 59 | =cut 60 | 61 | our %filetypes = ( 62 | 'b' => 'magenta bold', # block special 63 | 'c' => 'magenta bold', # character special 64 | 'C' => 'red bold', # contiguous data 65 | 'd' => 'blue bold', # directory 66 | 'D' => 'red bold', # door 67 | 'l' => 'cyan bold', # symlink 68 | 'M' => 'red bold', # offline file 69 | 'n' => 'red bold', # network special 70 | 'p' => 'yellow bold', # named pipe 71 | 'P' => 'red bold', # port 72 | 's' => 'yellow bold', # socket 73 | ); 74 | 75 | =head1 FUNCTIONS 76 | 77 | =head2 nonzero( $colour ) 78 | 79 | If the number given is not equal to zero, return the colour 80 | bold. Else, return it plain. 81 | 82 | =cut 83 | 84 | sub nonzero { 85 | my $colour = shift; 86 | return sub { 87 | my $val = shift; 88 | ( $val !~ /^0+(\.0+)?$/ ) ? "$colour bold" : "$colour"; 89 | }; 90 | } 91 | 92 | =head2 user( $colour ) 93 | 94 | If the string is equal to the current user name or ID, return the 95 | colour in bold. Else, return it plain. 96 | 97 | =cut 98 | 99 | my $me = (getpwuid( $< ))[0] || "nobody"; 100 | 101 | sub user { 102 | my $colour = shift || 'yellow'; 103 | return sub { 104 | my $uid = shift; 105 | ( $uid eq $me || $uid eq $< ) ? "$colour bold" : "$colour"; 106 | }; 107 | } 108 | 109 | =head2 percent( $lower, $middle, $upper ) 110 | 111 | Returns a colour based on the percentage, going from red, to yellow, 112 | to green, to bold. Low values are made red. 113 | 114 | =cut 115 | 116 | sub percent { 117 | my ( $lower, $middle, $upper ) = @_; 118 | return sub { 119 | my $pct = shift; 120 | $pct =~ s/^(\d+).+/$1/; # extract number 121 | if ( $pct >= $upper ) { return 'bold' } 122 | elsif ( $pct >= $middle ) { return 'green bold' } 123 | elsif ( $pct >= $lower ) { return 'yellow bold' } 124 | else { return 'red bold' } 125 | }; 126 | } 127 | 128 | =head2 percent_b( $lower, $middle, $upper ) 129 | 130 | Returns a colour based on the percentage, going from bold, to green, 131 | to yellow, to red. High values are made red. 132 | 133 | =cut 134 | 135 | sub percent_b { 136 | my ( $lower, $middle, $upper ) = @_; 137 | return sub { 138 | my $pct = shift; 139 | $pct =~ s/^(\d+).+/$1/; # extract number 140 | given ($pct) { 141 | when ( $_ >= $upper ) { return 'red bold' } 142 | when ( $_ >= $middle ) { return 'yellow bold' } 143 | when ( $_ >= $lower ) { return 'green bold' } 144 | default { return 'bold' } 145 | } 146 | }; 147 | } 148 | 149 | =head2 ping_time 150 | 151 | Takes a ping time in milliseconds, and returns green/yellow/red 152 | depending on how long the ping took. 153 | 154 | =cut 155 | 156 | sub ping_time { 157 | my ($ms) = @_; 158 | if ($ms =~ m/(\d+)/) { 159 | given ($1) { 160 | when ( $_ >= 200 ) { return 'red bold' } 161 | when ( $_ >= 100 ) { return 'yellow bold' } 162 | default { return 'green bold' } 163 | } 164 | } 165 | return ''; 166 | } 167 | 168 | -------------------------------------------------------------------------------- /lib/App/Cope/Manual.pod: -------------------------------------------------------------------------------- 1 | =head1 NAME 2 | 3 | App::Cope::Manual - User guide for cope 4 | 5 | =head1 DESCRIPTION 6 | 7 | B is a wrapper around programs that output to a terminal, to 8 | give them colour for utility and aesthetics while still keeping them 9 | the same at the text level. 10 | 11 | Adding colours on top of text makes it easy to see when something's 12 | amiss. For utility, you can stop hunting through your terminal's 13 | scroll buffer to locate an error when it's clearly highlighted in red, 14 | or locating a network address hidden in dense output when they're marked 15 | in yellow and blue (local and foreign, respectively). As for 16 | aesthetics, even the simplest utility can be brightened up by adding a 17 | dash of colour on top. 18 | 19 | cope's scripts are written in Perl, so they're as flexible (and fast) 20 | as Perl allows. See L for more on that. 21 | 22 | =head1 INSTALL 23 | 24 | cope is not currently on the CPAN, so installation is the standard 25 | 4-command Perl install procedure: 26 | 27 | - perl Makefile.PL 28 | 29 | - make 30 | 31 | - make test 32 | 33 | - make install 34 | 35 | There's a standard Perl location for putting extra files. You'll have 36 | to ask Perl to tell you where it is, though: 37 | 38 | $ perl -MFile::ShareDir=dist_dir -e "print dist_dir('Cope').\$/" 39 | 40 | Now all you need to do is add that directory to your C<$PATH>: 41 | 42 | OLDPATH=$PATH 43 | export PATH="/path/to/scripts/:$PATH" 44 | 45 | And the programs in the scripts directory will automatically colourise 46 | their counterparts. 47 | 48 | =head1 RUNNING 49 | 50 | Instead of filtering input through a single executable, cope provides 51 | a directory of scripts that examine the $PATH variable, run the 52 | original script, and process its output through a filter defined in 53 | that file. 54 | 55 | This has many benefits: it requires no configuration other than 56 | changing the $PATH, automatically highlights output from processes 57 | spawned by processes, and most shells won't know the difference in 58 | terms of tab-completion on arguments. 59 | 60 | =head1 LIMITATIONS 61 | 62 | Although cope uses a pseudo-terminal to read its input, it doesn't 63 | pretend to act like one. Applications that require a terminal to be 64 | emulated - think editors, pagers, roguelikes - will fail miserably. If 65 | you want to interact with one of them, write your own script using 66 | L to parse the output. 67 | 68 | =head1 TURNING FILTERING ON/OFF 69 | 70 | To avoid clashes with other pipes, cope does not filter if its output 71 | isn't going to a terminal. 72 | 73 | The script L runs a program without filtering it through cope, 74 | by removing the scripts directory from the C. 75 | 76 | Also, the environment variable C<$NOCOPE> is handled by all the scripts 77 | as to run the program without the filter. 78 | 79 | =head1 SUPPORT 80 | 81 | There is no "stable" version. cope is a relatively small program, and 82 | the majority of changes are going to be for different scripts, rather 83 | than changes to the main code, which is bound to be working more or 84 | less correctly. 85 | 86 | Support and information about cope can be found at: 87 | 88 | =over 4 89 | 90 | =item * cope's homepage 91 | 92 | L 93 | 94 | =item * cope's git repo 95 | 96 | L 97 | 98 | =back 99 | 100 | Please report anything wrong at all: either a bug within cope, or if 101 | something gets highlighted incorrectly, or even fails to be 102 | highlighted at all. 103 | 104 | =head1 AUTHOR 105 | 106 | Benjamin Sago aka `cytzol' C<< >> 107 | 108 | =head1 COPYRIGHT & LICENCE 109 | 110 | Copyright 2009 Benjamin Sago. 111 | 112 | This program is free software; you can redistribute it and/or modify 113 | it under the same terms as Perl itself. 114 | 115 | =cut 116 | 117 | -------------------------------------------------------------------------------- /lib/App/Cope/Pty.pm: -------------------------------------------------------------------------------- 1 | package App::Cope::Pty; 2 | use strict; 3 | use warnings; 4 | 5 | =head1 NAME 6 | 7 | App::Cope::Pty - Pseudo-tty functions for B. 8 | 9 | =head1 DESCRIPTION 10 | 11 | B This is part of L, and doesn't make much of an effort 12 | to fit in anywhere else. If you want a nice pty library, use 13 | L or L. 14 | 15 | cope uses a pseudo-tty for reading in from a process. This is favoured 16 | above pipes, because ptys allow for non-buffered input, instead of 17 | waiting for the program to complete before getting any output from it. 18 | 19 | =cut 20 | 21 | use Carp; 22 | use IO::Pty; 23 | 24 | =head1 METHODS 25 | 26 | =head2 new() 27 | 28 | The constructor initialises and returns the pty, and croaks if it 29 | fails. 30 | 31 | C should be called sometime after this, to run a program. 32 | 33 | =cut 34 | 35 | sub new { 36 | my $class = shift; 37 | my $self; 38 | $self->{pty} = new IO::Pty or croak "Failed pty: $!"; 39 | bless $self, $class; 40 | return $self; 41 | } 42 | 43 | =head2 spawn( @args ) 44 | 45 | Forks a new process with C, with C, C and 46 | C reopened to the pty. Croaks or carps if anything goes wrong 47 | (Failed piping or reopening). 48 | 49 | Leaves the child in the C call and returns nothing important. 50 | 51 | =cut 52 | 53 | sub spawn { 54 | my ( $self, @args ) = @_; 55 | 56 | # set up the pipe from which to read 57 | pipe( my $readp, my $writep ) or croak "Failed pipe: $!"; 58 | $writep->autoflush; 59 | 60 | # the program runs independently in a child process so we can get 61 | # its output without interfering with it 62 | $self->{pid} = fork; 63 | croak "Fork failed: $!" unless defined $self->{pid}; 64 | 65 | if ( $self->{pid} == 0 ) { # we are the child 66 | close $readp or carp "Failed close: $!"; 67 | $self->{pty}->make_slave_controlling_terminal; 68 | close $self->{pty}; 69 | 70 | # disassociate from the terminal 71 | POSIX::setsid or carp "Failed setsid: $!"; 72 | my $tty = $self->{pty}->slave; 73 | $tty->clone_winsize_from( \*STDIN ) if POSIX::isatty STDIN; 74 | 75 | # set stdin to raw, so keypresses get passed straight through 76 | IO::Stty::stty( $tty, 'raw', '-echo' ); 77 | 78 | # associate with a new terminal 79 | my $fileno = $tty->fileno; 80 | my $name = $tty->ttyname; 81 | croak "Failed ttyname: $!" unless defined $name; 82 | 83 | # make the standard file descriptors point to our pty rather than the 84 | # terminal we're printing to 85 | 86 | close STDIN; 87 | open STDIN, '<&', $fileno 88 | or croak "Couldn't reopen stdin for reading to $name: $!"; 89 | 90 | close STDOUT; 91 | open STDOUT, '>&', $fileno 92 | or croak "Couldn't reopen stdout for reading to $name: $!"; 93 | 94 | close STDERR; 95 | open STDERR, '>&', $fileno 96 | or croak "Couldn't reopen stderr for reading to $name: $!"; 97 | 98 | close $tty; 99 | 100 | # run the process (exec should never return) 101 | { exec(@args); }; 102 | print { $writep } $! + 0 or carp "Failed print: $!"; 103 | croak "Cannot exec: $!"; 104 | } 105 | 106 | else { # we are the parent 107 | #close STDIN; 108 | close $writep or carp "Failed close: $!"; 109 | $self->{pty}->close_slave; 110 | $self->{pty}->set_raw; 111 | 112 | # and don't do anything else! 113 | } 114 | } 115 | 116 | =head2 read() 117 | 118 | Returns up to 4096 bytes' worth of read data from the process that's 119 | running on the pty. If there's any data left over, it will be read 120 | during the next cycle. 121 | 122 | =cut 123 | 124 | sub read { 125 | my $self = shift; 126 | 127 | my $nchars = sysread( $self->{pty}, my $buf, 4096 ); 128 | return undef if defined $nchars and $nchars == 0; # eof 129 | return undef if $buf eq ''; # nothing to read 130 | 131 | return $buf; 132 | } 133 | 134 | =head2 more_to_read 135 | 136 | Runs a C