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