| 1 | #!/usr/bin/perl |
| 2 | |
| 3 | use strict; |
| 4 | use warnings; |
| 5 | use Text::Tabs qw(expand unexpand); |
| 6 | |
| 7 | =head1 NAME |
| 8 | |
| 9 | Porting/manifest_lib.pl - functions for managing manifests |
| 10 | |
| 11 | =head1 SYNOPSIS |
| 12 | |
| 13 | require './Porting/manifest_lib.pl'; |
| 14 | |
| 15 | =head1 DESCRIPTION |
| 16 | |
| 17 | This file makes available one function, C<sort_manifest()>. |
| 18 | |
| 19 | =head2 C<sort_manifest> |
| 20 | |
| 21 | Treats its arguments as (chomped) lines from a MANIFEST file, and returns that |
| 22 | listed sorted appropriately. |
| 23 | |
| 24 | =cut |
| 25 | |
| 26 | # Try to get a sane sort. case insensitive, more or less |
| 27 | # sorted such that path components are compared independently, |
| 28 | # and so that lib/Foo/Bar sorts before lib/Foo-Alpha/Baz |
| 29 | # and so that lib/Foo/Bar.pm sorts before lib/Foo/Bar/Alpha.pm |
| 30 | # and so that configure and Configure sort together. |
| 31 | sub sort_manifest { |
| 32 | my @lines = @_; |
| 33 | |
| 34 | # first we ensure that the descriptions for the files |
| 35 | # are lined up reasonably. |
| 36 | my %pfx_len; |
| 37 | my @line_tuples; |
| 38 | foreach my $idx (0 .. $#lines) { |
| 39 | my $line = $lines[$idx]; |
| 40 | # clean up tab/space issues |
| 41 | $line =~ s/\t[ ]+/\t/; |
| 42 | if ($line =~ s/^(\S+)([ ]\s+)(\S+.*)/$1\t/) { |
| 43 | my $descr = $2; |
| 44 | $descr =~ s/\t+/ /g; |
| 45 | $line .= $descr; |
| 46 | } |
| 47 | $line =~ s/\s+\z//; |
| 48 | $line =~ /^(\S+)(?:\t+([^\t]*))?\z/ |
| 49 | or do { |
| 50 | $line =~ s/\t/\\t/g; |
| 51 | die "Malformed content in MANIFEST at line $idx: '$line'\n", |
| 52 | "Note: tabs have been encoded as \\t in this message.\n"; |
| 53 | }; |
| 54 | my ($file, $descr) = ($1, $2); |
| 55 | my $pfx; |
| 56 | if ($file =~ m!^((?:[^/]+/){1,2})!) { |
| 57 | $pfx = $1; |
| 58 | } else { |
| 59 | $pfx = ""; |
| 60 | } |
| 61 | #print "'$pfx': $file\n"; |
| 62 | push @line_tuples, [$pfx, $file, $descr]; |
| 63 | $pfx_len{$pfx} //= 40; |
| 64 | |
| 65 | # ensure we have at least one "space" (really tab) |
| 66 | my $flen = 1 + length $file; |
| 67 | $pfx_len{$pfx} = $flen |
| 68 | if $pfx_len{$pfx} < $flen; |
| 69 | } |
| 70 | |
| 71 | # round up to the next tab stop |
| 72 | $_ % 8 and $_ += (8 - ($_ % 8)) for values %pfx_len; |
| 73 | |
| 74 | my @pretty_lines; |
| 75 | foreach my $tuple (@line_tuples) { |
| 76 | my ($pfx, $file, $descr) = @$tuple; |
| 77 | my $str = sprintf "%*s", -$pfx_len{$pfx}, $file; |
| 78 | ($str) = unexpand($str); |
| 79 | # I do not understand why this is necessary. Bug in unexpand()? |
| 80 | # See https://github.com/ap/Text-Tabs/issues/5 |
| 81 | $str =~ s/[ ]+/\t/; |
| 82 | if ($descr) { |
| 83 | $str =~ s/\t?\z/\t/; |
| 84 | $str .= $descr; |
| 85 | } |
| 86 | $str =~ s/\s+\z//; |
| 87 | push @pretty_lines, $str; |
| 88 | } |
| 89 | |
| 90 | @pretty_lines = |
| 91 | # case insensitive sorting of directory components independently. |
| 92 | map { $_->[0] } # extract the full line |
| 93 | sort { |
| 94 | $a->[2] cmp $b->[2] || # sort by the first directory |
| 95 | $a->[1] cmp $b->[1] || # sort in order of munged filename |
| 96 | $a->[0] cmp $b->[0] # then by the exact text in full line |
| 97 | } |
| 98 | map { |
| 99 | # split out the filename and the description |
| 100 | my ($f) = split /\s+/, $_, 2; |
| 101 | # extract out the first directory |
| 102 | my $d = $f=~m!^(\w+/)! ? lc $1 : ""; |
| 103 | # lc the filename so Configure and configure sort together in the list |
| 104 | my $m= lc $f; # $m for munged |
| 105 | # replace slashes by nulls, this makes short directory names sort before |
| 106 | # longer ones, such as "foo/" sorting before "foo-bar/" |
| 107 | $m =~ s!/!\0!g; |
| 108 | # replace the extension (only one) by null null extension. |
| 109 | # this puts any foo/blah.ext before any files in foo/blah/ |
| 110 | $m =~ s{(?<!\A)(\.[^.]+\z)}{\0\0$1}; |
| 111 | |
| 112 | # return the original string, and the munged filename, and root dir |
| 113 | [ $_, $m, $d ]; |
| 114 | } @pretty_lines; |
| 115 | |
| 116 | return @pretty_lines; |
| 117 | } |
| 118 | |
| 119 | 1; |
| 120 | |
| 121 | # ex: set ts=8 sts=4 sw=4 et: |