File Coverage

blib/lib/ClearCase/Wrapper.pm

Criterion	Covered	Total	%
statement	81	131	61.8
branch	15	66	22.7
condition	2	11	18.1
subroutine	15	20	75.0
pod	0	5	0.0
total	113	233	48.5

package ClearCase::Wrapper;

$VERSION = '1.19';

require 5.006;

use AutoLoader 'AUTOLOAD';
use B;
use strict;
use warnings;

use vars qw(%Packages %ExtMap $libdir $prog $dieexit $dieexec $diemexec);

# Inherit some symbols from the main package. We will later "donate"
# these to all overlay packages as well.
BEGIN {
    *prog = \$::prog;
    *dieexit = \$::dieexit;
    *dieexec = \$::dieexec;
    *diemexec = \$::diemexec;
}

# For some reason this can't be handled the same as $prog above ...
use constant MSWIN => $^O =~ /MSWin|Windows_NT/i ? 1 : 0;

# This is the list of functions we want to export to overlay pkgs.
my @exports = qw(MSWIN GetOptions Assert Burrow Msg Pred ViewTag
                AutoCheckedOut AutoNotCheckedOut AutoViewPrivate);

# Hacks for portability with Windows env vars.
BEGIN {
    $ENV{LOGNAME} ||= $ENV{USERNAME};
    $ENV{HOME} ||= "$ENV{HOMEDRIVE}/$ENV{HOMEPATH}";
}

# Unless the user has their own CLEARCASE_PROFILE, set it to the global one.
BEGIN {
    # Learn where this module was found so we can look there for other files.
    ($libdir = $INC{'ClearCase/Wrapper.pm'}) =~ s%\.pm$%%;

    if (defined $ENV{CLEARCASE_PROFILE}) {
      $ENV{_CLEARCASE_WRAPPER_PROFILE} = $ENV{CLEARCASE_PROFILE};
    } elsif ($ENV{_CLEARCASE_WRAPPER_PROFILE}) {
      $ENV{CLEARCASE_PROFILE} = $ENV{_CLEARCASE_WRAPPER_PROFILE};
    } elsif (! -f "$ENV{HOME}/.clearcase_profile") {
      my $rc = join('/', $libdir, 'clearcase_profile');
      $ENV{CLEARCASE_PROFILE} = $rc if -r $rc;
    }
}

# Skip the Getopt::Long->import(), we need our own GetOptions().
require Getopt::Long;

# Getopt::Long::GetOptions() respects '--' but strips it, while
# we want to respect '--' and leave it in. Thus this override.
sub GetOptions {
    @ARGV = map {/^--$/ ? qw(=--= --) : $_} @ARGV;
    my $ret = Getopt::Long::GetOptions(@_);
    @ARGV = map {/^=--=$/ ? qw(--) : $_} @ARGV;
    return $ret;
}

# Technically we should use Getopt::Long::Configure() for these but
# there's a tangled version history and this is faster anyway.
$Getopt::Long::passthrough = 1; # required for wrapper programs
$Getopt::Long::ignorecase = 0;  # global override for dumb default

# Any subroutine declared in a module located via this code
# will eclipse one of the same name declared above.
## NOTE: functions defined in modules found here should not
## be placed directly into ClearCase::Wrapper. They MUST be
## placed in the standard package analogous to their pathname
## (e.g. ClearCase::Wrapper::Foo). Magic occurs here to get
## them into ClearCase::Wrapper where they belong.
sub _FindAndLoadModules {
    my ($dir, $subdir) = @_;
    # Not sure how glob() sorts so force a standard order.
    my @pms = sort glob("$dir/$subdir/*.pm");
    for my $pm (@pms) {
      my $dirQuoted = quotemeta($dir);
      $pm =~ s%^$dirQuoted/(.*)\.pm$%$1%;
      (my $pkg = $pm) =~ s%[/\\]+%::%g;
      eval "*${pkg}::exit = \$dieexit";
      eval "*${pkg}::exec = \$dieexec";

      # In this block we temporarily enter the overlay's package
      # just in case the overlay module forgot its package stmt.
      # We then require the overlay file and also, if it's
      # an autoloaded module (which is recommended), we drag
      # in the index file too. This is because we need to
      # derive a list of all functions defined in the overlay
      # in order to import them to our own namespace.
      {
          eval qq(package $pkg); # default the pkg correctly
          no warnings qw(redefine);
          eval {
            eval "require $pkg";
            warn $@ if $@;
          };
          next if $@;
          my $ix = "auto/$pm/autosplit.ix";
          if (-e "$dir/$ix") {
            eval { require $ix };
            warn $@ if $@;
          }
      }

      # Now the overlay module is read in. We need to examine its
      # newly-created symbol table, determine which functions
      # it defined, and import them here. The same basic thing is
      # done for the base package later.
      no strict 'refs';
      my %names = %{"${pkg}::"};
      for (keys %names) {
          # Skip symbols that can't be names of valid cleartool ops.
          next if m%^(?:_?[A-Z]|__|[ab]$)%;
          my $tglob = "${pkg}::$_";
          my $coderef = \&{$tglob};
          next unless ref $coderef;
          my $cv = B::svref_2object($coderef);
          next unless $cv->isa('B::CV');
          next if $cv->GV->isa('B::SPECIAL');
          my $p = $cv->GV->STASH->NAME;
          next unless $p eq $pkg;

          # Take what survives the above tests and create a hash
          # mapping defined functions to the pkg that defines them.
          $ExtMap{$_} = $pkg;
          # We import the entire typeglob for 'foo' when we
          # find an extension func named foo(). This allows usage
          # msg extensions (in the form $foo) to come over too.
          eval qq(*$_ = *$tglob);
      }

      # The base module defines a few functions which the
      # overlay's code might want to use. Make aliases
      # for those in the overlay's symbol table.
      for (@exports) {
          eval "*${pkg}::$_ = \\&$_";
      }
      eval "*${pkg}::prog = \\\$prog";

      $Packages{$pkg} = $INC{"$pm.pm"};
    }
}
for my $subdir (qw(ClearCase/Wrapper ClearCase/Wrapper/Site)) {
    for my $dir (@INC) {
      _FindAndLoadModules($dir, $subdir);
    }
}

