lib/Clearcase.pm

   1 =pod
   2
   3 =head1 NAME $RCSfile: Clearcase.pm,v $
   4
   5 Object oriented interface to Clearcase.
   6
   7 =head1 VERSION
   8
   9 =over
  10
  11 =item Author
  12
  13 Andrew DeFaria <Andrew@ClearSCM.com>
  14
  15 =item Revision
  16
  17 $Revision: 1.43 $
  18
  19 =item Created
  20
  21 Tue Dec  4 17:33:43 MST 2007
  22
  23 =item Modified
  24
  25 $Date: 2011/11/16 18:27:37 $
  26
  27 =back
  28
  29 =head1 SYNOPSIS
  30
  31 Provides access to global Clearcase information in an object oriented manner as
  32 well as an interface to cleartool.
  33
  34  # Access some compile time global settings:
  35  display "View Drive: $Clearcase::VIEW_DRIVE";
  36  display "Vob Tag Prefix: $Clearcase::VOBTAG_PREFIX";
  37
  38  # Access some run time global information through the default object
  39  display "Client: $Clearcase::CC->client";
  40  display "Region: $Clearcase::CC->region";
  41  display "Registry host: $Clearcase::CC->registry_host";
  42
  43  # List all vobs using execute method of the default object";
  44  my ($status, @vobs) = $Clearcase::CC->execute ("lsvob -s");
  45
  46  display $_ foreach (@vobs) if $status == 0;
  47
  48 =head1 DESCRIPTION
  49
  50 This module, and others below the Clearcase directory, implement an object
  51 oriented approach to Clearcase. In general Clearcase entities are made into
  52 objects that can be manipulated easily in Perl. This module is the main or
  53 global module. Contained herein are members and methods of a general or global
  54 nature. Also contained here is an IPC interface to cleartool such that cleartool
  55 runs in the background and commands are fed to it via the execute method. When
  56 making repeated calls to cleartool this can result in a substantial savings of
  57 time as most operating systems' fork/execute sequence is time consuming. Factors
  58 of 8 fold improvement have been measured.
  59
  60 Additionally a global variable, $CC, is implemented from this module such that
  61 you should not need to instantiate another one, though you could.
  62
  63 =head1 ROUTINES
  64
  65 The following routines are exported:
  66
  67 =cut
  68
  69 package Clearcase;
  70
  71 use strict;
  72 use warnings;
  73
  74 use base 'Exporter';
  75
  76 use Carp;
  77
  78 use IPC::Open3;
  79
  80 use OSDep;
  81 use Display;
  82
  83 my ($clearpid, $clearin, $clearout, $oldHandler, $cleartool);
  84
  85 our $VIEW_DRIVE     = $ENV{CLEARCASE_VIEW_DRIVE} || 'M';
  86 our $VOB_MOUNT      = 'vob';
  87 our $WIN_VOB_PREFIX = '\\';
  88 our $SFX            = $ENV{CLEARCASE_XN_SFX} ? $ENV{CLEARCASE_XN_SFX} : '@@';
  89
  90 our $VOBTAG_PREFIX = ($ARCHITECTURE eq 'windows' or $ARCHITECTURE eq 'cygwin')
  91                    ? $WIN_VOB_PREFIX
  92                    : "/$VOB_MOUNT";
  93 our $VIEWTAG_PREFIX = ($ARCHITECTURE eq 'windows' or $ARCHITECTURE eq 'cygwin')
  94                     ? "$VIEW_DRIVE:"
  95                     : "${SEPARATOR}view";
  96
  97 our ($CCHOME, $COUNTDB);
  98
  99 our $CC;
 100
 101 our @EXPORT_OK = qw (
 102   $CC
 103   $CCHOME
 104   $COUNTDB
 105   $SFX
 106   $VIEW_DRIVE
 107   $VIEWTAG_PREFIX
 108   $VOB_MOUNT
 109   $VOBTAG_PREFIX
 110   $WIN_VOB_PREFIX
 111 );
 112
 113 BEGIN {
 114   # Find executables that we rely on
 115   if ($ARCHITECTURE eq 'windows' or $ARCHITECTURE eq 'cygwin') {
 116     # Should really go to the registry for this...
 117
 118     # We can go to the registry pretty easy in Cygwin but I'm not sure how to do
 119     # that in plain old Windows. Most people either have Clearcase installed on
 120     # the C drive or commonly on the D drive on servers. So we'll look at both.
 121     $CCHOME = 'C:\\Program Files (x86)\\ibm\\RationalSDLC\\Clearcase';
 122
 123     $CCHOME = 'D:\\Program Files (x86)\\ibm\\RationalSDLC\\Clearcase'
 124       unless -d $CCHOME;
 125
 126     error 'Unable to figure out where Clearcase is installed', 1
 127       unless -d $CCHOME;
 128
 129     $COUNTDB = "$CCHOME\\etc\\utils\\countdb.exe";
 130   } else {
 131     $CCHOME  = '/opt/rational/clearcase';
 132     $COUNTDB = "$CCHOME/etc/utils/countdb";
 133   } # if
 134
 135   #error "Unable to find countdb ($COUNTDB)", 2
 136     #if ! -f $COUNTDB;
 137 } # BEGIN
 138
 139 sub DESTROY {
 140   my $exitStatus = $?;
 141
 142   if ($clearpid) {
 143     # Exit cleartool process
 144     print $clearin "exit\n";
 145
 146     waitpid $clearpid, 0;
 147   } # if
 148
 149   local $? = $exitStatus;
 150
 151   # Call old signal handler (if any)
 152   &$oldHandler if $oldHandler;
 153
 154   return;
 155 } # DESTROY
 156
 157 # Save old interrupt handler
 158 $oldHandler = $SIG{INT};
 159
 160 # Set interrupt handler
 161 local $SIG{INT} = \&Clearcase::DESTROY;
 162
 163 sub _formatOpts {
 164   my (%opts) = @_;
 165
 166   my $opts = '';
 167
 168   foreach (keys %opts) {
 169     $opts .= "$_ ";
 170     $opts .= "$opts{$_} "
 171       if $opts{$_} ne '';
 172   } # foreach
 173
 174   return $opts;
 175 } # _formatOpts
 176
 177 sub _setComment ($) {
 178   my ($comment) = @_;
 179
 180   return !$comment ? '-nc' : '-c "' . quotemeta $comment . '"';
 181 } # _setComment
 182
 183 sub vobname ($) {
 184   my ($tag) = @_;
 185
 186 =pod
 187
 188 =head2 vobname ($tag)
 189
 190 Given a vob tag, return the vob name by stripping of the VOBTAG_PREFIX properly
 191 such that you return just the unique vob name. This is tricky because Windows
 192 uses '\' as a VOBTAG_PREFIX. With '\' in there regex's like
 193 /$Clearcase::VOBTAG_PREFIX(.+)/ to capture the vob's name minus the
 194 VOBTAG_PREFIX fail because Perl evaluates this as just a single '\', which
 195 escapes the '(' of the '(.+)'!
 196
 197 Parameters:
 198
 199 =for html <blockquote>
 200
 201 =over
 202
 203 =over
 204
 205 =item $tag
 206
 207 Vob tag to convert
 208
 209 =back
 210
 211 =back
 212
 213 =for html </blockquote>
 214
 215 Returns:
 216
 217 =for html <blockquote>
 218
 219 =over
 220
 221 =over
 222
 223 =item $name
 224
 225 The unique part of the vob name
 226
 227 =back
 228
 229 =back
 230
 231 =for html </blockquote>
 232
 233 =cut
 234
 235   my $name = $tag;
 236
 237   # Special code because Windows $VOBTAG prefix (a \) is such a pain!
 238   if (substr ($tag, 0, 1) eq '\\') {
 239     $name = substr $tag, 1;
 240   } elsif (substr ($tag, 0, 1) eq '/') {
 241     if ($tag =~ /${Clearcase::VOBTAG_PREFIX}\/(.+)/) {
 242       $name = $1;
 243     } # if
 244   } # if
 245
 246   return $name;
 247 } # vobname
 248
 249 sub vobtag ($) {
 250   my ($name) = @_;
 251
 252 =pod
 253
 254 =head2 vobtag ($name)
 255
 256 Given a vob name, add the VOBTAG_PREFIX based on the current OS.
 257
 258 Parameters:
 259
 260 =for html <blockquote>
 261
 262 =over
 263
 264 =over
 265
 266 =item $name
 267
 268 Vob name to convert
 269
 270 =back
 271
 272 =back
 273
 274 =for html </blockquote>
 275
 276 Returns:
 277
 278 =for html <blockquote>
 279
 280 =over
 281
 282 =over
 283
 284 =item $tag
 285
 286 Vob tag
 287
 288 =back
 289
 290 =back
 291
 292 =for html </blockquote>
 293
 294 =cut
 295
 296   # If the $VOBTAG_PREFIX is already there then do nothing
 297   if (substr ($name, 0, length $VOBTAG_PREFIX) eq $VOBTAG_PREFIX) {
 298     return $name;
 299   } else {
 300     return "$VOBTAG_PREFIX$name";
 301   } # if
 302 } # vobtag
 303
 304 sub attributes ($$;%) {
 305   # TODO: Need to handle other options too
 306   my ($self, $type, $name, %newAttribs) = @_;
 307
 308 =pod
 309
 310 =head2 attributes ($type, $name)
 311
 312 Get any attributes attached to the $type:$name
 313
 314 Parameters:
 315
 316 =for html <blockquote>
 317
 318 =over
 319
 320 =over
 321
 322 =item $type
 323
 324 Type of object to look for attributes. For example, activity, baseline, etc.
 325
 326 =item $name
 327
 328 Object name to look for attributes.
 329
 330 =back
 331
 332 =back
 333
 334 =for html </blockquote>
 335
 336 Returns:
 337
 338 =for html <blockquote>
 339
 340 =over
 341
 342 =over
 343
 344 =item %attributes
 345
 346 Hash of attribute name/values
 347
 348 =back
 349
 350 =back
 351
 352 =for html </blockquote>
 353
 354 =cut
 355
 356   my $cmd = "describe -fmt \"%Na\" $type:$name";
 357
 358   my ($status, @output) = $CC->execute ($cmd);
 359
 360   return if $status;
 361
 362   my %attributes;
 363
 364   if ($output[0]) {
 365     # Parse output
 366     my $attributes = $output[0];
 367     my ($name, $value);
 368
 369     while ($attributes ne '') {
 370       if ($attributes =~ /^=(\"*)(.*)/) {
 371         if ($2 =~ /(.*?)$1(\s|$)(.*)/) {
 372           $attributes{$name} = $1;
 373           $attributes        = $3;
 374         } else {
 375           $attributes{$name} = $2;
 376           $attributes        = '';
 377         } # if
 378       } elsif ($attributes =~ /^(\w+)=(.*)/) {
 379         $name       = $1;
 380         $attributes = "=$2";
 381       } else {
 382         croak "Parsing error while parsing " . ref ($self) . " attributes";
 383       } # if
 384     } # while
 385   } # if
 386
 387   # Set any %newAttribs
 388   foreach (keys %newAttribs) {
 389     # TODO: What about other options like -comment?
 390     $cmd  = "mkattr -replace -nc $_ \"";
 391     $cmd .= quotemeta $newAttribs{$_};
 392     $cmd .= "\" $type:$name";
 393
 394     $CC->execute ($cmd);
 395
 396     if ($CC->status) {
 397       die "Unable to execute $cmd (Status: "
 398           . $CC->status . ")\n"
 399           . join ("\n", $CC->output);
 400     } else {
 401       $attributes{$_} = $newAttribs{$_};
 402     } # if
 403   } # foreach
 404
 405   return %attributes;
 406 } # attributes
 407
 408 sub status () {
 409   my ($self) = @_;
 410
 411 =pod
 412
 413 =head2 status ()
 414
 415 Returns the status of the last executed command.
 416
 417 Parameters:
 418
 419 =for html <blockquote>
 420
 421 =over
 422
 423 =over
 424
 425 =item none
 426
 427 =back
 428
 429 =back
 430
 431 =for html </blockquote>
 432
 433 Returns:
 434
 435 =for html <blockquote>
 436
 437 =over
 438
 439 =over
 440
 441 =item $status
 442
 443 Status of the command last executed.
 444
 445 =back
 446
 447 =back
 448
 449 =for html </blockquote>
 450
 451 =cut
 452
 453   return $self->{status};
 454 } # status
 455
 456 sub output () {
 457   my ($self) = @_;
 458
 459 =pod
 460
 461 =head2 output ()
 462
 463 Returns the output of the last executed command.
 464
 465 Parameters:
 466
 467 =for html <blockquote>
 468
 469 =over
 470
 471 =over
 472
 473 =item none
 474
 475 =back
 476
 477 =back
 478
 479 =for html </blockquote>
 480
 481 Returns:
 482
 483 =for html <blockquote>
 484
 485 =over
 486
 487 =over
 488
 489 =item @output or $output
 490
 491 If called in a list context, returns @output, otherwise returns $output.
 492
 493 =back
 494
 495 =back
 496
 497 =for html </blockquote>
 498
 499 =cut
 500
 501   if (wantarray) {
 502     return split /\n/, $self->{output};
 503   } else {
 504     return $self->{output};
 505   } # if
 506 } # output
 507
 508 # TODO: Should implement a pipe call that essentially does a cleartool command
 509 # to a pipe allowing the user to read from the pipe. This will help with such
 510 # cleartool command that may give back huge output or where the user wishes to
 511 # start processing the output as it comes instead of waiting until the cleartool
 512 # command is completely finished. Would like to do something like execute does
 513 # with cleartool running in the background but we need to handle the buffering
 514 # of output sending only whole lines.
 515
 516 sub execute {
 517   my ($self, $cmd) = @_;
 518
 519 =pod
 520
 521 =head2 execute ($cmd)
 522
 523 Sends a command to the cleartool coprocess. If not running a cleartool coprocess
 524 is started and managed. The coprocess is implemented as a coprocess using IPC
 525 for communication that will exist until the object is destroyed. Stdin and
 526 stdout/stderr are therefore pipes and can be fed. The execute method feds the
 527 input pipe and returns status and output from the output pipe.
 528
 529 Using execute can speed up execution of repeative cleartool invocations
 530 substantially.
 531
 532 Parameters:
 533
 534 =for html <blockquote>
 535
 536 =over
 537
 538 =over
 539
 540 =item $cmd
 541
 542 Cleartool command to execute.
 543
 544 =back
 545
 546 =back
 547
 548 =for html </blockquote>
 549
 550 Returns:
 551
 552 =for html <blockquote>
 553
 554 =over
 555
 556 =over
 557
 558 =item $status
 559
 560 Status of the command last executed.
 561
 562 =item @output
 563
 564 Array of output lines from the cleartool command execution.
 565
 566 =back
 567
 568 =back
 569
 570 =for html </blockquote>
 571
 572 =cut
 573
 574   my ($status, @output);
 575
 576   # This seems to be how most people locate cleartool. On Windows (this
 577   # includes Cygwin) we assume it's in our path. On Unix/Linux we assume it's
 578   # installed under /opt/rational/clearcase/bin. This is needed in case we wish
 579   # to use these Clearcase objects say in a web page where the server is often
 580   # run as a plain user who does not have cleartool in their path.
 581   unless ($cleartool) {
 582     if ($ARCHITECTURE =~ /Win/i or $ARCHITECTURE eq 'cygwin') {
 583       $cleartool = 'cleartool';
 584     } elsif (-x '/opt/rational/clearcase/bin/cleartool') {
 585       $cleartool = '/opt/rational/clearcase/bin/cleartool';
 586     } # if
 587   } # unless
 588
 589   # TODO: Need to catch SIGCHILD here in case the user does something like hit
 590   # Ctrl-C. Such an action may interrupt the underlying cleartool process and
 591   # kill it. But we would be unaware (i.e. $clearpid would still be set). So
 592   # when SIGCHILD is caught we need to undef $clearpid.
 593   if (!$clearpid) {
 594     # Simple check to see if we can execute cleartool
 595     @output = `$cleartool -ver 2>&1`;
 596
 597     return (-1, 'Clearcase not installed')
 598       unless $? == 0;
 599
 600     $clearpid = open3 ($clearin, $clearout, $clearout, $cleartool, "-status");
 601
 602     return (-1, ('Clearcase not installed')) unless $clearpid;
 603   } # if
 604
 605   # Execute command
 606   print $clearin "$cmd\n";
 607
 608   # Now read output from $clearout and format the lines in to an array. Also
 609   # capture the status code to return it.
 610   while (my $line = <$clearout>) {
 611     if ($line !~ /(.*)Command \d+ returned status (\d+)/sm) {
 612       push @output, $line;
 613     } else {
 614       push @output, $1;
 615       $status = $2;
 616       last;
 617     } # if
 618   } # while
 619
 620   if (@output) {
 621     chomp @output;
 622     chop @output if $output[0] =~ /\r$/;
 623   } # if
 624
 625   # We're getting extra blank lines at the bottom of @output. Not sure why
 626   # but we need to remove it
 627   pop @output
 628     if @output and $output[$#output] eq '';
 629
 630   $self->{lastcmd} = 'cleartool ' . $cmd;
 631   $self->{status}  = $status;
 632   $self->{output}  = join "\n", @output;
 633
 634   return ($status, @output);
 635 } # execute
 636
 637 sub lastcmd() {
 638   my ($self) = @_;
 639
 640 =pod
 641
 642 =head2 lastcmd()
 643
 644 Return last command attempted by execute
 645
 646 Parameters:
 647
 648 =for html <blockquote>
 649
 650 =over
 651
 652 =item none
 653
 654 =back
 655
 656 =for html </blockquote>
 657
 658 Returns:
 659
 660 =for html <blockquote>
 661
 662 =over
 663
 664 =item Last command attempted by execute
 665
 666 =back
 667
 668 =for html </blockquote>
 669
 670 =cut
 671
 672   $self->{lastcmd} ||= '';
 673
 674   return $self->{lastcmd};
 675 } # lastcmd
 676
 677 sub new {
 678   my ($class) = @_;
 679
 680 =pod
 681
 682 =head2 new ()
 683
 684 Construct a new Clearcase object. Note there is already a default
 685 Clearcase object created named $cc. You should use that unless you
 686 have good reason to instantiate another Clearcase object.
 687
 688 Parameters:
 689
 690 =for html <blockquote>
 691
 692 =over
 693
 694 =item none
 695
 696 =back
 697
 698 =for html </blockquote>
 699
 700 Returns:
 701
 702 =for html <blockquote>
 703
 704 =over
 705
 706 =item Clearcase object
 707
 708 =back
 709
 710 =for html </blockquote>
 711
 712 =cut
 713
 714   # Attributes
 715   my (
 716     $registry_host,
 717     $version,
 718     @regions,
 719   );
 720
 721   my $self = bless {
 722     registry_host  => $registry_host,
 723     version        => $version,
 724     verbose_level  => 0,
 725     vobtag_prefix  => $VOBTAG_PREFIX,
 726     viewtag_prefix => $VIEWTAG_PREFIX,
 727     regions        => \@regions,
 728   }, $class;
 729
 730   # Get list of regions
 731   my ($status, @output);
 732
 733   ($status, @regions) = $self->execute ('lsregion');
 734
 735   return $self
 736     if $status;
 737
 738   # Get hostinfo attributes
 739   ($status, @output) = $self->execute ('hostinfo -long');
 740
 741   return $self
 742     if $status;
 743
 744   foreach (@output) {
 745     if (/Client: (.*)/) {
 746       $self->{client} = lc $1;
 747     } elsif (/Product: (.*)/) {
 748       $self->{version} = $1;
 749     } elsif (/Operating system: (.*)/) {
 750       $self->{os} = $1;
 751     } elsif (/Hardware type: (.*)/) {
 752       $self->{hardware_type} = $1;
 753     } elsif (/Registry host: (.*)/) {
 754       $self->{registry_host} = $1;
 755     } elsif (/Registry region: (.*)/) {
 756       $self->{region}         = $1;
 757       $self->{sitename}       = $1;
 758
 759       if ($self->{region} =~ /(\S*)(NT|UNIX)$/) {
 760         $self->{sitename} = $1;
 761       } # if
 762     } elsif (/License host: (.*)/) {
 763       $self->{license_host} = $1;
 764     } # if
 765   } # foreach
 766
 767   return $self;
 768 } # new
 769
 770 # Member access methods...
 771
 772 sub client {
 773   my ($self) = @_;
 774
 775 =pod
 776
 777 =head2 client
 778
 779 Returns the client
 780
 781 Parameters:
 782
 783 =for html <blockquote>
 784
 785 =over
 786
 787 =item none
 788
 789 =back
 790
 791 =for html </blockquote>
 792
 793 Returns:
 794
 795 =for html <blockquote>
 796
 797 =over
 798
 799 =item client
 800
 801 =back
 802
 803 =for html </blockquote>
 804
 805 =cut
 806
 807   return $self->{client};
 808 } # client
 809
 810 sub hardware_type {
 811   my ($self) = @_;
 812
 813 =pod
 814
 815 =head2 hardware_type
 816
 817 Returns the hardware_type
 818
 819 Parameters:
 820
 821 =for html <blockquote>
 822
 823 =over
 824
 825 =item none
 826
 827 =back
 828
 829 =for html </blockquote>
 830
 831 Returns:
 832
 833 =for html <blockquote>
 834
 835 =over
 836
 837 =item hardware_type
 838
 839 =back
 840
 841 =for html </blockquote>
 842
 843 =cut
 844
 845   return $self->{hardware_type};
 846 } # hardware_type
 847
 848 sub license_host {
 849   my ($self) = @_;
 850
 851 =pod
 852
 853 =head2 license_host
 854
 855 Returns the license_host
 856
 857 Parameters:
 858
 859 =for html <blockquote>
 860
 861 =over
 862
 863 =item none
 864
 865 =back
 866
 867 =for html </blockquote>
 868
 869 Returns:
 870
 871 =for html <blockquote>
 872
 873 =over
 874
 875 =item license_host
 876
 877 =back
 878
 879 =for html </blockquote>
 880
 881 =cut
 882
 883   return $self->{license_host};
 884 } # license_host
 885
 886 sub os {
 887   my ($self) = @_;
 888
 889 =pod
 890
 891 =head2 os
 892
 893 Returns the os
 894
 895 Parameters:
 896
 897 =for html <blockquote>
 898
 899 =over
 900
 901 =item none
 902
 903 =back
 904
 905 =for html </blockquote>
 906
 907 Returns:
 908
 909 =for html <blockquote>
 910
 911 =over
 912
 913 =item os
 914
 915 =back
 916
 917 =for html </blockquote>
 918
 919 =cut
 920
 921   return $self->{os};
 922 } # os
 923
 924 sub region {
 925   my ($self) = @_;
 926
 927 =pod
 928
 929 =head2 region
 930
 931 Returns the region
 932
 933 Parameters:
 934
 935 =for html <blockquote>
 936
 937 =over
 938
 939 =item none
 940
 941 =back
 942
 943 =for html </blockquote>
 944
 945 Returns:
 946
 947 =for html <blockquote>
 948
 949 =over
 950
 951 =item region
 952
 953 =back
 954
 955 =for html </blockquote>
 956
 957 =cut
 958
 959   return $self->{region};
 960 } # region
 961
 962 sub registry_host {
 963   my ($self) = @_;
 964
 965 =pod
 966
 967 =head2 registry_host
 968
 969 Returns the registry_host
 970
 971 Parameters:
 972
 973 =for html <blockquote>
 974
 975 =over
 976
 977 =item none
 978
 979 =back
 980
 981 =for html </blockquote>
 982
 983 Returns:
 984
 985 =for html <blockquote>
 986
 987 =over
 988
 989 =item client string
 990
 991 =back
 992
 993 =for html </blockquote>
 994
 995 =cut
 996
 997   return $self->{registry_host};
 998 } # registry_host
 999
1000 sub sitename {
1001   my ($self) = @_;
1002
1003 =pod
1004
1005 =head2 sitename
1006
1007 Returns the sitename
1008
1009 Parameters:
1010
1011 =for html <blockquote>
1012
1013 =over
1014
1015 =item none
1016
1017 =back
1018
1019 =for html </blockquote>
1020
1021 Returns:
1022
1023 =for html <blockquote>
1024
1025 =over
1026
1027 =item sitename
1028
1029 =back
1030
1031 =for html </blockquote>
1032
1033 =cut
1034
1035   return $self->{sitename};
1036 } # sitename
1037
1038 sub version {
1039   my ($self) = @_;
1040
1041 =pod
1042
1043 =head2 version
1044
1045 Returns the version
1046
1047 Parameters:
1048
1049 =for html <blockquote>
1050
1051 =over
1052
1053 =item none
1054
1055 =back
1056
1057 =for html </blockquote>
1058
1059 Returns:
1060
1061 =for html <blockquote>
1062
1063 =over
1064
1065 =item version
1066
1067 =back
1068
1069 =for html </blockquote>
1070
1071 =cut
1072
1073   return $self->{version};
1074 } # version
1075
1076 sub regions {
1077   my ($self) = @_;
1078
1079 =pod
1080
1081 =head2 regions
1082
1083 Returns an array of regions in an array context or the number of
1084 regions in a scalar context
1085
1086 Parameters:
1087
1088 =for html <blockquote>
1089
1090 =over
1091
1092 =item none
1093
1094 =back
1095
1096 =for html </blockquote>
1097
1098 Returns:
1099
1100 =for html <blockquote>
1101
1102 =over
1103
1104 =item array of regions or number of regions
1105
1106 =back
1107
1108 =for html </blockquote>
1109
1110 =cut
1111
1112   if (wantarray) {
1113     my @returnArray = sort @{$self->{regions}};
1114
1115     return @returnArray;
1116   } else {
1117     return scalar @{$self->{regions}};
1118   } # if
1119 } # regions
1120
1121 sub pwv () {
1122   my ($self) = @_;
1123
1124 =pod
1125
1126 =head2 pwv
1127
1128 Returns the current working view or undef if not in a view
1129
1130 Parameters:
1131
1132 =for html <blockquote>
1133
1134 =over
1135
1136 =item none
1137
1138 =back
1139
1140 =for html </blockquote>
1141
1142 Returns:
1143
1144 =for html <blockquote>
1145
1146 =over
1147
1148 =item Current working view or undef if none
1149
1150 =back
1151
1152 =for html </blockquote>
1153
1154 =cut
1155
1156   my ($status, @output) = $self->execute ('pwv -short');
1157
1158   return if $status;
1159   return $output[0] eq '** NONE **' ? undef : $output[0];
1160 } # pwv
1161
1162 sub name2oid ($;$) {
1163   my ($self, $name, $vob) = @_;
1164
1165 =pod
1166
1167 =head2 name2oid
1168
1169 Returns the oid for a given name
1170
1171 Parameters:
1172
1173 =for html <blockquote>
1174
1175 =over
1176
1177 =item name
1178
1179 The name to convert (unless filesystem object it should contain a type:)
1180
1181 =item vob
1182
1183 The vob the name belongs to
1184
1185 =back
1186
1187 =for html </blockquote>
1188
1189 Returns:
1190
1191 =for html <blockquote>
1192
1193 =over
1194
1195 =item OID
1196
1197 =back
1198
1199 =for html </blockquote>
1200
1201 =cut
1202
1203   if ($vob) {
1204     $vob = '@' . vobtag $vob;
1205   } else {
1206     $vob = '';
1207   } # if
1208
1209   my ($status, @output) = $self->execute ("dump $name$vob");
1210
1211   return if $status;
1212
1213   @output = grep { /^oid=/ } @output;
1214
1215   if ($output[0] =~ /oid=(\S+)\s+/) {
1216     return $1;
1217   } else {
1218     return;
1219   } # if
1220 } # name2oid
1221
1222 sub oid2name ($$) {
1223   my ($self, $oid, $vob) = @_;
1224
1225 =pod
1226
1227 =head2 oid2name
1228
1229 Returns the object name for the given oid
1230
1231 Parameters:
1232
1233 =for html <blockquote>
1234
1235 =over
1236
1237 =item oid
1238
1239 The OID to convert
1240
1241 =item vob
1242
1243 The vob the OID belongs to
1244
1245 =back
1246
1247 =for html </blockquote>
1248
1249 Returns:
1250
1251 =for html <blockquote>
1252
1253 =over
1254
1255 =item String representing the OID's textual name/value
1256
1257 =back
1258
1259 =for html </blockquote>
1260
1261 =cut
1262
1263   $vob = vobtag $vob
1264     unless $vob =~ /^vobuuid:/;
1265
1266   my ($status, @output) = $self->execute (
1267     "describe -fmt \"%n\" oid:$oid\@$vob"
1268   );
1269
1270   return if $status;
1271   return $output[0];
1272 } # oid2name
1273
1274 sub verbose_level {
1275   my ($self) = @_;
1276
1277 =pod
1278
1279 =head2 verbose_level
1280
1281 Returns the verbose_level
1282
1283 Parameters:
1284
1285 =for html <blockquote>
1286
1287 =over
1288
1289 =item none
1290
1291 =back
1292
1293 =for html </blockquote>
1294
1295 Returns:
1296
1297 =for html <blockquote>
1298
1299 =over
1300
1301 =item verbose_level
1302
1303 =back
1304
1305 =for html </blockquote>
1306
1307 =cut
1308
1309   return $self->{verbose_level};
1310 } # verbose_level
1311
1312 sub quiet {
1313   my ($self) = @_;;
1314
1315 =pod
1316
1317 =head2 quiet
1318
1319 Sets verbose_level to quiet
1320
1321 Parameters:
1322
1323 =for html <blockquote>
1324
1325 =over
1326
1327 =item none
1328
1329 =back
1330
1331 =for html </blockquote>
1332
1333 Returns:
1334
1335 =for html <blockquote>
1336
1337 =over
1338
1339 =item none
1340
1341 =back
1342
1343 =for html </blockquote>
1344
1345 =cut
1346
1347   $self->{verbose_level} = 0;
1348
1349   return;
1350 } # quiet
1351
1352 sub noisy {
1353   my ($self) = @_;
1354
1355 =pod
1356
1357 =head2 noisy
1358
1359 Sets verbose_level to noisy
1360
1361 Parameters:
1362
1363 =for html <blockquote>
1364
1365 =over
1366
1367 =item none
1368
1369 =back
1370
1371 =for html </blockquote>
1372
1373 Returns:
1374
1375 =for html <blockquote>
1376
1377 =over
1378
1379 =item none
1380
1381 =back
1382
1383 =for html </blockquote>
1384
1385 =cut
1386
1387   $self->{verbose_level} = 1;
1388
1389   return;
1390 } # noisy
1391
1392 $CC = Clearcase->new;
1393
1394 1;
1395
1396 =pod
1397
1398 =head1 DEPENDENCIES
1399
1400 =head2 Perl Modules
1401
1402 L<IPC::Open3|IPC::Open3>
1403
1404 =head2 ClearSCM Perl Modules
1405
1406 =for html <p><a href="/php/scm_man.php?file=lib/Display.pm">Display</a></p>
1407
1408 =for html <p><a href="/php/scm_man.php?file=lib/OSDep.pm">OSdep</a></p>
1409
1410 =head1 BUGS AND LIMITATIONS
1411
1412 There are no known bugs in this module
1413
1414 Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
1415
1416 =head1 LICENSE AND COPYRIGHT
1417
1418 Copyright (c) 2007, ClearSCM, Inc. All rights reserved.
1419
1420 =cut