1# $Id: Text.pm,v 1.56 2012/03/04 13:56:35 pfeiffer Exp $ 2 3=head1 NAME 4 5Mpp::Text - Subs for manipulating typical makefile text 6 7=cut 8 9package Mpp::Text; 10require Exporter; 11@ISA = qw(Exporter); 12 13@EXPORT = qw(index_ignoring_quotes max_index_ignoring_quotes 14 split_on_whitespace join_with_protection split_on_colon 15 split_commands unquote unquote_split_on_whitespace 16 requote format_exec_args whitespace_len hash_neq 17 is_cpp_source_name is_object_or_library_name); 18 19use Config; 20 21# Centrally provide constants which are needed repeatedly for aliasing, since 22# Perl implements them as subs, and each sub takes about 1.5kb RAM. 23BEGIN { 24 our @N = map eval( "sub(){$_}" ), 0..6; # More are defined in Mpp/BuildCacheControl.pm 25 *Mpp::is_perl_5_6 = $N[$] < 5.008 ? 1 : 0]; 26 *Mpp::is_windows = 27 $^O eq 'cygwin' ? sub() { -1 } : # Negative for Unix like 28 $^O eq 'msys' ? sub() { -2 } : # MinGW with sh & coreutils 29 $N[$^O =~ /^MSWin/ ? (exists $ENV{SHELL} && $ENV{SHELL} =~ /sh(?:\.exe)?$/i ? 1 : 2) : 0]; 30 31 my $perl = $ENV{PERL}; 32 if( $perl && -x $perl ) { # Overridden successfully. 33 } elsif( -x $^X ) { # Use same as ourself. 34 $^X =~ tr/\\/\// if Mpp::is_windows() > 0; 35 $perl = (Mpp::is_windows() ? $^X =~ /^(?:\w:)?\// : $^X =~ /^\//) ? 36 $^X : 37 eval "use Cwd; cwd . '/$^X'"; 38 } else { # Emergency fallback. 39 $perl = $Config{perlpath}; # Prefer appended version number for precision. 40 my $version = sprintf '%vd', $^V; 41 $perl .= $version if -x "$perl$version"; 42 } 43 eval "sub Mpp::PERL() { '$perl' }"; 44} 45 46# 47# This module contains a few subroutines for manipulating text, mostly for 48# dealing with quoted strings and make expressions. 49# 50 51=head2 pattern_substitution 52 53 @pieces = pattern_substitution($pattern, $dest, @words) 54 55Performs a pattern substitution like the C<$(patsubst )> function (in fact, 56C<$(patsubst )> is implemented using this. $pattern contains a C<%> as a 57wildcard, and $dest contains a matching C<%>. The substitution is applied to 58each word in @words, and the result returned as an array. 59 60For example: 61 62 @pieces = pattern_substitution('%.c', '%.o', 'file1.c', 'file2.c') 63 64returns ('file1.o', 'file2.o'). 65 66=cut 67 68our $set_stem; 69sub pattern_substitution { 70 my ($src, $dest, @words) = @_; # Name the arguments. 71 my $percent_pos = index $src, '%'; # Find the percent char. 72 $percent_pos < 0 and 73 die "\$(patsubst ...) called with '$src' as first argument\n"; 74 75 chop( my $src_prefix = substr $src, 0, $percent_pos+1, '' ); 76 77 for my $word (@words) { 78 my $len_diff = length( $word ) - length $src; 79 if( $len_diff >= $percent_pos && # Make sure prefix & suffix don't overlap. 80 substr( $word, 0, $percent_pos ) eq $src_prefix && 81 substr( $word, $len_diff ) eq $src ) { 82 my $pattern_stem = substr $word, $percent_pos, $len_diff - $percent_pos; 83 ($word = $dest) =~ s/%/$pattern_stem/g; 84 # Replace all occurrences of % with the stem. 85 # Save the resulting word(s). TODO: this is a 86 # hack for multitarget rules, allow multiple %-pairs. 87 $Mpp::Subs::rule->{PATTERN_STEM} ||= $pattern_stem 88 if defined $set_stem; # Set it up so $* can return the stem. 89 } 90 } 91 92 @words; 93} 94 95# Rather than cascade if( /\Gx/gc ), just look up the action 96our %skip_over = ( 97 "'", \&skip_over_squote, 98 '"', \&skip_over_dquote, 99 '$', \&skip_over_make_expression, 100 '\\', sub { ++pos }); 101 102=head2 index_ignoring_quotes 103 104 my $index = index_ignoring_quotes($string, 'substr'[, position]); 105 106Works like C<index($string, 'substr'[, position])>, except that the substring may not be 107inside quotes or a make expression. 108 109=head2 index_ignoring_single_quotes 110 111This is similar, but ignores only the characters in '' and the one after \. 112 113=cut 114 115sub index_ignoring_quotes { 116 my $substr = $_[1]; 117 local $_ = $_[0]; 118 pos = $_[2] || 0; # Start at the beginning. 119 120 for (;;) { 121 my $last_pos = pos; 122 if( /\G([^"'\\\$]+)/gc ) { # Just ordinary characters? 123 my $idx = index $1, $substr; # See if it's in those characters. 124 $idx >= 0 and return $last_pos + $idx; 125 } 126 127 return -1 if length() <= pos; # End of string? That means no match. 128 # For reasons that I don't understand, testing 129 # for /\G\z/gc doesn't work here. 130 131 # It's one of the standard cases ", ', \ or $. 132 &{$skip_over{substr $_, pos()++, 1}}; 133 } 134} 135sub index_ignoring_single_quotes { 136 local $skip_over{'"'} = local $skip_over{'$'} = $N[0]; 137 &index_ignoring_quotes; 138} 139 140=head2 max_index_ignoring_quotes 141 142Like C<index_ignoring_quotes>, except that it returns the index to the last 143instance rather than the first. 144 145=cut 146 147sub max_index_ignoring_quotes { 148 my $pos = &index_ignoring_quotes; 149 my $opos = -1; 150 $pos = index_ignoring_quotes $_[0], $_[1], 1 + ($opos = $pos) 151 while $pos >= 0; 152 $opos; 153} 154 155=head2 split_on_whitespace 156 157 @pieces = split_on_whitespace($string); 158 159Works just like 160 161 @pieces = split(' ', $string) 162 163except that whitespace inside quoted strings is not counted as whitespace. 164This should be called after expanding all make variables; it does not know 165anything about things like "$(make expressions)". 166 167There are three kinds of quoted strings, as in the shell. Single quoted 168strings are terminated by a matching single quote. Double quoted strings are 169terminated by a matching double quote that isn't escaped by a backslash. 170Backquoted strings are terminated by a matching backquote that isn't escaped 171by a backslash. 172 173=cut 174 175sub unquote_split_on_whitespace { 176 # Can't call unquote when pushing because both use \G and at least in 5.6 177 # localizing $_ doesn't localize \G 178 map unquote(), &split_on_whitespace; 179} 180sub split_on_whitespace { 181 my @pieces; 182 my $cmds = @_ > 1; 183 local $_ = $_[0]; 184 185 pos = 0; # Start at the beginning. 186 $cmds ? /^[;|&]+/gc : /^\s+/gc; # Skip over leading whitespace. 187 my $last_pos = pos; 188 189 for (;;) { 190 $cmds ? /\G[^;|&()"'`\\\$]+/gc : /\G[^\s"'\\]+/gc; # Skip over irrelevant things. 191 192 last if length() <= pos; # End of string. 193 194 my $cur_pos = pos; # Remember the current position. 195 if ($cmds && /\G(?<=[<>])&/gc) { # Skip over redirector, where & is not a separator 196 } elsif ($cmds ? /\G[;|&()]+/gc : /\G\s+/gc) { # Found some whitespace? 197 push(@pieces, substr($_, $last_pos, $cur_pos-$last_pos)); 198 $last_pos = pos; # Beginning of next string is after this space. 199 } elsif (!$cmds and /\G"/gc) { # Double quoted string? 200 while (pos() < length) { 201 next if /\G[^\\"]+/gc; # Skip everything except quote and \. 202 /\G"/gc and last; # We've found the end of the string. 203 pos() += 2; # Skip char after backslash. 204 } 205 } elsif (/\G'[^']*'/gc) { # Skip until end of single quoted string. 206 } elsif (/\G`/gc) { # Back quoted string? 207 while (pos() < length) { 208 next if /\G[^\\`]+/gc; # Skip everything except quote and \. 209 /\G`/gc and last; # We've found the end of the string. 210 pos() += 2; # Skip char after backslash. 211 } 212 } else { # It's one of the standard cases ", \ or $. 213 # $ only gets here in commands, where we use the similarity of make expressions 214 # to skip over $(cmd; cmd), $((var|5)), ${var:-foo&bar}. 215 # " only gets here in commands, where we need to catch nested things like 216 # "$(cmd "foo;bar")" 217 &{$skip_over{substr $_, pos()++, 1}}; 218 } 219 } 220 221 push @pieces, substr $_, $last_pos 222 if length() > $last_pos; # Anything left at the end of the string? 223 224 @pieces; 225} 226sub split_commands { 227 split_on_whitespace $_[0], 1; 228} 229 230=head2 join_with_protection 231 232 $string = join_with_protection(@pieces); 233 234Works just like 235 236 $string = join(' ', @pieces) 237 238except that strings in @pieces that contain shell metacharacters are protected 239from the shell. 240 241=cut 242 243sub join_with_protection { 244 join ' ', 245 map { 246 $_ eq '' ? "''" : 247 /'/ ? map { s/'/'\\''/g; "'$_'" } "$_" : # Avoid modifying @_ 248 m|[^\w/.@%\-+=:]| ? "'$_'" : 249 $_; 250 } @_; 251} 252 253=head2 split_on_colon 254 255 @pieces = split_on_colon('string'); 256 257This subroutine is equivalent to 258 259 @pieces = split(/:+/, 'string'); 260 261except that colons inside double quoted strings or make expressions are passed 262over. Also, a semicolon terminates the expression; any colons after a 263semicolon are ignored. This is to support grokking of this horrible rule: 264 265 $(srcdir)/cat-id-tbl.c: stamp-cat-id; @: 266 267=cut 268 269sub split_on_colon { 270 my @pieces; 271 272 local $_ = $_[0]; 273 my $last_pos = 0; 274 pos = 0; # Start at the beginning. 275 276 for (;;) { 277 /\G[^;:"'\\\$]+/gc; # Skip over irrelevant stuff. 278 last if length() <= pos; # End of string? 279 # For reasons that I don't understand, testing 280 # for /\G\z/gc doesn't work here. 281 282 if (/\G(:+)/gc) { # Found our colon? 283 push @pieces, substr $_, $last_pos, pos() - $last_pos - length $1; 284 $last_pos = pos; # Beginning of next string is after this space. 285 } elsif (/\G;/gc) { # Found end of the rule? 286 pos = length; # Don't look for any more colons. 287 } else { # It's one of the standard cases ", ', \ or $. 288 &{$skip_over{substr $_, pos()++, 1}}; 289 } 290 } 291 292 if (length() > $last_pos) { # Anything left at the end of the string? 293 push @pieces, substr($_, $last_pos); 294 } 295 296 @pieces; 297} 298 299 300# 301# This routine splits the PATH according to the current systems syntax. An 302# object may be optionally passed. If that contains a non-empty entry {PATH}, 303# that is used instead of $ENV{PATH}. Empty elements are returned as '.'. 304# A second optional argument may be an alternative string to 'PATH'. 305# A third optional argument may be an alternative literal path. 306# 307sub split_path { 308 my $var = $_[1] || 'PATH'; 309 my $path = $_[2] || ($_[0] && $_[0]{$var} || $ENV{$var}); 310 if( Mpp::is_windows ) { 311 map { tr!\\"!/!d; $_ eq '' ? '.' : $_ } 312 Mpp::is_windows > 0 ? 313 split( /;/, "$path;" ) : # "C:/a b";C:\WINNT;C:\WINNT\system32 314 split_on_colon( "$path:" ); # "C:/a b":"C:/WINNT":/cygdrive/c/bin 315 } else { 316 map { $_ eq '' ? '.' : $_ } split /:/, "$path:"; 317 } 318} 319 320# 321# This routine is used to skip over a make expression. A make expression 322# is a variable, like "$(CXX)", or a function, like $(patsubst %.o, %.c, sdaf). 323# 324# The argument should be passed in the global variable $_ (not @_, as usual), 325# and pos($_) should be the character immediately after the dollar sign. 326# On return, pos($_) is the first character after the end of the make 327# expression. 328# 329# This returns the length of the opening parens, i.e.: $@ = 0; $(VAR) = 1 and 330# $((perl ...)) = 2, or undef if the closing parens don't match. 331# 332sub skip_over_make_expression { 333 my( $nonre, $endre ); 334 if (/\G\(/gc) { # Does the expression begin with $(? 335 $nonre = qr/[^)"'\$]/; 336 $endre = qr/\)/; 337 } elsif (/\G\{/gc) { # Does the expression begin with ${? 338 $nonre = qr/[^}"'\$]/; 339 $endre = qr/\}/; 340 } elsif (/\G\[/gc) { # Does the expression begin with $[? 341 $nonre = qr/[^]"'\$]/; 342 $endre = qr/\]/; 343 } else { 344 ++pos; # Must be a single character variable. Just 345 # skip over it. 346 return 0; 347 } 348 349 my $double = //gc || 0; # Does the expression begin with $((, ${{ or $[[? 350 351 if( /\G(?:perl|map())\s+/gc ) { # Is there plain Perl code we must skip blindly? 352 if( defined $1 ) { # The first arg to map is normal make stuff. 353 /\G[^"'\$,]/gc or &{$skip_over{substr $_, pos()++, 1}} 354 until /\G,/gc; 355 } 356 $double ? /\G.*?$endre$endre/gc : /\G.*?$endre/gc; 357 return $double + 1; 358 } 359 360 for (;;) { 361 /\G$nonre+/gc; # Skip over irrelevant things. 362 last if length() <= pos; # Quit if end of string. (Testing for \z 363 # seems unreliable.) 364 if( /\G$endre/gc ) { 365 return $double + 1 if !$double or //gc; # Quit if closing parens. 366 ++pos; # A simple ) within $(( )) or } within ${{ }} 367 } else { # It's one of the standard cases ", ' or $. 368 &{$skip_over{substr $_, pos()++, 1}}; 369 } 370 } 371 undef; 372} 373 374 375# 376# This subroutine is used to skip over a double quoted string. A double 377# quoted string may have a make expression inside of it; we also skip over 378# any such nested make expressions. 379# 380# The argument should be passed in the global variable $_ (not @_, as usual), 381# and pos($_) should be the character immediately after the quote. 382# On return, pos($_) is the first character after the closing quote. 383# 384sub skip_over_dquote { 385 for (;;) { 386 /\G[^"\\\$]+/gc; # Skip over irrelevant characters. 387 388 last if length() <= pos; # Quit if end of string. (Testing for \z 389 # seems unreliable.) 390 /\G"/gc and last; # Found the closing quote. 391 392 # It's one of the standard cases \ or $. 393 &{$skip_over{substr $_, pos()++, 1}}; 394 } 395} 396 397# 398# This subroutine is used to skip over a single quoted string. A single 399# quoted string may have a make expression inside of it; we also skip over 400# any such nested make expressions. The difference between a single and double 401# quoted string is that a backslash is used to escape special chars inside 402# a double quoted string, whereas it has no meaning in a single quoted string. 403# 404# The argument should be passed in the global variable $_ (not @_, as usual), 405# and pos($_) should be the character immediately after the quote. 406# On return, pos($_) is the first character after the closing quote. 407# 408sub skip_over_squote { 409 for (;;) { 410 /\G[^'\\\$]+/gc; # Skip over irrelevant characters. 411 412 last if length() <= pos; # Quit if end of string. (Testing for \z 413 # seems unreliable.) 414 /\G'/gc and last; # Found the closing quote. 415 416 # It's one of the standard cases \ or $. 417 &{$skip_over{substr $_, pos()++, 1}}; 418 } 419} 420 421=head2 unquote 422 423 $text = unquote($quoted_text) 424 425Removes quotes and escaping backslashes from a name. Thus if you give it as 426an argument 427 \""a bc"'"' 428 429it will return the string 430 431 "a bc" 432 433You must already have expanded all of the make variables in the string. 434unquote() knows nothing about make expressions. 435 436=cut 437 438sub unquote { 439 my $ret_str = ''; 440 441 local $_ = $_[0] if @_; 442 pos = 0; # Start at beginning of string. 443 444 for (;;) { 445 /\G([^"'\\]+)/gc and $ret_str .= $1; # Skip over ordinary characters. 446 last if length() <= pos; 447 448 if (/\G"/gc) { # Double quoted section of the string? 449 for (;;) { 450 /\G([^"\\]+)/gc and $ret_str .= $1; # Skip over ordinary chars. 451 if( /\G\\/gc ) { # Handle quoted chars. 452 if( length() <= pos ) { 453 die "single backslash at end of string '$_'\n"; 454 } else { # Other character escaped with backslash. 455 $ret_str .= substr $_, pos()++, 1; # Put it in verbatim. 456 } 457 } else { 458 last if length() <= pos || # End of string w/o matching quote. 459 ++pos; # Skip quote. 460 } 461 } 462 } elsif (/\G'/gc) { # Single quoted string? 463 /\G([^']+)/gc and $ret_str .= $1; # Copy up to terminating quote. 464 last if length() <= pos; # End of string w/o matching quote. 465 ++pos; # Or skip quote. 466 } else { 467 ++pos; # Must be '\', skip it 468 if( length() <= pos ) { 469 die "single backslash at end of string '$_'\n"; 470 } elsif (/\G([0-7]{1,3})/gc) { # Octal character code? 471 $ret_str .= chr oct $1; # Convert the character to binary. 472 } elsif (/\G([*?[\]])/gc) { # Backslashed wildcard char? 473 # Don't weed out backslashed wildcards here, 474 # because they're recognized separately in 475 # the wildcard routines. 476 $ret_str .= '\\' . $1; # Leave the backslash there. 477 } else { # Other character escaped with backslash. 478 $ret_str .= substr $_, pos()++, 1; # Put it in verbatim. 479 } 480 } 481 } 482 483 $ret_str; 484} 485 486=head2 requote 487 488 $quoted_text = requote($unquoted_text); 489 490Puts quotes around the text, and escapes any quotes inside the text, so 491that calling unquote() on $quoted_text will return the same string as 492$unquoted_text. 493 494=cut 495 496sub requote { 497 my( $str ) = @_; # Get a modifiable copy of the string. 498 $str =~ s/(["\\])/\\$1/g; # Protect all backslashes and double quotes. 499 $str =~ s{([\0-\037])}{sprintf '\%o', ord $1}eg; # Protect any binary characters. 500 qq["$str"]; # Return the quoted string. 501} 502 503# 504# Perl contains an optimization where it won't run a shell if it thinks the 505# command has no shell metacharacters. However, its idea of shell 506# metacharacters is a bit too limited, since it doesn't realize that something 507# like "XYZ=abc command" does not mean to execute the program "XYZ=abc". 508# Also, Perl's system command doesn't realize that ":" is a valid shell 509# command. So we do a bit more detailed check for metacharacters and 510# explicitly pass it off to a shell if needed. 511# 512# This subroutine takes a shell command to execute, and returns an array 513# of arguments suitable for exec() or system(). 514# 515sub format_exec_args { 516 my( $cmd ) = @_; 517 return $cmd # No Shell available. 518 if Mpp::is_windows > 1; 519 if( Mpp::is_windows == 1 && $cmd =~ /[%"\\]/ ) { # Despite multi-arg system(), these chars mess up command.com 520 require Mpp::Subs; 521 my $tmp = Mpp::Subs::f_mktemp( '' ); 522 open my $fh, '>', $tmp; 523 print $fh $cmd; 524 return ($ENV{SHELL}, $tmp); 525 } 526 return ($ENV{SHELL}, '-c', $cmd) 527 if Mpp::is_windows == -2 || Mpp::is_windows == 1 || 528 $cmd =~ /[()<>\\"'`;&|*?[\]#]/ || # Any shell metachars? 529 $cmd =~ /\{.*,.*\}/ || # Pattern in Bash (blocks were caught by ';' above). 530 $cmd =~ /^\s*(?:\w+=|[.:!](?:\s|$)|e(?:val|xec|xit)\b|source\b|test\b)/; 531 # Special commands that only 532 # the shell can execute? 533 534 return $cmd; # Let Perl do its optimization. 535} 536 537# 538# Compute the length of whitespace when it may be composed of spaces or tabs. 539# The leading whitespace is removed from $_. 540# Usage: 541# $len = strip_indentation; 542# 543# If $_ is not all tabs and spaces, returns the length of the 544# whitespace up to the first non-white character. 545# 546 547sub strip_indentation() { 548 my $white_len = 0; 549 pos = 0; # Start at the beginning of the string. 550 while( /\G(?:( +)|(\t+))/gc ) { 551 if( $1 ) { # Spaces? 552 $white_len += length $1; 553 } else { # Move over next tab stops. 554 $white_len = ($white_len + 8*length $2) & ~7; 555 # Cheap equivalent for 8*int(.../8) 556 } 557 } 558 substr $_, 0, pos, ''; 559 $white_len; 560} 561 562=head2 hash_neq 563 564 if (hash_neq(\%a, \%b)) { ... } 565 566Returns true (actually, returns the first key encountered that's different) if 567the two associative arrays are unequal, and '' if not. 568 569=cut 570 571sub hash_neq { 572 my ($a, $b, $ignore_empty ) = @_; 573# 574# This can't be done simply by stringifying the associative arrays and 575# comparing the strings (e.g., join(' ', %a) eq join(' ', %b)) because 576# the order of the key/value pairs in the list returned by %a differs. 577# 578 my %a_not_b = %$a; # Make a modifiable copy of one of them. 579 delete @a_not_b{grep !length $a_not_b{$_}, keys %a_not_b} 580 if $ignore_empty; 581 foreach (keys %$b) { 582 next if $ignore_empty && !length $b->{$_}; 583 exists $a_not_b{$_} or return $_ || '0_'; # Must return a true value. 584 $a_not_b{$_} eq $b->{$_} or return $_ || '0_'; 585 delete $a_not_b{$_}; # Remember which things we've compared. 586 } 587 588 if (scalar %a_not_b) { # Anything left over? 589 return (%a_not_b)[0] || '0_'; # Return the first key value. 590 } 591 ''; # No difference. 592} 593 594=head2 is_cpp_source_name 595 596 if (is_cpp_source_name($filename)) { ... } 597 598Returns true if the given filename has the appropriate extension to be 599a C or C++ source or include file. 600 601=cut 602 603# NOTE: NVIDIA uses ".pp" for generic files (not necessarily programs) 604# that need to pass through cpp. 605sub is_cpp_source_name { 606 $_[0] =~ /\.(?:[ch](|[xp+])\1|([chp])\2|moc|x[bp]m|idl|ii?|mi)$/i; 607 # i, ii, and mi are for the GNU C preprocessor 608 # (see cpp(1)). moc is for qt. 609} 610 611=head2 is_object_or_library_name 612 613 if (is_object_or_library_name($filename)) { ... } 614 615Returns true if the given filename has the appropriate extension to be some 616sort of object or library file. 617 618=cut 619 620sub is_object_or_library_name { 621 $_[0] =~ /\.(?:l?[ao]|s[aol](?:\.[\d.]+)?)$/; 622} 623 624=head2 getopts 625 626 getopts %vars, strictflag, [qw(o optlong), \$var, wantarg, handler], ... 627 628Almost as useful as Getopt::Long and much smaller :-) 629 630%vars is optional, any VAR=VALUE pairs get stored in it if passed. 631 632strictflag is optional, means to stop at first non-option. 633 634Short opt may be empty, longopt may be a regexp (grouped if alternative). 635 636$var gets incremented for each occurrence of this option or, if optional 637wantarg is true, it gets set to the argument. This can be undef if you don't 638need it. 639 640If an optional handler is given, it gets called after assigning $var, if it is 641a ref (a sub). Any other value is assigned to $var. 642 643=cut 644 645my $args; 646my $argfile = 647 ['A', qr/arg(?:ument)?s?[-_]?file/, \$args, 1, 648 sub { 649 open my $fh, $args or die "$0: cannot open args-file `$args'--$!\n"; 650 local $/; 651 unshift @ARGV, unquote_split_on_whitespace <$fh>; 652 close $fh; 653 }]; 654sub getopts(@) { 655 my $hash = 'HASH' eq ref $_[0] and 656 my $vars = shift; 657 my $mixed = ref $_[0] 658 or shift; 659 my( @ret, %short ); 660 while( @ARGV ) { 661 my $opt = shift @ARGV; 662 if( $opt =~ s/^-(-?)// ) { 663 my $long = $1; 664 if( $opt eq '' ) { # nothing after -(-) 665 if( $long ) { # -- explicit end of opts 666 unshift @ARGV, @ret; 667 return; 668 } 669 push @ret, '-'; # - stdin; TODO: this assumes $mixed 670 next; 671 } 672 SPECS: for my $spec ( @_, $argfile, undef ) { 673 die "$0: unknown option -$long$opt\n" unless defined $spec; 674 if( $long ) { 675 if( $$spec[3] ) { 676 next unless $opt =~ /^$$spec[1](?:=(.*))?$/; 677 ${$$spec[2]} = defined $1 ? $1 : @ARGV ? shift @ARGV : 678 die "$0: no argument to --$opt\n"; 679 } else { # want no arg 680 next unless $opt =~ /^$$spec[1]$/; 681 ${$$spec[2]}++; 682 } 683 } else { # short opt 684 next unless $$spec[0] && $opt =~ s/^$$spec[0]//; 685 if( $$spec[3] ) { 686 ${$$spec[2]} = $opt ne '' ? $opt : @ARGV ? shift @ARGV : 687 die "$0: no argument to -$$spec[0]\n"; 688 $opt = ''; 689 } else { 690 ${$$spec[2]}++; 691 } 692 print STDERR "$0: -$$spec[0] is short for --"._getopts_long($spec)."\n" 693 if $Mpp::verbose && !$short{$$spec[0]}; 694 $short{$$spec[0]} = 1; 695 } 696 ref $$spec[4] ? &{$$spec[4]} : (${$$spec[2]} = $$spec[4]) if exists $$spec[4]; 697 goto SPECS if !$long && length $opt; 698 last; 699 } 700 } elsif( $hash and $opt =~ /^(\w[-\w.]*)=(.*)/ ) { 701 $vars->{$1} = $2; 702 } elsif( $mixed ) { 703 push @ret, $opt; 704 } else { 705 unshift @ARGV, $opt; 706 return; 707 } 708 } 709 @ARGV = @ret; 710} 711 712# Transform regexp to be human readable. 713sub _getopts_long($) { 714 my $str = "$_[0][1]"; 715 $str =~ s/.*?://; # remove qr// decoration 716 $str =~ s/\[-_\]\??/-/g; 717 $str =~ s/\(\?:([^(]+)\|[^(]+?\)/$1/g; # reduce inner groups (?:...|...) to 1st variant 718 $str =~ s/\|/, --/g; 719 $str =~ tr/()?://d; 720 $str; 721} 722 723#@@eliminate 724# Not installed, so grep all our sources for the checkin date. Make a 725# composite version consisting of the three most recent dates (shown as (yy)mmdd, 726# but sorted including year) followed by the count of files checked in that 727# day. 728# 729BEGIN { 730 $Mpp::datadir ||= (grep -f( "$_/Mpp.pm" ) && -f( "$_/VERSION" ), @INC)[0] or 731 die "Can't find our libraries in \@INC.\n"; 732 open my $fh, '<', "$Mpp::datadir/VERSION" or 733 die "Can't read the file $Mpp::datadir/VERSION--$!.\nThis should be part of the standard distribution.\n"; 734 chomp( $Mpp::VERSION # Hide assignment from CPAN scanner. 735 = <$fh> ); 736 if( $Mpp::VERSION # -"- 737 =~ s/beta\r?// ) { 738 my %VERSION = qw(0/00/00 0 00/00/00 0); # Default in case all modules change on same day. 739 for( <$Mpp::datadir/makep*[!~] $Mpp::datadir/Mpp{,/*,/*/*}.pm> ) { 740 open my( $fh ), $_; 741 while( <$fh> ) { 742 if( /\$Id: .+,v [.0-9]+ ([\/0-9]+)/ ) { 743 $VERSION{$1}++; 744 last; 745 } 746 } 747 } 748 my $year = ''; 749 $Mpp::VERSION .= join '-', '', 750 grep { s!\d\d(\d+)/(\d+)/(\d+)!($year eq $1 ? '' : ($year = $1))."$2$3:$VERSION{$_}"!e } 751 (reverse sort keys %VERSION)[0..2]; 752 } 753} 754#@@ 755 756 757our @common_opts = 758 ( # makeppbuiltin relies on help being 1st. 759 [qr/[h?]/, 'help', undef, undef, sub { local $/; print <Mpp::DATA>; exit 0 }], 760 761 [qw(V version), undef, undef, sub { $0 =~ s!.*/!!; print <<EOS; exit 0 }]); 762$0 version $Mpp::VERSION 763Makepp may be copied only under the terms of either the Artistic License or 764the GNU General Public License, either version 2, or (at your option) any 765later version. 766For more details, see the makepp homepage at http://makepp.sourceforge.net. 767EOS 768 7691; 770