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     = '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:\\IBMRational\\RationalSDLC\\Clearcase';
 122
 123     $CCHOME = 'D:\\IBMRational\\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 feeds 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/ 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     @output = ();
 597
 598     return (-1, 'Clearcase not installed')
 599       unless $? == 0;
 600
 601     $clearpid = open3 ($clearin, $clearout, $clearout, $cleartool, "-status");
 602
 603     return (-1, ('Clearcase not installed')) unless $clearpid;
 604   } # if
 605
 606   # Execute command
 607   print $clearin "$cmd\n";
 608
 609   # Now read output from $clearout and format the lines in to an array. Also
 610   # capture the status code to return it.
 611   while (my $line = <$clearout>) {
 612     if ($line !~ /(.*)Command \d+ returned status (\d+)/sm) {
 613       push @output, $line;
 614     } else {
 615       push @output, $1;
 616       $status = $2;
 617       last;
 618     } # if
 619   } # while
 620
 621   if (@output) {
 622     chomp @output;
 623     chop @output if $output[0] =~ /\r$/;
 624   } # if
 625
 626   # We're getting extra blank lines at the bottom of @output. Not sure why
 627   # but we need to remove it
 628   pop @output
 629     if @output and $output[$#output] eq '';
 630
 631   $self->{lastcmd} = 'cleartool ' . $cmd;
 632   $self->{status}  = $status;
 633   $self->{output}  = join "\n", @output;
 634
 635   return ($status, @output);
 636 } # execute
 637
 638 sub lastcmd() {
 639   my ($self) = @_;
 640
 641 =pod
 642
 643 =head2 lastcmd()
 644
 645 Return last command attempted by execute
 646
 647 Parameters:
 648
 649 =for html <blockquote>
 650
 651 =over
 652
 653 =item none
 654
 655 =back
 656
 657 =for html </blockquote>
 658
 659 Returns:
 660
 661 =for html <blockquote>
 662
 663 =over
 664
 665 =item Last command attempted by execute
 666
 667 =back
 668
 669 =for html </blockquote>
 670
 671 =cut
 672
 673   $self->{lastcmd} ||= '';
 674
 675   return $self->{lastcmd};
 676 } # lastcmd
 677
 678 sub new {
 679   my ($class) = @_;
 680
 681 =pod
 682
 683 =head2 new ()
 684
 685 Construct a new Clearcase object. Note there is already a default
 686 Clearcase object created named $cc. You should use that unless you
 687 have good reason to instantiate another Clearcase object.
 688
 689 Parameters:
 690
 691 =for html <blockquote>
 692
 693 =over
 694
 695 =item none
 696
 697 =back
 698
 699 =for html </blockquote>
 700
 701 Returns:
 702
 703 =for html <blockquote>
 704
 705 =over
 706
 707 =item Clearcase object
 708
 709 =back
 710
 711 =for html </blockquote>
 712
 713 =cut
 714
 715   # Attributes
 716   my (
 717     $registry_host,
 718     $version,
 719     @regions,
 720   );
 721
 722   my $self = bless {
 723     registry_host  => $registry_host,
 724     version        => $version,
 725     verbose_level  => 0,
 726     vobtag_prefix  => $VOBTAG_PREFIX,
 727     viewtag_prefix => $VIEWTAG_PREFIX,
 728     regions        => \@regions,
 729   }, $class;
 730
 731   # Get list of regions
 732   my ($status, @output);
 733
 734   ($status, @regions) = $self->execute ('lsregion');
 735
 736   return $self
 737     if $status;
 738
 739   # Get hostinfo attributes
 740   ($status, @output) = $self->execute ('hostinfo -long');
 741
 742   return $self
 743     if $status;
 744
 745   foreach (@output) {
 746     if (/Client: (.*)/) {
 747       $self->{client} = lc $1;
 748     } elsif (/Product: (.*)/) {
 749       $self->{version} = $1;
 750     } elsif (/Operating system: (.*)/) {
 751       $self->{os} = $1;
 752     } elsif (/Hardware type: (.*)/) {
 753       $self->{hardware_type} = $1;
 754     } elsif (/Registry host: (.*)/) {
 755       $self->{registry_host} = $1;
 756     } elsif (/Registry region: (.*)/) {
 757       $self->{region}         = $1;
 758       $self->{sitename}       = $1;
 759
 760       if ($self->{region} =~ /(\S*)(NT|UNIX)$/) {
 761         $self->{sitename} = $1;
 762       } # if
 763     } elsif (/License host: (.*)/) {
 764       $self->{license_host} = $1;
 765     } # if
 766   } # foreach
 767
 768   return $self;
 769 } # new
 770
 771 # Member access methods...
 772
 773 sub client {
 774   my ($self) = @_;
 775
 776 =pod
 777
 778 =head2 client
 779
 780 Returns the client
 781
 782 Parameters:
 783
 784 =for html <blockquote>
 785
 786 =over
 787
 788 =item none
 789
 790 =back
 791
 792 =for html </blockquote>
 793
 794 Returns:
 795
 796 =for html <blockquote>
 797
 798 =over
 799
 800 =item client
 801
 802 =back
 803
 804 =for html </blockquote>
 805
 806 =cut
 807
 808   return $self->{client};
 809 } # client
 810
 811 sub hardware_type {
 812   my ($self) = @_;
 813
 814 =pod
 815
 816 =head2 hardware_type
 817
 818 Returns the hardware_type
 819
 820 Parameters:
 821
 822 =for html <blockquote>
 823
 824 =over
 825
 826 =item none
 827
 828 =back
 829
 830 =for html </blockquote>
 831
 832 Returns:
 833
 834 =for html <blockquote>
 835
 836 =over
 837
 838 =item hardware_type
 839
 840 =back
 841
 842 =for html </blockquote>
 843
 844 =cut
 845
 846   return $self->{hardware_type};
 847 } # hardware_type
 848
 849 sub license_host {
 850   my ($self) = @_;
 851
 852 =pod
 853
 854 =head2 license_host
 855
 856 Returns the license_host
 857
 858 Parameters:
 859
 860 =for html <blockquote>
 861
 862 =over
 863
 864 =item none
 865
 866 =back
 867
 868 =for html </blockquote>
 869
 870 Returns:
 871
 872 =for html <blockquote>
 873
 874 =over
 875
 876 =item license_host
 877
 878 =back
 879
 880 =for html </blockquote>
 881
 882 =cut
 883
 884   return $self->{license_host};
 885 } # license_host
 886
 887 sub os {
 888   my ($self) = @_;
 889
 890 =pod
 891
 892 =head2 os
 893
 894 Returns the os
 895
 896 Parameters:
 897
 898 =for html <blockquote>
 899
 900 =over
 901
 902 =item none
 903
 904 =back
 905
 906 =for html </blockquote>
 907
 908 Returns:
 909
 910 =for html <blockquote>
 911
 912 =over
 913
 914 =item os
 915
 916 =back
 917
 918 =for html </blockquote>
 919
 920 =cut
 921
 922   return $self->{os};
 923 } # os
 924
 925 sub region {
 926   my ($self) = @_;
 927
 928 =pod
 929
 930 =head2 region
 931
 932 Returns the region
 933
 934 Parameters:
 935
 936 =for html <blockquote>
 937
 938 =over
 939
 940 =item none
 941
 942 =back
 943
 944 =for html </blockquote>
 945
 946 Returns:
 947
 948 =for html <blockquote>
 949
 950 =over
 951
 952 =item region
 953
 954 =back
 955
 956 =for html </blockquote>
 957
 958 =cut
 959
 960   return $self->{region};
 961 } # region
 962
 963 sub registry_host {
 964   my ($self) = @_;
 965
 966 =pod
 967
 968 =head2 registry_host
 969
 970 Returns the registry_host
 971
 972 Parameters:
 973
 974 =for html <blockquote>
 975
 976 =over
 977
 978 =item none
 979
 980 =back
 981
 982 =for html </blockquote>
 983
 984 Returns:
 985
 986 =for html <blockquote>
 987
 988 =over
 989
 990 =item client string
 991
 992 =back
 993
 994 =for html </blockquote>
 995
 996 =cut
 997
 998   return $self->{registry_host};
 999 } # registry_host