$Packages{'ClearCase::Wrapper'} = __FILE__;

# Piggyback on the -ver flag to show our version too.
if (@ARGV && $ARGV[0] =~ /^-ver/i) {
    my $fmt = "*%-32s %s (%s)\n";
    local $| = 1;
    for (sort keys %Packages) {
      my $ver = eval "\$$_\::VERSION" || '????';
      my $mtime = localtime((stat $Packages{$_})[9]);
      printf $fmt, $_, $ver, $mtime || '----';
    }
    exit 0 if $ARGV[0] =~ /^-verw/i;
}

# Take a string and an array, return the index of the 1st occurrence
# of the string in the array.
sub _FirstIndex {
    my $flag = shift;
    for my $i (0..$#_) {
       return $i if $flag eq $_[$i];
    }
    return undef;
}

# Implements the -me -tag convention (see POD).
if (my $me = _FirstIndex('-me', @ARGV)) {
    if ($ARGV[0] =~ /^(?:set|start|end)view$|^rdl$|^work/) {
      my $delim = 0;
      for (@ARGV) {
          last if /^--$/;
          $delim++;
      }
      for (reverse @ARGV[0..$delim-1]) {
          if (/^\w+$/) {
            $_ = join('_', $ENV{LOGNAME}, $_);
            last;
          }
      }
      splice(@ARGV, $me, 1);
    } elsif (my $tag = _FirstIndex('-tag', @ARGV)) {
      $ARGV[$tag+1] = join('_', $ENV{LOGNAME}, $ARGV[$tag+1]);
      splice(@ARGV, $me, 1);
    }
}

# Implements the -M flag (see POD).
if (my $mflag = _FirstIndex('-M', @ARGV) || $ENV{CLEARCASE_WRAPPER_PAGER}) {
    splice(@ARGV, $mflag, 1) if $mflag && !$ENV{CLEARCASE_WRAPPER_PAGER};
    pipe(READER, WRITER);
    my $pid;
    if ($pid = fork) {
      close WRITER;
      open(STDIN, ">&READER") || die Msg('E', "STDIN: $!");
      my $pager = $ENV{CLEARCASE_WRAPPER_PAGER} || $ENV{PAGER};
      if (!$pager) {
          require Config;
          $pager = $Config::Config{pager} || 'more';
      }
      exec $pager || warn Msg('W', "can't run $pager: $!");
    } else {
      die Msg('E', "can't fork") if !defined($pid);
      close READER;
      open(STDOUT, ">&WRITER") || die Msg('E', "STDOUT: $!");
    }
}

# Implements the -P flag to pause after a GUI operation.
if (my $pflag = _FirstIndex('-P', @ARGV)) {
    splice(@ARGV, $pflag, 1);
    if (MSWIN) {
      eval "END { system qw(cmd /c pause) }";
    } else {
      my $foo = ;
    }
}

