From 4a0798e9378fdb2de85f56e1ef1d46653f86cc69 Mon Sep 17 00:00:00 2001 From: Karl Berry Date: Sun, 25 Oct 2015 22:41:38 +0000 Subject: srcredact (25oct15) git-svn-id: svn://tug.org/texlive/trunk@38710 c570f23f-e606-0410-a88d-b1316a301751 --- Master/texmf-dist/scripts/srcredact/srcredact.pl | 521 +++++++++++++++++++++++ 1 file changed, 521 insertions(+) create mode 100755 Master/texmf-dist/scripts/srcredact/srcredact.pl (limited to 'Master/texmf-dist/scripts/srcredact') diff --git a/Master/texmf-dist/scripts/srcredact/srcredact.pl b/Master/texmf-dist/scripts/srcredact/srcredact.pl new file mode 100755 index 00000000000..5908bde1e20 --- /dev/null +++ b/Master/texmf-dist/scripts/srcredact/srcredact.pl @@ -0,0 +1,521 @@ +#!/usr/bin/env perl + +use strict; + +my $USAGE = < + +or + + % + +In the first cases the text following the guard is included for the +audiences "name1", "name2", .... In the second case it is excluded for +these audiences. + +THere is a special audience "ALL": a wild card for all audiences. Thus +the idiom + + % + % + +means that the chunk is excluded for all audiences but "classified" + +Exactly one of the options -e (extract) or -u (unextract) must be present. +In the redact mode the non-option argument is the name of the full file. +If it is absent, or is "-", standard input is used. In the unextract mode +the first non-option argument + +OPTIONS + -c list of comment patterns + Use the given pattern for comment lines to search for guards instead + of the default "TeX" pattern. The recognized patterns are: + + c + // + + cpp + // + + fortran + C + + shell + # + + TeX + % + + The pattern names should be separated by commas, and the list may be + enclosed in quotes to prevent shell expansion, e.g + + -c "TeX, c, shell" + + -d Debug mode on. + + -e audience + Extract the contents for the current audience into the file file. + The cuurent audience is guessed from the file name, if the latter + has the structure base-audience.extension, e.g. + "report-unclassified.tex". The key -a overrides this guess and + should be used if the file name does not follow this pattern. The + file name "-" means the standard output. + + -h Print help information and exit. + + -l List all audiences set in the file (one per line) and exit. + + -u audience + Take a redacted file intended for the audience (the second + non-option argument) and incorporate the changes in it into the full + file (the first non-option argument). If the second argument is + missing, standard input is used instead. As usual, "-" also means + standard input. Note that only one of the two file arguments in this + case can be standard input. + + -v Print version information and exit. + + -w on|off|1|0|true|false + If "on", 1 or "true" (the deafult), implicitly wrap the full + document into the guards + + % + ... + % +END + + + my $COPYRIGHT= < is $wrap\n"; +} + +# Opening files +my $fullFH; +my $newFH; + +# In 'l' or 'e' mode we need one or zero non-option arguments +if (($mode eq 'list') || ($mode eq 'extract')) { + if (scalar(@ARGV) == 0) { + if ($DEBUG) { + print STDERR "Usign stdin for full file\n"; + } + $fullFH=*STDIN; + } elsif (scalar(@ARGV) == 1) { + my $full = shift @ARGV; + if ($full eq '-') { + if ($DEBUG) { + print STDERR "Usign stdin for full file\n"; + } + $fullFH = *STDIN; + } else { + if ($DEBUG) { + print STDERR "Usign $full for full file\n"; + } + open ($fullFH, "<", $full) or do { + print STDERR "Cannot open file $full\n"; + exit (2); + }; + } + } else { + print STDERR + "Options -e and -l require one or zero non-option argument\n\n"; + print STDERR $USAGE; + exit(2); + } +} + +# In 'u' mode we need one or two arguments +if ($mode eq 'unextract') { + if ((scalar(@ARGV) < 1) || (scalar(@ARGV) > 2)) { + print STDERR + "Option -u requires one or two non-option argument\n\n"; + print STDERR $USAGE; + exit(2); + } + + my $full = shift @ARGV; + if ($full eq '-') { + if ($DEBUG) { + print STDERR "Usign stdin for full file\n"; + } + $fullFH = *STDIN; + } else { + if ($DEBUG) { + print STDERR "Usign $full for full file\n"; + } + open ($fullFH, "<", $full) or do { + print STDERR "Cannot open file $full\n"; + exit (2); + }; + } + + if (scalar(@ARGV) == 0) { + if ($DEBUG) { + print STDERR "Usign stdin for redacted file\n"; + } + $newFH=*STDIN; + } else { + my $redacted = shift @ARGV; + if ($redacted eq '-') { + if ($DEBUG) { + print STDERR "Usign stdin for redacted file\n"; + } + $newFH = *STDIN; + } else { + if ($DEBUG) { + print STDERR "Usign $redacted for redacted file\n"; + } + open ($newFH, "<", $redacted) or do { + print STDERR "Cannot open file $redacted\n"; + exit (2); + }; + } + } +} + + + +# And the real work +if ($mode eq 'list') { + if ($DEBUG) { + print STDERR "List mode\n"; + } + my @audiences=ListAudiences($fullFH, \@commentPatterns); + print join("\n", @audiences), "\n"; + exit (0); +} + +if ($mode eq 'extract') { + if ($DEBUG) { + print STDERR "Extract mode\n"; + } + ExtractText($fullFH, \*STDOUT, $audience, + \@commentPatterns, $wrap); + exit (0); +} + +if ($mode eq 'unextract') { + if ($DEBUG) { + print STDERR "Unextract mode\n"; + } + + my $exitCode = UnextractText($fullFH, $newFH, \*STDOUT, + $audience, \@commentPatterns, $wrap); + + exit ($exitCode); + +} + +################################################## +# Extracting comment patterns +################################################## + +sub GetCommentPatterns { + + my %knownPatterns = ( 'c' => '^/\*<([^>]*)>\*/', + 'cpp' => '^\/\/<([^>]*)>', + fortran => '^C<([^>]*)>', + shell => '^#<([^>]*)>', + tex => '^%<([^>]*)>' + ); + + + + my $input = shift; + if ($DEBUG) { + print STDERR "Got pattern string $input\n"; + } + $input =~ s/^\s*//; + $input =~ s/\s*$//; + my @languages = split /[\s,]\s*/, $input; + my @patterns; + + foreach my $lang (@languages) { + $lang =~ s/^(.*)$/\L$1\E/; + if ($DEBUG) { + print STDERR "Processing language $lang... "; + } + if (exists $knownPatterns{$lang}) { + push @patterns, $knownPatterns{$lang}; + if ($DEBUG) { + print STDERR "found pattern $knownPatterns{$lang}\n"; + } + } else { + print STDERR + "Unknown comment language $lang. The supported languages are ", + join(", ", keys %knownPatterns), "\n"; + exit(2); + } + } + + return @patterns; +} + +################################################## +# List audiences +################################################## + +sub ListAudiences { + my $fh=shift; + my $patterns=shift; + my %foundAudiences = ('ALL' => 1); + while (<$fh>) { + my @result = FindAudiences ($_, $patterns); + if (scalar @result) { + shift @result; + foreach my $audience (@result) { + $foundAudiences{$audience} = 1; + } + } + } + return (sort keys %foundAudiences); +} + +################################################## +# Check whether the line is a comment +################################################## +# Return 0 to delete, 1 to add, and the list of +# audiences +sub FindAudiences { + my $line = shift; + my $patterns=shift; + foreach my $pattern (@{$patterns}) { + if ($line =~ m/$pattern/) { + if ($DEBUG) { + print STDERR "Line $. is a guard: $line"; + } + my $guards = $1; + my @result; + if (substr($guards,0,1) eq '*') { + push @result, 1; + } elsif (substr($guards,0,1) eq '/') { + push @result, 0; + } else { + die "Wrong guard line $line\n"; + } + @result = (@result, split(/\|/, substr($guards,1))); + return @result; + } + } + return (); +} + +################################################## +# Extracting text for the given audience +################################################## +sub ExtractText { + my $fullFH=shift; + my $outFH=shift; + my $audience = shift; + my $patterns = shift; + my $state = shift; + + if ($DEBUG) { + print STDERR "Initial state $state\n"; + } + + while (<$fullFH>) { + my @result = FindAudiences ($_, $patterns); + if (scalar @result) { + my $newstate = shift @result; + foreach my $tryaudience (@result) { + if (($tryaudience eq 'ALL') || + ($audience eq $tryaudience)) { + $state = $newstate; + if ($DEBUG) { + print STDERR "Changing state to $state\n"; + } + last; + } + } + } else { # Normal line + if ($state) { + print $outFH $_; + } + } + } +} + +################################################################ +# Merge files +################################################################ + +sub UnextractText { + my $fullFH=shift; + my $newFH=shift; + my $outFH = shift; + my $audience = shift; + my $patterns = shift; + my $state = shift; + + # Creating tempdir. We leave the tempdir in place in + # the debug mode + my $tmpdir = tempdir (CLEANUP => !$DEBUG); + if ($DEBUG) { + print STDERR "Creating directory $tmpdir\n"; + } + + open (FULL, ">$tmpdir/full") or do { + print STDERR "Cannot open temporary file $tmpdir/full\n"; + return(2); + }; + + print FULL <$fullFH>; + close FULL; + + open (FULL, "<$tmpdir/full") or do { + print STDERR "Cannot open temporary file $tmpdir/full\n"; + return(2); + }; + + open (EXTRACTED, ">$tmpdir/extracted") or do { + print STDERR "Cannot open temporary file $tmpdir/extracted\n"; + return(2); + }; + + if ($DEBUG) { + print STDERR "Extracting text\n"; + } + + ExtractText(\*FULL, \*EXTRACTED, $audience, + $patterns, $wrap); + + close FULL; + close EXTRACTED; + + open (NEW, ">$tmpdir/new") or do { + print STDERR "Cannot open temporary file $tmpdir/new\n"; + return(2); + }; + + print NEW <$newFH>; + close NEW; + + + if ($DEBUG) { + print STDERR "Merging text\n"; + } + + print $outFH `diff3 -m $tmpdir/full $tmpdir/extracted $tmpdir/new`; + + return ${^CHILD_ERROR_NATIVE}; + +} -- cgit v1.2.3