Perforce/lib/Perforce.pm

   1 package Perforce;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Carp;
   7 use File::Basename;
   8 use File::Temp;
   9
  10 use P4;
  11 use Authen::Simple::LDAP;
  12
  13 use Display;
  14 use GetConfig;
  15 use Utils;
  16
  17 our $VERSION  = '$Revision: 2.23 $';
  18    ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
  19
  20 my $p4config   = $ENV{P4_CONF}   || dirname (__FILE__) . '/../etc/p4.conf';
  21 my $ldapconfig = $ENV{LDAP_CONF} || dirname (__FILE__) . '/../etc/LDAP.conf';
  22
  23 my %P4OPTS   = GetConfig $p4config   if -r $p4config;
  24 my %LDAPOPTS = GetConfig $ldapconfig if -r $ldapconfig;
  25
  26 my $serviceUser = 'shared';
  27 my ($domain, $password);
  28 my $defaultPort = 'perforce:1666';
  29 my $p4tickets   = $^O =~ /win/i ? 'C:/Program Files/Devops/Perforce/p4tickets'
  30                                 : '/opt/audience/perforce/p4tickets';
  31
  32 my $keys;
  33
  34 # If USERDOMAIN is set and equal to audience then set $domain to ''. This will
  35 # use the Audience domain settings in LDAP.conf.
  36 if ($ENV{USERDOMAIN}) {
  37   if (lc $ENV{USERDOMAIN} eq 'audience') {
  38     $domain = '';
  39   } else {
  40     $domain = $ENV{USERDOMAIN}
  41   } # if
  42 } # if
  43
  44 sub new (;%) {
  45   my ($class, %parms) = @_;
  46
  47   my $self = bless {}, $class;
  48
  49   $self->{P4USER}   = $parms{username} || $P4OPTS{P4USER}   || $ENV{P4USER}   || $serviceUser;
  50   $self->{P4PASSWD} = $parms{password} || $P4OPTS{P4PASSWD} || $ENV{P4PASSWD} || undef;
  51   $self->{P4CLIENT} = $parms{p4client} || $P4OPTS{P4CLIENT} || $ENV{P4CLIENT} || undef;
  52   $self->{P4PORT}   = $parms{p4port}   || $ENV{P4PORT}    || $defaultPort;
  53
  54   $self->{P4}       = $self->connect (%parms);
  55
  56   return $self;
  57 } # new
  58
  59 sub errors ($;$) {
  60   my ($self, $cmd, $exit) = @_;
  61
  62   my $msg    = "Unable to run \"p4 $cmd\"";
  63   my $errors = $self->{P4}->ErrorCount;
  64
  65   error "$msg\n" . $self->{P4}->Errors, $exit if $errors;
  66
  67   return $errors;
  68 } # errors
  69
  70 sub connect () {
  71   my ($self) = @_;
  72
  73   $self->{P4} = P4->new;
  74
  75   $self->{P4}->SetUser     ($self->{P4USER});
  76   $self->{P4}->SetClient   ($self->{P4CLIENT}) if $self->{P4CLIENT};
  77   $self->{P4}->SetPort     ($self->{P4PORT});
  78   $self->{P4}->SetPassword ($self->{P4PASSWD}) unless $self->{P4USER} eq $serviceUser;
  79
  80   verbose_nolf "Connecting to Perforce server $self->{P4PORT}...";
  81   $self->{P4}->Connect or croak "Unable to connect to Perforce Server\n";
  82   verbose 'done';
  83
  84   verbose_nolf "Logging in as $self->{P4USER}\@$self->{P4PORT}...";
  85
  86   unless ($self->{P4USER} eq $serviceUser) {
  87     $self->{P4}->RunLogin;
  88
  89     $self->errors ('login', $self->{P4}->ErrorCount);
  90   } else {
  91     $ENV{P4TICKETS} = $p4tickets if $self->{P4USER} eq $serviceUser;
  92   } # unless
  93
  94   verbose 'done';
  95
  96   return $self->{P4};
  97 } # connect
  98
  99 sub _authenticateUser ($$$$) {
 100   my ($self, $domain, $username, $p4client) = @_;
 101
 102   $domain .= '_' unless $domain eq '';
 103
 104   # Connect to LDAP
 105   my $ad = Authen::Simple::LDAP->new (
 106     host   => $LDAPOPTS{"${domain}AD_HOST"},
 107     basedn => $LDAPOPTS{"${domain}AD_BASEDN"},
 108     port   => $LDAPOPTS{"${domain}AD_PORT"},
 109     filter => $LDAPOPTS{"${domain}AD_FILTER"},
 110   ) or croak $@;
 111
 112   # Read the password from <stdin> and truncate the newline - unless we already
 113   # read in the password
 114   unless ($password) {
 115     if (-t STDIN) {
 116       $password = GetPassword;
 117     } else {
 118       $password = <STDIN>;
 119
 120       chomp $password;
 121     } # if
 122   } # unless
 123
 124   # Special handling of "shared" user
 125   if ($username eq 'shared') {
 126     my $sharedAcl = "$FindBin::Bin/sharedAcl.txt";
 127
 128     croak "Unable to find file $sharedAcl" unless -f $sharedAcl;
 129
 130     open my $sharedAcls, '<', $sharedAcl
 131       or croak "Unable to open $sharedAcl - $!";
 132
 133     chomp (my @acls = <$sharedAcls>);
 134
 135     close $sharedAcls;
 136
 137     for (@acls) {
 138       if (/\*$/) {
 139         chop;
 140
 141         exit if $p4client =~ /$_/;
 142       } else {
 143         exit if $_ eq $p4client;
 144       } # if
 145     } # for
 146   } # if
 147
 148   # Connect to Perforce
 149   $self->connect unless $self->{P4};
 150
 151   # Must be a valid Perforce user
 152   return unless $self->getUser ($username);
 153
 154   # And supply a valid username/password
 155   return $ad->authenticate ($username, $password);
 156 } # _authenticateUser
 157
 158 sub authenticateUser ($;$) {
 159   my ($self, $username, $p4client) = @_;
 160
 161 =pod
 162   # If $domain is set to '' then we'll check Audience's LDAP.
 163   # If $domain is not set (undef) then we'll try Knowles first, then Audience
 164   # otherwise we will take $DOMAIN and look for those settings...
 165   unless ($domain) {
 166     unless ($self->_authenticateUser ('KNOWLES', $username, $p4client)) {
 167       unless ($self->_authenticateUser ('', $username, $p4client)) {
 168         return;
 169       } # unless
 170     } # unless
 171   } else {
 172     if ($domain eq '') {
 173       unless ($self->_authenticateUser ('', $username, $p4client)) {
 174         return;
 175       } # unless
 176     } else {
 177       unless ($self->_authenticateUser ($domain, $username, $p4client)) {
 178         return;
 179       } # unless
 180     } # if
 181   } # unless
 182 =cut
 183
 184   return $self->_authenticateUser ('KNOWLES',  $username, $p4client);
 185
 186 #  return 1;
 187 } # authenticateUser
 188
 189 sub changes (;$%) {
 190   my ($self, $args, %opts) = @_;
 191
 192   my $cmd = 'changes';
 193
 194   for (keys %opts) {
 195     if (/from/i and $opts{to}) {
 196         $args .= " $opts{$_},$opts{to}";
 197
 198         delete $opts{to};
 199     } else {
 200       $args .= " $opts{$_}";
 201     } # if
 202   } # for
 203
 204   my $changes = $self->{P4}->Run ($cmd, $args);
 205
 206   return $self->errors ("$cmd $args") || $changes;
 207 } # changes
 208
 209 sub job ($) {
 210   my ($self, $job) = @_;
 211
 212   my $jobs = $self->{P4}->IterateJobs ("-e $job");
 213
 214   return $self->errors ("jobs -e $job") || $job;
 215 } # job
 216
 217 sub comments ($) {
 218   my ($self, $changelist) = @_;
 219
 220   my $change = $self->{P4}->FetchChange ($changelist);
 221
 222   return $self->errors ("change $changelist") || $change;
 223 } # comments
 224
 225 sub files ($) {
 226   my ($self, $changelist) = @_;
 227
 228   my $files = $self->{P4}->Run ('files', "\@=$changelist");
 229
 230   return $self->errors ("files \@=$changelist") || $files;
 231 } # files
 232
 233 sub filelog ($;%) {
 234   my ($self, $fileSpec, %opts) = @_;
 235
 236   return $self->{P4}->RunFilelog ($fileSpec, %opts);
 237 } # filelog
 238
 239 sub getRevision ($;$) {
 240   my ($self, $filename, $revision) = @_;
 241
 242   unless ($revision) {
 243     if ($filename =~ /#/) {
 244       ($filename, $revision) = split $filename, '#';
 245     } else {
 246       error "No revision specified in $filename";
 247
 248       return;
 249     } # if
 250   } # unlessf
 251
 252   my @contents = $self->{P4}->RunPrint ("$filename#$revision");
 253
 254   if ($self->{P4}->ErrorCount) {
 255     $self->errors ("Print $filename#$revision");
 256
 257     return;
 258   } else {
 259     return @contents;
 260   } # if
 261 } # getRevision
 262
 263 sub getUser (;$) {
 264   my ($self, $user) = @_;
 265
 266   $user //= $ENV{P4USER} || $ENV{USER};
 267
 268   my $cmd  = 'user';
 269   my @args = ('-o', $user);
 270
 271   my $userRecs = $self->{P4}->Run ($cmd, @args);
 272
 273   # Perforce returns an array of qualifying users. We only care about the first
 274   # one. However if the username is invalid, Perforce still returns something
 275   # that looks like a user. We look to see if there is a Type field here which
 276   # indicates that it's a valid user
 277   if ($userRecs->[0]{Type}) {
 278     return %{$userRecs->[0]};
 279   } else {
 280     return;
 281   } # if
 282 } # getUser
 283
 284 sub renameSwarmUser ($$) {
 285   my ($self, $oldusername, $newusername) = @_;
 286
 287   # We are turning this off because Perforce support says that just modifying
 288   # the keys we do not update the indexing done in the Perforce Server/Database.
 289   # So instead we have a PHP script (renameUser.php) which goes through the
 290   # official, but still unsupported, "Swarm Record API" to change the usernames
 291   # and call the object's method "save" which should perform the necessary
 292   # reindexing... Stay tuned! :-)
 293   #
 294   # BTW One needs to run renameUser.php by hand as we do not do that here.
 295   return;
 296
 297   $keys = $self->getKeys ('swarm-*') unless $keys;
 298
 299   for (@$keys) {
 300     my %key = %$_;
 301
 302     if ($key{value} =~ /$oldusername/) {
 303       $key{value} =~ s/\"$oldusername\"/\"$newusername\"/g;
 304       $key{value} =~ s/\@$oldusername /\@$newusername /g;
 305       $key{value} =~ s/\@$oldusername\./\@$newusername\./g;
 306       $key{value} =~ s/\@$oldusername,/\@$newusername,/g;
 307       $key{value} =~ s/ $oldusername / $newusername /g;
 308       $key{value} =~ s/ $oldusername,/ $newusername,/g;
 309       $key{value} =~ s/ $oldusername\./ $newusername\./g;
 310       $key{value} =~ s/-$oldusername\"/-$newusername\"/g;
 311
 312       my $cmd = 'key';
 313
 314       display "Correcting key $key{key}";
 315
 316       my @result = $self->{P4}->Run ($cmd, $key{key}, $key{value});
 317
 318       $self->errors ($cmd, $result[0]->{key} || 1);
 319     } # if
 320   } # for
 321
 322   return;
 323 } # renameSwarmUser
 324
 325 sub renameUser ($$) {
 326   my ($self, $old, $new) = @_;
 327
 328   my $cmd  = 'renameuser';
 329   my @args = ("--from=$old", "--to=$new");
 330
 331   $self->{P4}->Run ($cmd, @args);
 332
 333   my $status = $self->errors (join ' ', $cmd, @args);
 334
 335   return $status if $status;
 336
 337 #  return $self->renameSwarmUser ($old, $new);
 338 } # renameUser
 339
 340 sub updateUser (%) {
 341   my ($self, %user) = @_;
 342
 343   # Trying to do this with P4Perl is difficult. First off the structure needs
 344   # to be AOH and secondly you need to call SetUser to be the other user. That
 345   # said you need to also specify -f to force the update (which means you must
 346   # a admin (or superuser?) and I found no way to specify -f so I've reverted
 347   # back to using p4 from the command line. I also don't like having to use
 348   # a file here...
 349   my $tmpfile     = File::Temp->new;
 350   my $tmpfilename = $tmpfile->filename;
 351
 352   print $tmpfile "User: $user{User}\n";
 353   print $tmpfile "Email: $user{Email}\n";
 354   print $tmpfile "Update: $user{Update}\n";
 355   print $tmpfile "FullName: $user{FullName}\n";
 356
 357   close $tmpfile;
 358
 359   my @lines  = `p4 -p $self->{P4PORT} user -f -i < $tmpfilename`;
 360   my $status = $?;
 361
 362   return wantarray ? @lines : join '', @lines;
 363 } # updateUser
 364
 365 sub getKeys (;$) {
 366   my ($self, $filter) = @_;
 367
 368   my $cmd = 'keys';
 369   my @args;
 370
 371   if ($filter) {
 372     push @args, '-e';
 373     push @args, $filter;
 374   } # if
 375
 376   my $keys = $self->{P4}->Run ($cmd, @args);
 377
 378   $self->errors ($cmd . join (' ', @args), 1);
 379
 380   return $keys;
 381 } # getKeys
 382
 383 sub key ($$) {
 384   my ($self, $name, $value) = @_;
 385
 386   my $cmd = 'key';
 387   my @args = ($name, $value);
 388
 389   $self->{P4}->Run ($cmd, @args);
 390
 391   return $self->errors (join ' ', $cmd, @args);
 392 } # key
 393
 394 1;