package VCP::Filter::labelmap;
=head1 NAME
VCP::Filter::labelmap - Alter or remove labels from each revision
=head1 SYNOPSIS
## From the command line:
vcp <source> labelmap: "rev_$rev_id" "change_$change_id" -- <dest>
## In a .vcp file:
LabelMap:
foo-... <<delete>> # remove all labels beginning with foo-
F...R <<delete>> # remove all labels F
v-(...) V-$1 # use uppercase v prefixes
=head1 DESCRIPTION
Allows labels to be altered or removed using a syntax similar to
VCP::Filter::map. This is being written for development use so more
documentation is needed. See L<VCP::Filter::map|VCP::Filter::map> for
more examples of pattern matching (though VCP::Filter::labelmap does
not use <branch_id> syntax).
=for test_script t/61labelmap.t
=cut
$VERSION = 1 ;
@ISA = qw( VCP::Filter );
use strict ;
use VCP::Debug qw( :debug );
use VCP::Filter;
use VCP::Logger qw( lg );
use Regexp::Shellish qw( compile_shellish );
#use base qw( VCP::Filter );
#use fields (
# 'MAP_SUB', ## The rules to apply, compiled in to an anon sub
#);
## NOTE: this code is simpler than, but similar to, the same-named
## helper routines in VCP::Filter::map. That module uses multifield
## patterns and actions, this one uses single field (ie just the
## label) patterns and actions.
sub _parse_expr {
my ( $type, $v ) = @_;
my %expr;
return () unless defined $v;
if ( $type eq "result" ) {
return ( delete => 1, %expr ) if $v eq "<<delete>>";
return ( keep => 1, %expr ) if $v eq "<<keep>>";
}
$expr{label} = $v;
die "unable to parse labelmap $type '$v'\n"
unless defined $expr{label};
for ( "label" ) { ## loop is just to mimic code in VCP::Filter::map
die "newline in '$expr{$_}' of labelmap $type '$v'\n"
if $expr{$_} =~ tr/\n//;
die "unescaped '$1' in '$expr{$_}' of labelmap $type '$v'\n"
if $expr{$_} =~
( $type eq "pattern"
? qr{(?<!\\)(?:\\\\)*([\@#<>\[\]{}\$])}
: qr{(?<!\\)(?:\\\\)*([\@#<>\[\]*?()]|\.\.\.)|(?<!\$)\{}
);
## We reserve a lot of metacharacters so we can do more later.
die "illegal escape sequence '$1' in '$expr{$_}' of labelmap $type '$v'\n"
if $expr{$_} =~ qr{(?<!\\)(?:\\\\)*(\\(?!=\.\.\.)[^\@#<>\[\]{}*?()])};
}
return %expr;
}
sub _compile_rule {
my $self = shift;
my ( $name, $pattern, $result ) = @_;
my %pattern_expr = _parse_expr pattern => $pattern;
my %result_expr = _parse_expr result => $result;
## The test expression is a single regexp that matches a string
## built up from some pieces of the rev metadata. Right now, only
## the name and the branch_id are tested, by someday the labels,
## change_id, rev_id, and comment could be tested. If so, the
## comment field would need to come last due to newline issues.
my $test_expr =
! keys %pattern_expr
? 1 ## This happens iff the pattern was undef (which
## should only happen for the default rule).
: join(
"",
"m'", ## Note the single-quotish context
do {
my $re = compile_shellish( $pattern_expr{label} );
$re =~ s{(')}{\\`}g;
$re =~ s{\A\(\?[\w-]*: (.*) \)}{$1}gx; # for readability
# of dumped code
$re;
},
"'",
);
$pattern = defined $pattern ? qq{"$pattern"} : "match all";
my $result_statement = join(
"",
debugging
? qq{lg( ' matched $name ($pattern)' );\n}
: (),
$result_expr{keep}
? (
debugging
? qq{lg( " <<keep>>ing" );\n}
: (),
"push \@l, \$_; ## Keep!\n"
)
: $result_expr{delete}
? (
debugging
? qq{lg( " <<delete>>ing" );\n}
: (),
"++\$changed; ## Delete!\n",
)
: do {
my $expr = $result_expr{label};
$expr =~ s{([\\"])}{\\$1}g;
$expr =~ s{\n}{\\n}g;
(
debugging
? qq{lg( " rewriting \$_ to '$expr'" );\n}
: (),
qq{push \@l, "$expr";\n},
qq{++\$changed;\n},
);
}
);
$result_statement =~ s/^/ /gm;
$result_statement = "elsif ( $test_expr ) {\n$result_statement}\n";
$result_statement =~ s/^/ /gm;
$result_statement;
}
sub _compile_rules {
my $self = shift;
my ( $rules ) = @_;
## NOTE: making this a closure causes spurious warnings at exit so
## we pass $self explicitly.
my $preamble = <<END_PREAMBLE;
my ( \$self, \$rev ) = \@_;
END_PREAMBLE
my $rule_number;
my $code = join( "",
$preamble,
"my \@l;\n",
"my \$changed;\n",
"for ( \$rev->labels ) {\n",
debugging
? qq{ my \$s = \$_; \$s =~ s/\\n/\\\\n/g; lg( "labelmap testing '\$s' (", \$rev->as_string, ")" );\n\n}
: (),
" if (0) {}\n",
map( $self->_compile_rule( @$_ ),
map( [ "Rule " . ++$rule_number, @$_ ], @$rules ),
[ "Default Rule", undef, "<<keep>>" ]
),
"}\n",
"\$rev->set_labels( \\\@l ) if \$changed;\n",
"\$self->dest->handle_rev( \$rev );\n",
);
$code =~ s/^/ /mg;
$code = "#line 1 VCP::Filter::labelmap::labelmap_function\n$code";
$code = "sub {\n$code}";
debug "labelmap code:\n$code" if debugging;
return( eval $code
or die "$@ compiling Map: code:\n",
do {
my $w = length( $code =~ tr/\n// + 1 ) ;
my $ln;
1 while chomp $code;
$code =~ s{^}[sprintf "%${w}d|",++$ln]gme;
"$code\n";
},
);
}
sub new {
my $self = shift->SUPER::new;
## Parse the options
my ( $spec, $options ) = @_ ;
$self->{MAP_SUB} = $self->_compile_rules(
$self->parse_rules_list( $options, "Pattern", "Replacement" )
);
return $self ;
}
sub filter_name { return "LabelMap" }
sub handle_rev {
my $self = shift;
$self->{MAP_SUB}->( $self, @_ );
}
=head1 AUTHOR
Barrie Slaymaker <barries@slaysys.com>
=head1 COPYRIGHT
Copyright (c) 2000, 2001, 2002 Perforce Software, Inc.
All rights reserved.
See L<VCP::License|VCP::License> (C<vcp help license>) for the terms of use.
=cut
1