ldapsearch.PL

# -*- perl -*-

use Config;
use File::Basename qw(&basename &dirname);
use Cwd;

# This forces PL files to create target in same directory as PL file.
# This is so that make depend always knows where to find PL derivatives.
my $origdir = cwd;
chdir dirname($0);
my $script = basename($0, '.PL');
$script .= '.com' if $^O eq 'VMS';

unlink($script);
open OUT, ">$script" or die "open for writing $script: $!";

print OUT <<"!GROK!THIS!";
$Config{startperl}
    eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
	if \$running_under_some_shell && \$running_under_some_shell;
!GROK!THIS!

# In the following, perl variables are not expanded during extraction.

print OUT <<'!NO!SUBS!';
# -*- perl -*-
# Nearly complete clone of Umich ldapsearch program
#
# c.ridd@isode.com
#
# $Id: ldapsearch.PL,v 1.3 2000/08/03 17:10:26 gbarr Exp $
#
# $Log: ldapsearch.PL,v $
# Revision 1.3  2000/08/03 17:10:26  gbarr
# *** empty log message ***
#
# Revision 1.3  1999/01/11 08:33:34  cjr
# Revised for 0.09 API
#
# Revision 1.2  1998/10/20 08:38:43  cjr
# Add support for binary values (base64 encoding and the -B option)
#
# Revision 1.1  1998/10/19 15:14:15  cjr
# Initial revision
#

use strict;
use Carp;
use Net::LDAP;
use URI::ldap;
use Net::LDAP::LDIF;
use vars qw($opt_n $opt_v $opt_t $opt_u $opt_A $opt_B $opt_L $opt_R $opt_d
	    $opt_F $opt_S $opt_f $opt_b $opt_b $opt_s $opt_a $opt_l $opt_z
	    $opt_D $opt_w $opt_h $opt_p $opt_3);
use Getopt::Std;

# Enums
my %scopes = ( 'base' => 0, 'one' => 1, 'sub' => '2' );
my %derefs = ( 'never' => 0, 'search' => 1, 'find' => 2, 'always' => 3 );