1000
1001 sub sitename {
1002   my ($self) = @_;
1003
1004 =pod
1005
1006 =head2 sitename
1007
1008 Returns the sitename
1009
1010 Parameters:
1011
1012 =for html <blockquote>
1013
1014 =over
1015
1016 =item none
1017
1018 =back
1019
1020 =for html </blockquote>
1021
1022 Returns:
1023
1024 =for html <blockquote>
1025
1026 =over
1027
1028 =item sitename
1029
1030 =back
1031
1032 =for html </blockquote>
1033
1034 =cut
1035
1036   return $self->{sitename};
1037 } # sitename
1038
1039 sub version {
1040   my ($self) = @_;
1041
1042 =pod
1043
1044 =head2 version
1045
1046 Returns the version
1047
1048 Parameters:
1049
1050 =for html <blockquote>
1051
1052 =over
1053
1054 =item none
1055
1056 =back
1057
1058 =for html </blockquote>
1059
1060 Returns:
1061
1062 =for html <blockquote>
1063
1064 =over
1065
1066 =item version
1067
1068 =back
1069
1070 =for html </blockquote>
1071
1072 =cut
1073
1074   return $self->{version};
1075 } # version
1076
1077 sub regions {
1078   my ($self) = @_;
1079
1080 =pod
1081
1082 =head2 regions
1083
1084 Returns an array of regions in an array context or the number of
1085 regions in a scalar context
1086
1087 Parameters:
1088
1089 =for html <blockquote>
1090
1091 =over
1092
1093 =item none
1094
1095 =back
1096
1097 =for html </blockquote>
1098
1099 Returns:
1100
1101 =for html <blockquote>
1102
1103 =over
1104
1105 =item array of regions or number of regions
1106
1107 =back
1108
1109 =for html </blockquote>
1110
1111 =cut
1112
1113   if (wantarray) {
1114     my @returnArray = sort @{$self->{regions}};
1115
1116     return @returnArray;
1117   } else {
1118     return scalar @{$self->{regions}};
1119   } # if
1120 } # regions
1121
1122 sub pwv () {
1123   my ($self) = @_;
1124
1125 =pod
1126
1127 =head2 pwv
1128
1129 Returns the current working view or undef if not in a view
1130
1131 Parameters:
1132
1133 =for html <blockquote>
1134
1135 =over
1136
1137 =item none
1138
1139 =back
1140
1141 =for html </blockquote>
1142
1143 Returns:
1144
1145 =for html <blockquote>
1146
1147 =over
1148
1149 =item Current working view or undef if none
1150
1151 =back
1152
1153 =for html </blockquote>
1154
1155 =cut
1156
1157   my ($status, @output) = $self->execute ('pwv -short');
1158
1159   return if $status;
1160   return $output[0] eq '** NONE **' ? undef : $output[0];
1161 } # pwv
1162
1163 sub name2oid ($;$) {
1164   my ($self, $name, $vob) = @_;
1165
1166 =pod
1167
1168 =head2 name2oid
1169
1170 Returns the oid for a given name
1171
1172 Parameters:
1173
1174 =for html <blockquote>
1175
1176 =over
1177
1178 =item name
1179
1180 The name to convert (unless filesystem object it should contain a type:)
1181
1182 =item vob
1183
1184 The vob the name belongs to
1185
1186 =back
1187
1188 =for html </blockquote>
1189
1190 Returns:
1191
1192 =for html <blockquote>
1193
1194 =over
1195
1196 =item OID
1197
1198 =back
1199
1200 =for html </blockquote>
1201
1202 =cut
1203
1204   if ($vob) {
1205     $vob = '@' . vobtag $vob;
1206   } else {
1207     $vob = '';
1208   } # if
1209
1210   my ($status, @output) = $self->execute ("dump $name$vob");
1211
1212   return if $status;
1213
1214   @output = grep { /^oid=/ } @output;
1215
1216   if ($output[0] =~ /oid=(\S+)\s+/) {
1217     return $1;
1218   } else {
1219     return;
1220   } # if
1221 } # name2oid
1222
1223 sub oid2name ($$) {
1224   my ($self, $oid, $vob) = @_;
1225
1226 =pod
1227
1228 =head2 oid2name
1229
1230 Returns the object name for the given oid
1231
1232 Parameters:
1233
1234 =for html <blockquote>
1235
1236 =over
1237
1238 =item oid
1239
1240 The OID to convert
1241
1242 =item vob
1243
1244 The vob the OID belongs to
1245
1246 =back
1247
1248 =for html </blockquote>
1249
1250 Returns:
1251
1252 =for html <blockquote>
1253
1254 =over
1255
1256 =item String representing the OID's textual name/value
1257
1258 =back
1259
1260 =for html </blockquote>
1261
1262 =cut
1263
1264   $vob = vobtag $vob
1265     unless $vob =~ /^vobuuid:/;
1266
1267   my ($status, @output) = $self->execute (
1268     "describe -fmt \"%n\" oid:$oid\@$vob"
1269   );
1270
1271   return if $status;
1272   return $output[0];
1273 } # oid2name
1274
1275 sub verbose_level {
1276   my ($self) = @_;
1277
1278 =pod
1279
1280 =head2 verbose_level
1281
1282 Returns the verbose_level
1283
1284 Parameters:
1285
1286 =for html <blockquote>
1287
1288 =over
1289
1290 =item none
1291
1292 =back
1293
1294 =for html </blockquote>
1295
1296 Returns:
1297
1298 =for html <blockquote>
1299
1300 =over
1301
1302 =item verbose_level
1303
1304 =back
1305
1306 =for html </blockquote>
1307
1308 =cut
1309
1310   return $self->{verbose_level};
1311 } # verbose_level
1312
1313 sub quiet {
1314   my ($self) = @_;;
1315
1316 =pod
1317
1318 =head2 quiet
1319
1320 Sets verbose_level to quiet
1321
1322 Parameters:
1323
1324 =for html <blockquote>
1325
1326 =over
1327
1328 =item none
1329
1330 =back
1331
1332 =for html </blockquote>
1333
1334 Returns:
1335
1336 =for html <blockquote>
1337
1338 =over
1339
1340 =item none
1341
1342 =back
1343
1344 =for html </blockquote>
1345
1346 =cut
1347
1348   $self->{verbose_level} = 0;
1349
1350   return;
1351 } # quiet
1352
1353 sub noisy {
1354   my ($self) = @_;
1355
1356 =pod
1357
1358 =head2 noisy
1359
1360 Sets verbose_level to noisy
1361
1362 Parameters:
1363
1364 =for html <blockquote>
1365
1366 =over
1367
1368 =item none
1369
1370 =back
1371
1372 =for html </blockquote>
1373
1374 Returns:
1375
1376 =for html <blockquote>
1377
1378 =over
1379
1380 =item none
1381
1382 =back
1383
1384 =for html </blockquote>
1385
1386 =cut
1387
1388   $self->{verbose_level} = 1;
1389
1390   return;
1391 } # noisy
1392
1393 $CC = Clearcase->new;
1394
1395 1;
1396
1397 =pod
1398
1399 =head1 DEPENDENCIES
1400
1401 =head2 Perl Modules
1402
1403 L<IPC::Open3|IPC::Open3>
1404
1405 =head2 ClearSCM Perl Modules
1406
1407 =for html <p><a href="/php/scm_man.php?file=lib/Display.pm">Display</a></p>
1408
1409 =for html <p><a href="/php/scm_man.php?file=lib/OSDep.pm">OSdep</a></p>
1410
1411 =head1 BUGS AND LIMITATIONS
1412
1413 There are no known bugs in this module
1414
1415 Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
1416
1417 =head1 LICENSE AND COPYRIGHT
1418
1419 Copyright (c) 2007, ClearSCM, Inc. All rights reserved.
1420
1421 =cut