audience/getPicture.pl

   1 #!/usr/bin/env perl
   2 use strict;
   3 use warnings;
   4
   5 =pod
   6
   7 =head1 NAME 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: #8 $
  22
  23 =item Created
  24
  25 Fri Oct  3 18:16:26 PDT 2014
  26
  27 =item Modified
  28
  29 $Date: 2014/10/03 18:17:20 $
  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 should 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 Net::LDAP;
  56 use CGI qw (:standard);
  57
  58 # Interpolate variable in str (if any) from %opts
  59 sub interpolate ($%) {
  60   my ($str, %opts) = @_;
  61
  62   # Since we wish to leave undefined $var references in tact the following while
  63   # loop would loop indefinitely if we don't change the variable. So we work
  64   # with a copy of $str changing it always, but only changing the original $str
  65   # for proper interpolations.
  66   my $copyStr = $str;
  67
  68   while ($copyStr =~ /\$(\w+)/) {
  69     my $var = $1;
  70
  71     if (exists $opts{$var}) {
  72       $str     =~ s/\$$var/$opts{$var}/;
  73       $copyStr =~ s/\$$var/$opts{$var}/;
  74     } elsif (exists $ENV{$var}) {
  75       $str     =~ s/\$$var/$ENV{$var}/;
  76       $copyStr =~ s/\$$var/$ENV{$var}/;
  77     } else {
  78      $copyStr =~ s/\$$var//;
  79   } # if
  80  } # while
  81
  82  return $str;
  83 } # interpolate
  84
  85 sub _processFile ($%) {
  86   my ($configFile, %opts) = @_;
  87
  88   while (<$configFile>) {
  89     chomp;
  90
  91     next if /^\s*[\#|\!]/;    # Skip comments
  92
  93     if (/\s*(.*?)\s*[:=]\s*(.*)\s*/) {
  94       my $key   = $1;
  95       my $value = $2;
  96
  97       # Strip trailing spaces
  98       $value =~ s/\s+$//;
  99
 100       # Interpolate
 101       $value = interpolate $value, %opts;
 102
 103       if ($opts{$key}) {
 104         # If the key exists already then we have a case of multiple values for
 105         # the same key. Since we support this we need to replace the scalar
 106         # value with an array of values...
 107         if (ref $opts{$key} eq "ARRAY") {
 108           # It's already an array, just add to it!
 109           push @{$opts{$key}}, $value;
 110         } else {
 111           # It's not an array so make it one
 112           my @a;
 113
 114           push @a, $opts{$key};
 115           push @a, $value;
 116           $opts{$key} = \@a;
 117         } # if
 118       } else {
 119         # It's a simple value
 120         $opts{$key} = $value;
 121       }  # if
 122     } # if
 123   } # while
 124
 125   return %opts;
 126 } # _processFile
 127
 128 sub GetConfig ($) {
 129   my ($filename) = @_;
 130
 131   my %opts;
 132
 133   open my $configFile, '<', $filename
 134     or die "Unable to open config file $filename";
 135
 136   %opts = _processFile $configFile;
 137
 138   close $configFile;
 139
 140   return %opts;
 141 } # GetConfig
 142
 143 sub checkLDAPError ($$) {
 144   my ($msg, $result) = @_;
 145
 146   my $code = $result->code;
 147
 148   die "$msg (Error $code)\n" . $result->error if $code;
 149 } # checkLDAPError
 150
 151 my ($confFile) = ($FindBin::Script =~ /(.*)\.pl$/);
 152     $confFile = "$confFile.conf";
 153
 154 my %opts = GetConfig ($confFile);
 155
 156 ## Main
 157 $| = 1;
 158
 159 GetOptions (
 160   \%opts,
 161   'AD_HOST=s',
 162   'AD_PORT=s',
 163   'AD_BINDDN=s',
 164   'AD_BINDPW=s',
 165   'AD_BASEDN=s',
 166   'userid=s',
 167 ) || die 'Invalid parameters';
 168
 169 $opts{userid} = param 'userid' unless $opts{userid};
 170
 171 die "Usage getPicture.pl [userid=]<userid>\n" unless $opts{userid};
 172
 173 my $ldap = Net::LDAP->new (
 174   $opts{AD_HOST}, (
 175     host   => $opts{AD_HOST},
 176     port   => $opts{AD_PORT},
 177     basedn => $opts{AD_BASEDN},
 178     binddn => $opts{AD_BINDDN},
 179     bindpw => $opts{AD_BINDPW},
 180   ),
 181 ) or die $@;
 182
 183 my $result = $ldap->bind (
 184   dn       => $opts{AD_BINDDN},
 185   password => $opts{AD_BINDPW},
 186 ) or die "Unable to bind\n$@";
 187
 188 checkLDAPError ('Unable to bind', $result);
 189
 190 $result = $ldap->search (
 191   base   => $opts{AD_BASEDN},
 192   filter => "uid=$opts{userid}",
 193 );
 194
 195 checkLDAPError ('Unable to search', $result);
 196
 197 my @entries = ($result->entries);
 198
 199 if ($entries[0]) {
 200   print header 'image/jpeg';
 201   print $entries[0]->get_value ('thumbnailPhoto');
 202 } # if