# We only print attributes that we know are text
# This stuff is in lieu of a workable Schema module
my @textsyntax = grep /^\w/, (<<'EOS' =~ /(#.*|\S+)/g); # qw() with comments
		    # RFC 2251
		    modifiersName modifyTimestamp
		    creatorsName createTimestamp

		    # RFC 2256
		    objectClass aliasedObjectName knowledgeInformation cn sn
		    serialNumber c l st street o ou title description
		    searchGuide businessCategory postalAddress postalCode
		    postOfficeBox physicalDeliveryOfficeName telephoneNumber
		    telexNumber teletexTerminalIdentifier
		    facsimileTelephoneNumber x121Address
		    internationaliSDNNumber registeredAddress
		    destinationIndicator preferredDeliveryMethod
		    presentationAddress supportedApplicationContext member
		    owner roleOccupant seeAlso userPassword name givenName
		    initials generationQualifier x500UniqueIdentifier
		    dnQualifier enhancedSearchGuide protocolInformation
		    distinguishedName uniqueMember houseIdentifier dmdName

		    # RFC 1274
		    mail rfc822Mailbox

		    # RFC 2079
		    labeledURI
		    
		    # Definitions from other schemas goes here...
		    collectivePostalAddress collectiveTelephoneNumber
		    collectiveFacsimileTelephoneNumber
		    supportedLDAPVersion
EOS

my %istext; # keys are canonicalised attribute names.
foreach (@textsyntax) { $istext{lc($_)} = 1; };

die "Usage: $0 [options] filter [attributes...]\
where:\
    filter      RFC 2254 compliant LDAP search filter\
    attributes  whitespace-separated list of attributes to retrieve\
                (if no attribute list is given, all are retrieved)\
options:\
    -n          show what would be done but don\'t actually search\
    -v          run in verbose mode (diagnostics to standard output)\
    -A          retrieve attribute names only (no values)\
    -B          do not suppress printing of non-ASCII values\
    -L          print entries in LDIF format (-B is implied)\
    -R          do not automatically follow referrals\
    -d level    set LDAP debugging level to \'level\'\
    -F sep      print `sep' instead of \'=\' between attribute names and values\
    -b basedn   base dn for search\
    -s scope    one of base, one, or sub (search scope)\
    -a deref    one of never, always, search, or find (alias dereferencing)\
    -l time lim time limit (in seconds) for search\
    -z size lim size limit (in entries) for search\
    -D binddn   bind dn\
    -w passwd   bind passwd (for simple authentication)\
    -h host     ldap server\
    -p port     port on ldap server\
    -3          connect using LDAPv3, otherwise use LDAPv2\n" unless @ARGV;

getopts('nvtuABLRd:F:S:f:b:s:a:l:z:D:w:h:p:3');

die "$0: arguments -t -u -S and -f are not supported yet" if ($opt_t ||
							      $opt_u ||
							      $opt_S ||
							      $opt_f);
# Default the host to a known good LDAP server
$opt_h = 'nameflow.dante.net' unless $opt_h;
$opt_F = '=' unless $opt_F;

die "$0: unknown scope $opt_s\n" if $opt_s && !defined($scopes{$opt_s});
die "$0: unknown deref $opt_a\n" if $opt_a && !defined($derefs{$opt_a});

my $filter = shift || die "$0: missing filter\n";

# We are expecting to get back referrals from the search. Each referral may
# lead to more referrals being returned, etc etc.
#
# So we handle this by looping through a list of referrals, taking the top
# one each time, but possibly adding extra ones inside the loop. We prime the
# list of referrals by making a 'referral' from the command line args.
#
# The loop body does the open, bind, search, unbind and close.
#
# The authentication offered to any particular server is not offered to any
# other server, unless the referral indicates it should. This prevents you
# revealing your password (etc) to random servers.

my $initial = URI->new("ldap:");
$initial->host($opt_h);
$initial->dn($opt_b);
$initial->port($opt_p) if $opt_p;
my %exts;
$exts{bindname} = $opt_D if $opt_D;
$exts{bindpassword} = $opt_w if $opt_w;
$initial->extensions(%exts);

my @urls = ($initial->as_string);

my $ldif = Net::LDAP::LDIF->new if $opt_L;
my $first_record = 1;

while (@urls) {
    my $url = URI::ldap->new(shift @urls);
    my %exts = $url->extensions;
    my $ldap;
    my %openargs;
    my %bindargs;
    my %searchargs;

    $bindargs{dn} = $exts{bindname} if $exts{bindname};
    $bindargs{password} = $exts{bindpassword} if $exts{bindpassword};

    $openargs{port} = $url->port if $url->port;
    $openargs{debug} = $opt_d if $opt_d;

    dumpargs("new", $url->host, \%openargs) if ($opt_n || $opt_v);

    unless ($opt_n) {
	$ldap = new Net::LDAP($url->host,
			      %openargs) or die $@;
    }

#
# Bind as the desired version, falling back if required to v2
#

    $bindargs{version} = $opt_3 ? 3 : 2;

    if ($bindargs{version} == 3) {
	dumpargs("bind", undef, \%bindargs) if ($opt_n || $opt_v);
	unless ($opt_n) {
	    $ldap->bind(%bindargs) or $bindargs{version} = 2;
	}
    }

    if ($bindargs{version} == 2) {
	dumpargs("bind", undef, \%bindargs) if ($opt_n || $opt_v);
	unless ($opt_n) {
	    $ldap->bind(%bindargs) or die $@;
	}
    }

    # Set search arguments
    $searchargs{base} = $opt_b if $opt_b;
    $searchargs{base} = $url->dn if $url->dn;
    $searchargs{scope} = $opt_s if $opt_s;
    $searchargs{scope} = $url->_scope if defined $url->_scope;
    $searchargs{scope} = $scopes{$searchargs{scope}} if $searchargs{scope};
    $searchargs{deref} = $derefs{$opt_a} if $opt_a;
    $searchargs{sizelimit} = $opt_z if $opt_z;
    $searchargs{timelimit} = $opt_l if $opt_l;
    $searchargs{attrsonly} = 1 if $opt_t; # typesOnly
    $searchargs{filter} = $filter;
    $searchargs{attrs} = [ @ARGV ];

    dumpargs("search", undef, \%searchargs) if ($opt_n || $opt_v);

    # Print results
    # Hm, this is harder work than the actual search!
    unless ($opt_n) {
	my $results = $ldap->search(%searchargs) or die $@;

	my @entries = $results->entries;
	if ($opt_L) {
	    $ldif->write(@entries);
	} else {
	    my $entry;
	    foreach $entry (@entries) {
		print "\n" unless $first_record;
		$first_record = 0;
		my ($attr, $val);
		# Print in a pseudo EDB format
		# Not a useful format, but it shows how to get to the
		# attributes and values in an entry
		print $entry->dn,"\n";
		foreach $attr ($entry->attributes) {
		    my $is_printable = $istext{lc($attr)};
		    foreach $val ($entry->get($attr)) {
			print "$attr$opt_F";
			if ($opt_B || $is_printable) {
			    print "$val\n";
			} else {
			    print "(binary value)\n";
			}
		    } # foreach value
		} # foreach attribute
	    } # foreach entry
	} # EDB format

	# Check for any referrals
	my @refs = $results->referrals;
	if ($opt_v && @refs) {
	    map { print "Referral to: $_\n" } @refs;
	}
	push @urls, @refs unless $opt_R;

	# Check for any search continuation references
	my @conts = $results->references;
	if ($opt_v && @conts) {
	    map { print "Continue at: $_\n" } @conts;
	}
        push @urls, @conts unless $opt_R;
    }
    
    if ($opt_n || $opt_v) {
	print "unbind()\n";
    }
    unless ($opt_n) {
	$ldap->unbind() or die $@;
    }
} # foreach URL

sub dumpargs {
    my ($cmd,$s,$rh) = @_;
    my @t;
    push @t, "'$s'" if $s;
    map {
	my $value = $$rh{$_};
	if (ref($value) eq 'ARRAY') {
	    push @t, "$_ => [" . join(", ", @$value) . "]";
	} else {
	    push @t, "$_ => '$value'";
	}
    } keys(%$rh);
    print "$cmd(", join(", ", @t), ")\n";
}
!NO!SUBS!

close OUT or die "Can't close $script: $!";
chmod 0755, $script or die "Can't reset permissions for $script: $!\n";
exec("$Config{'eunicefix'} $script") if $Config{'eunicefix'} ne ':';
chdir $origdir;