addlabels.pm #1

package VCP::Filter::addlabels;

=head1 NAME

VCP::Filter::addlabels - Add labels to each revision

=head1 SYNOPSIS

  ## From the command line:
   vcp <source> addlabels: "rev_$rev_id" "change_$change_id" -- <dest>

  ## In a .vcp file:

    AddLabels:
            rev_$rev_id
            change_$change_id
            # ... etc ...

=head1 DESCRIPTION

Used when you want to track the original rev_id, change_id, branch_id,
etc. of each revision had in the source repository by adding a label.
Can be used to turn any piece of metadata in to a label.

There is no way to add labels only to selected revisions at this
time, but if you try to add a label for metadata that is undefined
or empty, it will not be added.

=for test_script t/61addlabels.t

=cut

$VERSION = 1 ;

use strict ;
use VCP::Debug qw( :debug );
use VCP::Utils qw( shell_quote );
use VCP::Filter;
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
);

sub _empty { ! ( defined $_ && length $_ ) }

sub _compile_label_add_routine {
   my VCP::Filter::addlabels $self = shift;

   my $preamble = <<END_PREAMBLE;
my ( \$rev ) = \@_;

END_PREAMBLE

   $preamble .= qq{my \$s = \$_; \$s =~ s/\\n/\\\\n/g; VCP::Debug::debug( "vcp: addlabels processing '\$s' (", \$rev->as_string, ")" );\n\n}
      if explicitly_debugging $self;

   my @code = ( $preamble );

   for ( @_ ) {
      my $l = $_;
      my %f;
      $l =~ s/\$(\w+)/$f{$1}=undef; "' . \$rev->$1 . '"/ge;
      $l =~ s/\$\{[^}]+\}/$f{$1}=undef; "' . \$rev->$1 . '"/ge;
      push @code, join "",
         "\$rev->add_label( '",
         $l,
         "' )",
         keys %f
            ? (
               " if ! grep _empty, ",
               join( ", ", map "\$rev->$_()", sort keys %f )
            )
            : (),
          ";\n";
   }

   push @code, "\$self->dest->handle_rev( \$rev );\n";

   my $code = join "", @code;
   $code =~ s/^/   /mg;

   # NOTE: the sub is a closure and encloses our $self
   $code = "sub {\n$code}";
   debug "vcp: addlabels code:\n$code" if explicitly_debugging $self;

   return( eval $code
      or die "vcp: $@ compiling\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 $class = shift ;
   $class = ref $class || $class ;

   my $self = $class->SUPER::new( @_ ) ;

   ## Parse the options
   my ( $spec, $options ) = @_ ;

   # Add the default rule.
   my @label_specs;
   while ( @$options ) {
      my $v = shift @$options;
      last if $v eq "--";
      push @label_specs, $v;
   }

   if ( debugging $self ) {
      require Data::Dumper;
      debug( "vcp: ", Data::Dumper->Dump( [ \@label_specs], [ "addlabels" ] ) );
   }

   $self->{MAP_SUB} = $self->_compile_label_add_routine( @label_specs );

   return $self ;
}


sub handle_rev {
   my VCP::Filter::addlabels $self = shift;

   $self->{MAP_SUB}->( @_ );
}

=head1 LIMITATIONS

There is no way (yet) of telling the mapper to continue processing the
rules list.  We could implement labels like C< <<I<label>>> > to be
allowed before pattern expressions (but not between pattern and result),
and we could then impelement C< <<goto I<label>>> >.  And a C< <<next>>
> could be used to fall through to the next label.  All of which is
wonderful, but I want to gain some real world experience with the
current system and find a use case for gotos and fallthroughs before I
implement them.  This comment is here to solicit feedback :).

=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