Perforce/getPicture.pl

   1 #!/usr/bin/env perl
   2 use strict;
   3 use warnings;
   4
   5 =pod
   6
   7 =head1 NAME $File: //AudEngr/Import/VSS/ReleaseEng/Dev/Perforce/getPicture.pl $
   8
   9 Retrieve thumbnailPhoto for the userid from Active Directory
  10
  11 =head1 VERSION
  12
  13 =over
  14
  15 =item Author
  16
  17 Andrew DeFaria <Andrew@ClearSCM.com>
  18
  19 =item Revision
  20
  21 $Revision: #1 $
  22
  23 =item Created
  24
  25 Fri Oct  3 18:16:26 PDT 2014
  26
  27 =item Modified
  28
  29 $Date: 2015/03/03 $
  30
  31 =back
  32
  33 =head1 DESCRIPTION
  34
  35 This script will take a userid and search the Active Directory for the user and
  36 return an image file if the user has an image associated with his
  37 thumbnailPhoto attribute.
  38
  39 This can be configured into Perforce Swarn as documented:
  40
  41 http://www.perforce.com/perforce/doc.current/manuals/swarm/admin.avatars.html
  42
  43 One would use something like
  44
  45   // this block shoudl be a peer of 'p4'
  46   'avatars' => array(
  47     'http_url'  => 'http://<server>/cgi-bin/getPicture.pl?userid={user}'
  48     'https_url' => 'http://<server>/cgi-bin/getPicture.pl?userid={user}',
  49   ),
  50
  51 =cut
  52
  53 use FindBin;
  54 use Getopt::Long;
  55 use Pod::Usage;
  56 use Net::LDAP;
  57 use CGI qw (:standard);
  58
  59 # Interpolate variable in str (if any) from %opts
  60 sub interpolate ($%) {
  61   my ($str, %opts) = @_;
  62
  63   # Since we wish to leave undefined $var references in tact the following while
  64   # loop would loop indefinitely if we don't change the variable. So we work
  65   # with a copy of $str changing it always, but only changing the original $str
  66   # for proper interpolations.
  67   my $copyStr = $str;
  68
  69   while ($copyStr =~ /\$(\w+)/) {
  70     my $var = $1;
  71
  72     if (exists $opts{$var}) {
  73       $str     =~ s/\$$var/$opts{$var}/;
  74       $copyStr =~ s/\$$var/$opts{$var}/;
  75     } elsif (exists $ENV{$var}) {
  76       $str     =~ s/\$$var/$ENV{$var}/;
  77       $copyStr =~ s/\$$var/$ENV{$var}/;
  78     } else {
  79      $copyStr =~ s/\$$var//;
  80   } # if
  81  } # while
  82
  83  return $str;
  84 } # interpolate
  85
  86 sub _processFile ($%) {
  87   my ($configFile, %opts) = @_;
  88
  89   while (<$configFile>) {
  90     chomp;
  91
  92     next if /^\s*[\#|\!]/;    # Skip comments
  93
  94     if (/\s*(.*?)\s*[:=]\s*(.*)\s*/) {
  95       my $key   = $1;
  96       my $value = $2;
  97
  98       # Strip trailing spaces
  99       $value =~ s/\s+$//;
 100
 101       # Interpolate
 102       $value = interpolate $value, %opts;
 103
 104       if ($opts{$key}) {
 105         # If the key exists already then we have a case of multiple values for
 106         # the same key. Since we support this we need to replace the scalar
 107         # value with an array of values...
 108         if (ref $opts{$key} eq "ARRAY") {
 109           # It's already an array, just add to it!
 110           push @{$opts{$key}}, $value;
 111         } else {
 112           # It's not an array so make it one
 113           my @a;
 114
 115           push @a, $opts{$key};
 116           push @a, $value;
 117           $opts{$key} = \@a;
 118         } # if
 119       } else {
 120         # It's a simple value
 121         $opts{$key} = $value;
 122       }  # if
 123     } # if
 124   } # while
 125
 126   return %opts;
 127 } # _processFile
 128
 129 sub GetConfig ($) {
 130   my ($filename) = @_;
 131
 132   my %opts;
 133
 134   open my $configFile, '<', $filename
 135     or die "Unable to open config file $filename";
 136
 137   %opts = _processFile $configFile;
 138
 139   close $configFile;
 140
 141   return %opts;
 142 } # GetConfig
 143
 144 sub checkLDAPError ($$) {
 145   my ($msg, $result) = @_;
 146
 147   my $code = $result->code;
 148
 149   die "$msg (Error $code)\n" . $result->error if $code;
 150 } # checkLDAPError
 151
 152 my ($confFile) = ($FindBin::Script =~ /(.*)\.pl$/);
 153     $confFile = "$FindBin::Bin/$confFile.conf";
 154
 155 my %opts = GetConfig ($confFile);
 156
 157 ## Main
 158 $| = 1;
 159
 160 GetOptions (
 161   \%opts,
 162   'AD_HOST=s',
 163   'AD_PORT=s',
 164   'AD_BINDDN=s',
 165   'AD_BINDPW=s',
 166   'AD_BASEDN=s',
 167   'userid=s',
 168 ) or pod2usage;
 169
 170 $opts{userid} = param 'userid' unless $opts{userid};
 171
 172 pod2usage "Usage getPicture.pl [userid=]<userid>\n" unless $opts{userid};
 173
 174 my $ldap = Net::LDAP->new (
 175   $opts{AD_HOST}, (
 176     host   => $opts{AD_HOST},
 177     port   => $opts{AD_PORT},
 178     basedn => $opts{AD_BASEDN},
 179     binddn => $opts{AD_BINDDN},
 180     bindpw => $opts{AD_BINDPW},
 181   ),
 182 ) or die $@;
 183
 184 my $result = $ldap->bind (
 185   dn       => $opts{AD_BINDDN},
 186   password => $opts{AD_BINDPW},
 187 ) or die "Unable to bind\n$@";
 188
 189 checkLDAPError ('Unable to bind', $result);
 190
 191 $result = $ldap->search (
 192   base   => $opts{AD_BASEDN},
 193   filter => "sAMAccountName=$opts{userid}",
 194 );
 195
 196 checkLDAPError ('Unable to search', $result);
 197
 198 my @entries = ($result->entries);
 199
 200 if ($entries[0]) {
 201   print header 'image/jpeg';
 202   print $entries[0]->get_value ('thumbnailPhoto');
 203 } # if