#############################################################################
# Usage Message Extensions
#############################################################################
{
   no strict 'vars';

   # Extended messages for actual cleartool commands that we extend.
   $checkin      = "\n* [-dir|-rec|-all|-avobs] [-ok] [-diff [diff-opts]]" .
                  "\n* [-revert [-mkhlink]]";
   $checkout      = "\n* [-dir|-rec] [-ok]";
   $diff      = "\n* [-] [-dir|-rec|-all|-avobs]";
   $diffcr      = "\n* [-data]";
   $lsprivate      = "\n* [-dir|-rec|-all] [-ecl/ipsed] [-type d|f]" .
              "\n* [-rel/ative] [-ext] [pname]";
   $lsview      = "\n* [-me]";
   $mkelem      = "\n* [-dir|-rec] [-do] [-ok]";
   $uncheckout      = " * [-nc]";

   # Extended messages for pseudo cleartool commands that we implement here.
   my $z = $ARGV[0] || '';
   $edit      = "$z  [-ci]  pname ...";
   $extensions      = "$z [-long]";
}

#############################################################################
# Command Aliases
#############################################################################
*ci            = *checkin;
*co            = *checkout;
*lsp            = *lsprivate;
*lspriv            = *lsprivate;
*unco            = *uncheckout;
*vi            = *edit;

#############################################################################
# Allow per-user configurability. Give the individual access to @ARGV just
# before we hand it off to the local wrapper function and/or cleartool.
# Access to this feature is suppressed if the 'NO_OVERRIDES' file exists.
#############################################################################
if (-r "$ENV{HOME}/.clearcase_profile.pl" && ! -e "$libdir/NO_OVERRIDES") {
    require "$ENV{HOME}/.clearcase_profile.pl";
    no warnings qw(redefine);
    *Argv::exec = $diemexec;
}

# Add to ExtMap the names of extensions defined in the base package.
for (keys %ClearCase::Wrapper::) {
    # Skip functions that can't be names of valid cleartool ops.
    next if m%^(?:_?[A-Z]|__)%;
    # Skip typeglobs that don't involve functions.
    my $tglob = "ClearCase::Wrapper::$_";
    next unless ref \&{$tglob};
    # Take what survives the above tests and create a hash
    # mapping defined functions to the pkg that defines them.
    $ExtMap{$_} ||= __PACKAGE__;
}

# Returns undefined if  is not being extended and returns the
# package that extends it otherwise. Potentially useful for extension
# writers.
sub Extension {
    my $op = shift;
    return $ExtMap{$op};
}

# Returns the full name of a command, whether native or not; unchanged in error
sub Canonic {
    my $op = shift;
    my $tglob = $ExtMap{$op} . "::" . $op;
    my $coderef = \&{$tglob};
    return $op unless ref $coderef;
    my $cv = B::svref_2object($coderef);
    return $cv->GV->NAME;
}

# Returns a boolean indicating whether the named cmd is native to
# CC or not. Note: the first call to this func has a "cost" of one
# "cleartool help" operation; subsequent calls are free.
{
    my %native;
    sub Native {
      my $op = shift;
      return 1 if $op =~ m%^lsp(riv)?%;
      if (! $op) {
          ($op = (caller(1))[3]) =~ s%.*:%%;
      }
      if (! keys %native) {
          my @usg = grep /^Usage:/, ClearCase::Argv->help->qx;
          for (@usg) {
            if (/^Usage:\s*(\w+)\s*(\|\s*(\w+))?/) {
                $native{$1} = 1 if $1;
                $native{$3} = 1 if $3;
            }
          }
      }
      if (exists($native{$op})) {
          return 1;
      } elsif ($op =~ m%^(?:des|lsh)%) {
          return 1;
      } else {
          return 0;
      }
    }
}

# This is an enhancement like the ones below but is kept "above the
# fold" because wrapping of cleartool man is an integral and generic
# part of the module. It runs "cleartool man " as requested,
# followed by "perldoc ClearCase::Wrapper" iff  is extended below.
sub man {
    $_ = Canonic($_) for @ARGV[1..$#ARGV];
    my $page = (grep !/^-/, @ARGV)[1];
    return 0 unless $page;
    ClearCase::Argv->new(@ARGV)->system if Native($page);
    if (exists($ClearCase::Wrapper::{$page})) {
      # This EV hack causes perldoc to search for the right keyword
      # within the module's perldoc.
      if (!MSWIN) {
          require Config;
          my $pager = $Config::Config{pager};
          $ENV{PERLDOC_PAGER} ||= "$pager +/" . uc($page)
            if $pager =~ /more|less/;
      }
    } elsif ($page ne $::prog) {
      if (!Native($page)) {
          ClearCase::Argv->new(@ARGV)->exec;
      } else {
          exit($? ? 1 : 0);
      }
    }
    my $psep = MSWIN ? ';' : ':';
    require File::Basename;
    $ENV{PATH} = join($psep, File::Basename::dirname($^X), $ENV{PATH});
    my $module = $ExtMap{$page} || __PACKAGE__;
    Argv->perldoc($module)->exec;
    exit $?;
}

1;

__END__