import

13 files changed, 1355 insertions, 0 deletions

diff --git a/Changes b/Changes
new file mode 100755
index 0000000..1b124ed
--- /dev/null
+++ b/Changes
@@ -0,0 +1,6 @@
+Revision history for Perl extension LDAPShell.
+
+0.01  Mon Nov  4 10:39:28 2002
+	- original version; created by h2xs 1.21 with options
+		-X -n LDAPShell
+
diff --git a/LDAPShell.pm b/LDAPShell.pm
new file mode 100755
index 0000000..87e087f
--- /dev/null
+++ b/LDAPShell.pm
@@ -0,0 +1,1016 @@
+package LDAPShell;
+
+use 5.006;
+use strict;
+#use warnings;
+
+require Exporter;
+use AutoLoader qw(AUTOLOAD);
+
+our @ISA = qw(Exporter);
+
+# Items to export into callers namespace by default. Note: do not export
+# names by default without a very good reason. Use EXPORT_OK instead.
+# Do not simply export all your public functions/methods/constants.
+
+# This allows declaration	use LDAPShell ':all';
+# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
+# will save memory.
+our %EXPORT_TAGS = ( '_funcs' => [ qw(
+				      _ls
+				      _mv
+				      _add
+				      _modify
+				      _delete
+				      _cat
+				      _login
+				      _auth
+				      _logout
+				      _pwd
+				      _cd
+) ],
+		     'all' => [ qw(
+
+) ]
+);
+
+our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
+
+our @EXPORT = qw(
+	
+);
+our $VERSION = '1.00';
+
+use Term::ReadLine;
+use Term::ReadLine::Gnu;
+use Term::ANSIColor;
+use Getopt::Long;
+use URI;
+use Text::FormatTable;
+use Unicode::String qw(utf8 latin1);
+use vars qw(%Attribs @EXPORT @ISA);
+use Net::LDAP qw(LDAP_NO_SUCH_OBJECT);
+use ResourcePool;
+use ResourcePool::Factory::Net::LDAP;
+
+use LDAPShell::Callbacks;
+
+# Preloaded methods go here.
+
+# Autoload methods go after =cut, and are processed by the autosplit program.
+
+sub toutf8
+  {
+    latin1($_[1]||'')->utf8;
+  }
+
+sub tolatin1
+  {
+    utf8($_[1]||'')->latin1;
+  }
+
+sub new
+  {
+    my $self = shift;
+    my $class = ref $self || $self;
+    my $this = bless {},$class;
+
+    $this->{_term} = Term::ReadLine::Gnu->new('LDAP Shell');
+    my $attribs = $this->{_term}->Attribs;
+    $attribs->{completion_entry_function} = \&rdn_completion_function;
+    $attribs->{basic_word_break_characters} = "\t\n\ ";
+    $attribs->{completer_word_break_characters} = $attribs->{basic_word_break_characters};
+    $attribs->{filename_quote_characters} = "\ ";
+    $attribs->{completion_append_character} = '/';
+    $attribs->{filename_completion_desired} = 1;
+    $this->{_base} = '';
+    $this->{_callbacks} = LDAPShell::Callbacks->new();
+    my $uri = $this->getenv('AUTOCONNECT');
+    if ($uri)
+      {
+	my $u = URI->new($uri) or die "Malformed uri: $uri\n";
+	my ($host,$port,$path) = $u->opaque =~ /\/\/([^\/:]+):?([0-9]*)\/?(.*)/;
+	$this->{_server} = $host;
+	$this->{_port} = $port if $port;
+	$this->{_base} = $path if $path;
+	$this->reconnect();
+      }
+    $this;
+  }
+
+sub init
+  {
+    my $self = shift;
+    my $ini = shift;
+
+  }
+
+sub callbacks { $_[0]->{_callbacks} }
+
+my $_i;
+sub rdn_completion_function ( $$ ) {
+    my($text, $state) = @_;
+
+    $_i = $state ? $_i + 1 : 0; # clear counter at the first call
+    *Attribs = \%Term::ReadLine::Gnu::Attribs;
+    my $cw = $Attribs{completion_word};
+    for (; $_i <= $#{$cw}; $_i++) {
+      #warn "\"$cw->[$_i]\"\n";
+      return $cw->[$_i] if (substr($cw->[$_i],0,length($text)) eq $text);
+    }
+    return undef;
+}
+
+sub getenv
+  {
+    $ENV{"DSH_".$_[1]};
+  }
+
+sub setenv
+  {
+    $ENV{"DSH_".$_[1]} = $_[2];
+  }
+
+sub unset
+  {
+    delete $ENV{"DSH_".$_[1]};
+  }
+
+sub _escapespace
+  {
+    local $_ = shift;
+    s/ /\\\ /og;
+    $_;
+  }
+
+sub _unescapespace
+  {
+    local $_ = shift;
+    s/\\\ / /og;
+    $_;
+  }
+
+sub setup_autocompletion
+  {
+    my $self = shift;
+
+    my $c = $self->connection;
+    my $dn = $self->{_base};
+    my $res = $c->search(base=>$dn,
+			 scope=>'one',
+			 filter=>$self->getenv('filter') || 'objectClass=*',
+			 attr=>['objectClass']);
+
+    $res->code && die "LDAP Error: ".$res->error."\n";
+    my @rdns;
+    foreach my $e ($res->all_entries)
+      {
+	push(@rdns,_escapespace($self->tolatin1($self->rdn($e->dn()))));
+      }
+    $self->{_term}->Attribs->{completion_word} = \@rdns;
+  }
+
+sub reconnect
+  {
+    my $self = shift;
+
+    delete $self->{_ssl};
+    delete $self->{_authenticated};
+    if (ref $self->{_ldap})
+      {
+	$self->{_ldap}->unbind();
+      }
+
+    if ($self->getenv('USESSL'))
+      {
+	my $port = $self->{_port} || 636;
+	my @ca;
+	push(@ca,cafile=>$self->getenv('CAFILE')) if $self->getenv('CAFILE');
+	push(@ca,cadir=>$self->getenv('CADIR')) if $self->getenv('CADIR');
+	$self->{_ldap} = Net::LDAP->new($self->{_server},
+					version=>3,
+					port=>$port,
+					verify=>'require',@ca);
+	$self->{_ssl}++;
+      }
+    else
+      {
+	$self->{_ldap} = Net::LDAP->new($self->{_server},version=>3,port=>$self->{_port}||389);
+	my $starttls = $self->getenv('STARTTLS');
+	if ($starttls)
+	  {
+	    my @ca;
+	    push(@ca,cafile=>$self->getenv('CAFILE')) if $self->getenv('CAFILE');
+	    push(@ca,cadir=>$self->getenv('CADIR')) if $self->getenv('CADIR');
+	    my $res = $self->{_ldap}->start_tls(verify=>'require',@ca);
+	    if ($res->code)
+	      {
+		if ($starttls =~ /require/i)
+		  {
+		    die "START_TLS: ".$res->error."\n";
+		  }
+		else
+		  {
+		    warn "START_TLS: ".$res->error."\n";
+		  }
+	      }
+	    else
+	      {
+		$self->{_ssl}++;
+	      }
+	  }
+      }
+    $self->setup_autocompletion();
+    die "Unable to connect" unless $self->{_ldap};
+  }
+
+sub yesno
+  {
+    my $self = shift;
+    my $prompt = shift;
+
+    'yes' eq $self->askfor("$prompt [yes|no] ",0,'\s*(yes|no)\s*');
+  }
+
+sub askfor
+  {
+    my $self = shift;
+    my $prompt = shift;
+    my $noecho = shift;
+    my $regexp = shift || '\s*(\S+)\s*';
+
+    my $value;
+    while (! defined $value)
+      {
+	system "stty -echo" if $noecho;
+	print $prompt;
+	$value = <STDIN>;
+	chomp($value);
+	if ($noecho)
+	  {
+	    system "stty echo";
+	    print "\n";
+	  }
+	next unless ($value) = $value =~ /$regexp/;
+      }
+    $value;
+  }
+
+sub getUser
+  {
+    my $self = shift;
+    my $uid = shift;
+    my $attrs = shift;
+
+    my $c = $self->connection;
+    my $res = $c->search(base=>$self->getenv('BASE'),filter=>"uid=$uid",attrs=>$attrs || ['objectClass','uid']);
+    $res = $c->search(base=>$self->getenv('BASE'),filter=>"sAMAccountName=$uid",attrs=>$attrs || ['objectClass','sAMAccountName']) if $res->code;
+    $res->code && die $res->error;
+    return $res->pop_entry();
+  }
+
+sub dologin
+  {
+    my $self = shift;
+    my $user = shift;
+
+    unless ($user)
+      {
+	$user = $self->askfor("Username: ");
+      }
+    my $ue = $self->getUser($user);
+    die "No such user $user\n" unless $ue;
+    $self->authenticate($ue->dn(),@_);
+  }
+
+sub authenticate
+  {
+    my $self = shift;
+    my $dn = shift;
+
+    if (!$self->getenv('AUTH') || $self->getenv('AUTH') =~ /plain/is)
+      {
+	if ($self->getenv('NOCLUE'))
+	  {
+	    warn "*** You have set DSH_NOCLUE=1. I will send passwords in the clear.\n" unless $self->{_ssl};
+	  }
+	else
+	  {
+	    die "I refuse to send passwords in the clear. Enable ssl/start_tls\n" unless $self->{_ssl};
+	  }
+	my $pass = $self->askfor("Password for $dn: ",1);
+	my $res = $self->{_ldap}->bind($dn,password=>$pass,version=>3);
+	$res->code && die $res->error;
+	$self->{_authenticated} = $dn;
+      }
+    elsif ($self->getenv('AUTH') =~ /sasl/is)
+      {
+	use Authen::SASL;
+	my $sasl = Authen::SASL->new(mechanism=>$self->getenv('SASL_MECH') || 'GSSAPI');
+	my $res = $self->{_ldap}->bind($dn,sasl=>$sasl,version=>3);
+	$res->code && die $res->error;
+	$self->{_authenticated} = $dn;
+      }
+    else
+      {
+	die "Unknown authentication method \"".$self->getenv('AUTH')."\"";
+      }
+  }
+
+
+sub getDN
+  {
+    my $self = shift;
+    my $ustr = shift;
+
+    my $path;
+    my @paths;
+    if ($ustr =~ /^ldap:/)
+      {
+	my $uri = URI->new($ustr);
+
+	$path = $uri->path;
+	my ($host,$port) = $uri->opaque =~ /\/\/([^\/:]+):?([0-9]+)*$path$/;
+	$path =~ s/^\///o;
+	if ($host || $port)
+	  {
+	    if ($self->{_server} ne $host || $self->{_port} ne $port)
+	      {
+		$self->{_server} = $host;
+		$self->{_port} = $port;
+		$self->reconnect();
+	      }
+	  }
+	push(@paths,$path);
+      }
+    elsif ($ustr =~ /^~(.+)/)
+      {
+        my $e = $self->getUser($1);
+        die "No such user $1\n" unless ref $e;
+	push(@paths,$e->dn());
+      }
+    elsif ($ustr =~ /^\*(.+)/)
+      {
+	my $res = $self->connection->search(filter=>'objectClass=*',
+					    base=>$self->{_base},
+					    scope=>'base');
+	$res->code && die $res->error;
+	my $e = $res->pop_entry();
+	die "No such entry: ".$self->{_base}."\n" unless $e;
+	my @v = $e->get_value($1);
+	die "No such attribute \'$1\'\n" unless @v;
+	push(@paths,@v);
+      }
+    elsif ($ustr =~ /^(\/?)\?(.+)/)
+      {
+	my $base = $1 ? '' : $self->{_base};
+	my $res =
+	  $self->connection->search(base=>$base,
+				    filter=>$2,
+				    scope=>'sub',
+				    attrs=>['objectClass']);
+	$res->code && die "LDAP Error: ".$res->error."\n";
+	foreach my $e ($res->all_entries)
+	  {
+	    push(@paths,$e->dn());
+	  }
+	die "No entry matching search for $2 below $base\n" unless @paths;
+      }
+    elsif ($ustr =~ /([a-zA-Z0-9-]\.)+/s)
+      {
+	my @dc = split /\./,$ustr;
+	push(@paths,join(',',map { "dc=$_" } @dc));
+      }
+    else
+      {
+	$ustr =~ s/\/$//o;
+	my $abs;
+	$abs++ if $ustr =~ s/^\///;
+	$ustr = join(',',reverse(split(/\//,$ustr)));
+	push(@paths,$ustr.($self->{_base} && !$abs ? ','.$self->{_base} : ''));
+      }
+
+    map
+      {
+	my $mod = 1;
+	while ($mod)
+	  {
+	    $mod = 0;
+	    $mod++ if s/\.\.,([^,]+)//o;
+	    $mod++ if s/\.,([^,]+)/$1/g;
+	    $mod++ if s/^\.$//o;
+	    $mod++ if s/^\.\.$//o;
+	    $mod++ if s/^,//o;
+	    $mod++ if s/,$//o;
+	    $mod++ if s/^,//o;
+	    $mod++ if s/,,/,/o;
+	  }
+      } @paths;
+
+    wantarray ? @paths : $paths[0];
+  }
+
+sub dequote
+  {
+    shift;
+    local $_ = shift;
+
+    s/^\"//og;
+    s/\"$//og;
+    s/^\'//og;
+    s/\'$//og;
+    $_;
+  }
+
+sub url
+  {
+    my $self = shift;
+
+    return "not connected" unless $self->{_server};
+
+    if (!$self->{_port} || $self->{_port} == 389)
+      {
+	sprintf "ldap://%s/%s",$self->{_server},$self->{_base}
+      }
+    else
+      {
+	sprintf "ldap://%s:%d/%s",$self->{_server},$self->{_port},$self->{_base}
+      }
+  }
+
+sub displayUrl
+  {
+    $_[0]->tolatin1($_[0]->url);
+  }
+
+sub prompt
+  {
+    my $self = shift;
+
+    my $auth = $self->{_authenticated};
+    my $durl = $self->displayUrl();
+    my $len = length($durl);
+    sprintf "[%s%s]>",defined $auth ? '*' : '',($len > 37 ? substr($durl,0,37)." ..." : $durl);
+  }
+
+sub connection
+  {
+    $_[0]->{_ldap};
+  }
+
+sub get
+  {
+    die "Not connected\n" unless $_[0]->{_server};
+
+    $_[0]->{_rp}->get();
+  }
+
+sub free
+  {
+    $_[0]->{_rp}->free($_[1]);
+  }
+
+sub print
+  {
+    my $self = shift;
+
+    print @_;
+  }
+
+sub printf
+  {
+    my $self = shift;
+
+    printf @_;
+  }
+
+sub rdn
+  {
+    my @rdns = split /\s*,\s*/,$_[1];
+    $rdns[0];
+  }
+
+sub write
+  {
+    my $self = shift;
+    my $e = shift;
+
+    $self->printf("\n%s:\n\n",$self->tolatin1($e->dn()));
+    my $len = 0;
+    foreach my $attr ($e->attributes)
+      {
+        my $alen = length($attr);
+        $len = $len > $alen ? $len : $alen;
+      }
+    $len+=2;
+    foreach my $attr ($e->attributes)
+      {
+        foreach my $value ($e->get_value($attr))
+          {
+            $self->printf("%${len}s: %s\n",$attr,$self->tolatin1($value));
+          }
+      }
+    $self->print("\n");
+  }
+
+sub split
+  {
+    $_[1] =~ s/\\\ /%20;/og;
+    my @parts = split /\s+/,$_[1];
+    map { s/%20;/\\\ /og; $_ } @parts;
+  }
+
+sub loop
+  {
+    my $self = shift;
+
+    foreach my $cmd (keys %LDAPShell::Builtins::builtins)
+      {
+	no warnings;
+	eval "sub $cmd { \$self->_$cmd(\@_); }";
+	die $@ if $@;
+      }
+
+    while (defined ($_ = $self->{_term}->readline($self->prompt())) )
+      {
+	my @parts = $self->split($_);
+	if (ref $LDAPShell::Builtins::builtins{$parts[0]})
+	  {
+	    my $cmd = shift @parts;
+	    my $spec = $LDAPShell::Builtins::builtins{$cmd};
+	    eval
+	      {
+		my %args;
+		my @opts = @{$spec->[1]};
+		local @ARGV = @parts;
+		if (@opts && @ARGV)
+		  {
+		    GetOptions(\%args,@opts)
+		      or die "Usage: $spec->[2]\n";
+		  }
+		&{$spec->[0]}($self,\%args,@ARGV)
+	      };
+	  }
+	else
+	  {
+	    eval;
+	  }
+	print "** $@\n" if $@;
+      }
+  }
+
+package LDAPShell::Builtins;
+@LDAPShell::Builtins::ISA = qw(LDAPShell);
+use Net::LDAP qw(LDAP_NO_SUCH_OBJECT);
+
+use vars qw(%builtins);
+
+%builtins = (
+	     ls => [\&_ls,['filter:s'],"ls [--filter=<ldap filter>] <what>"],
+	     cat => [\&_cat,['format=s','attributes=s'],"cat [--format=<ldif|dsml|dump*>] [--attributes=<attr list>] <object>?"],
+	     cd => [\&_cd,[],"cd <object>"],
+	     pwd => [\&_pwd,[],"pwd"],
+	     add => [\&_add,['interactive!'],"add [--interactive] -- {<attribute>=<value>}+"],
+	     modify => [\&_modify,['interactive!'],"modify [--interactive] [<what>] -- {[+|-|&|!]<attribute>=<value>}+"],
+	     delete => [\&_delete,['interactive!'],"delete [--interactive] [<object>]"],
+	     mv => [\&_mv,['interactive!'],"mv [--interactive] <object>+"],
+	     logout => [\&_logout,[],"logout"],
+	     login => [\&_login,[],["login [<user>]"]],
+	     auth => [\&_auth,[],["auth [<dn>]"]],
+	     whoami => [\&_whoami,[],["whoami"]],
+	    );
+
+sub _def
+  {
+    my $self = shift;
+    my $args = shift;
+    my $name = shift;
+    my $block = shift;
+
+    $builtins{$name} = eval "sub _$name { my \$self = shift; my \$args = shift; eval \"$block\" }";
+  }
+
+sub _whoami
+  {
+    my $self = shift;
+    my $args = shift;
+
+    $self->print($self->{_authenticated} ? "$self->{_authenticated}\n" : "anonymous\n");
+  }
+
+sub _ls
+  {
+    my $self = shift;
+    my $args = shift;
+    my $c = $self->connection;
+    # The semantics of ls forbids us to ls multiple directories so we
+    # don't want an array here.
+    my $dn = $self->getDN($self->toutf8($_[0]));
+    my $res = $c->search(base=>$dn,
+			 scope=>'one',
+			 filter=>$args->{'filter'} || 'objectClass=*',
+			 attr=>['objectClass']);
+    $res->code && die "ls $dn:".$res->error."\n";
+    my $line;
+    my @rdns;
+    foreach my $e ($res->all_entries)
+      {
+	push(@rdns,$self->tolatin1($self->rdn($e->dn())));
+      }
+    my $tab = Text::FormatTable->new('l l l l l');
+    my @row; my $nc = 0;
+    foreach my $rdn (sort @rdns)
+      {
+	push(@row,$rdn);
+	$nc++;
+	if ($nc == 5)
+	  {
+	    $tab->row(@row);
+	    $nc = 0;
+	    @row = ();
+	  }
+      }
+    foreach (my $i = $nc; $i < 5; $i++)
+      {
+	push(@row,'');
+      }
+    $tab->row(@row);
+    $self->print($tab->render);
+  }
+
+sub _cat
+  {
+    my $self = shift;
+    my $args = shift;
+
+    my @dn = $self->getDN($self->toutf8($_[0]));
+    my @attrs = split(',',$args->{attributes}) if $args->{attributes};
+
+    my $writer;
+    my $format = $args->{format} || 'dump';
+    if ($format eq 'ldif')
+      {
+        use Net::LDAP::LDIF;
+	$writer = Net::LDAP::LDIF->new(\*STDOUT,"w");
+      }
+    elsif ($format eq 'dsml')
+      {
+	use Net::LDAP::DSML;
+	$writer = Net::LDAP::DSML->new();
+	$writer->open(\*STDOUT);
+      }
+    else
+      {
+	$writer = $self;
+      }
+
+    foreach my $dn (@dn)
+      {
+	my $res = $self->connection->search(scope=>'base',
+					    base=>$dn,
+					    attrs=>\@attrs,
+					    filter=>'objectClass=*');
+	$res->code && die "cat $dn: ".$res->error."\n";
+	my $e = $res->pop_entry();
+	die "No such entry: $dn\n"
+	  unless UNIVERSAL::isa($e,'Net::LDAP::Entry');
+
+	$args->{diff} ? $writer->write_cmd($e) : $writer->write($e);
+      }
+
+    $writer->finish() if $format eq 'dsml';
+  }
+
+sub _login
+  {
+    my $self = shift;
+    my $args = shift;
+
+    $self->dologin($_[0] || $self->getenv('USER'));
+  }
+
+sub _auth
+  {
+    my $self = shift;
+    my $args = shift;
+
+    $self->authenticate($_[0] || $self->getenv('USER') || $self->getenv('AUTHDN'));
+  }
+
+sub _logout
+  {
+    my $self = shift;
+    my $args = shift;
+
+    $self->reconnect();
+  }
+
+sub _pwd
+  {
+    my $self = shift;
+    my $args = shift;
+
+    $self->print($self->displayUrl(),"\n");
+  }
+
+sub _cd
+  {
+    my $self = shift;
+    my $args = shift;
+
+    my $dir = $self->toutf8($_[0]);
+    $dir = ($self->getenv('HOME') || $self->{_authenticated} || '/') unless $dir;
+    my $dn = $self->getDN($dir);
+    my $res = $self->connection->search(base=>$dn,
+					filter=>'objectClass=*',
+					scope=>'base',
+					attrs=>['objectClass']);
+    $res->code && $res->code != LDAP_NO_SUCH_OBJECT && die "cd $dn: ".$res->error."\n";
+    $res->code == LDAP_NO_SUCH_OBJECT && do {
+      $self->printf("cd: %s: %s\n",$dn,$res->error);
+      $dn = $res->dn();
+    };
+    $self->{_base} = $dn;
+    $self->setup_autocompletion();
+  }
+
+sub __moddn
+  {
+    my $self = shift;
+    my $e = shift;
+    my @newdn = @_;
+
+    my $newrdn = shift @newdn;
+
+    $e->replace(newrdn => $newrdn,
+		newsuperior => join(',',@newdn),
+		deleteoldrdn => 1);
+
+    $e->changetype('moddn');
+  }
+
+sub _mv
+  {
+    my $self = shift;
+    my $args = shift;
+
+    my @dn;
+    foreach my $expr (@_)
+      {
+	push(@dn,$self->getDN($self->toutf8($expr)));
+      }
+    my $target_dn = pop @dn;
+    my $res = $self->connection->search(filter=>'objectClass=*',
+					scope=>'base',
+					base=>$target_dn);
+    $res->code && die "mv $target_dn: ".$res->error."\n";
+    my $target_entry = $res->pop_entry();
+    my @target_rdns = split(',',$target_dn);
+    if (ref $target_entry)
+      {
+	foreach my $dn (@dn)
+	  {
+	    my $nres = $self->connection->search(filter=>'objectClass=*',
+				 		scope=>'base',
+						base=>$dn);
+	    $nres->code && die "mv $dn: ".$nres->error."\n";
+	    my $e = $nres->pop_entry();
+	    next unless ref $e;
+	    my @rdns = split(',',$dn);
+	    my $rdn = shift @rdns;
+	    &__moddn($self,$e,$rdn,@target_rdns);
+	    if ($args->{interactive})
+	      {
+		$self->write($e);
+		$self->print("\n");
+		die "Cancelled\n" unless $self->yesno("++ Really complete this move/rename?");
+	      }
+	    my $res = $e->update($self->connection);
+	    $res->code && die "mv $dn: ".$res->error."\n";
+	    $self->setup_autocompletion();
+	  }
+      }
+    else
+      {
+	die "Last argument must be a container when moving multiple targets\n"
+	  unless 1 == @dn;
+	my $nres = $self->connection->search(filter=>'objectClass=*',
+					    scope=>'base',
+					    base=>$dn[0]);
+	$nres->code && die "mv $dn[0]: ".$nres->error."\n";
+	my $e = $nres->pop_entry();
+	die "No such entry: $dn[0]\n" unless ref $e;
+	&__moddn($self,$e,@target_rdns);
+	if ($args->{interactive})
+	  {
+	    $self->write($e);
+	    $self->print("\n");
+	    die "Cancelled\n" unless $self->yesno("++ Really complete this move/rename?");
+	  }
+	my $res = $e->update($self->connection);
+	$res->code && die "mv $dn[0]: ".$res->error."\n";
+	$self->setup_autocompletion();
+      }
+  }
+
+sub _utf_eq
+  {
+    my ($self,$a,$b,$caseexact) = @_;
+
+    if ($caseexact)
+      {
+	return $a eq $b;
+      }
+    else
+      {
+	my $ua = $self->tolatin1($a);
+	my $ub = $self->tolatin1($b);
+	return uc($ua) eq uc($ub);
+      }
+  }
+
+sub _add
+  {
+    my $self = shift;
+    my $args = shift;
+
+    my $dn = $self->getDN();
+    my $c = $self->connection;
+    my $res = $c->search(filter=>'objectClass=*',
+			 base=>$dn,
+			 scope=>'base');
+    $res->code && die "add $dn: ".$res->error."\n";
+    my $pe = $res->pop_entry();
+    die "No such entry \'$dn\'\n"
+      unless $pe;
+    my $e = Net::LDAP::Entry->new();
+    my $rdn;
+    foreach my $av (@_)
+      {
+	my ($c,$a,$v) = $av =~ /([+-]?)([^+-=]+)\s*=?\s*(.*)/;
+	die "Improperly formatted add request: \'$av\'\n"
+	  unless $a && $v;
+	$rdn = "$a=$v" unless $rdn;
+	$e->add($a => $v);
+      }
+    die "Must specify an RDN\n" unless $rdn;
+    my @dn = ($rdn);
+    push(@dn,$dn) if $dn;
+    $e->dn(join(',',@dn));
+    $self->callbacks->add_callbacks($e,$self->connection);
+    if ($args->{interactive})
+      {
+	$self->write($e);
+	$self->print("\n");
+	die "Cancelled\n" unless $self->yesno("++ Really ADD this entry?");
+      }
+    $res = $e->update($c);
+    $res->code && die "add ".$e->dn().": ".$res->error."\n";
+    $self->setup_autocompletion();
+  }
+
+sub _modify
+  {
+    my $self = shift;
+    my $args = shift;
+
+    my $dir = shift;
+    foreach my $dn ($self->getDN($self->toutf8($dir)))
+      {
+	my $res = $self->connection->search(filter=>'objectClass=*',
+					    base=>$dn,
+					    scope=>'base');
+	$res->code && die "modify $dn: ".$res->error."\n";
+	my $e = $res->pop_entry();
+	die "No such entry $dn\n" unless $e;
+
+	my $mod = 0;
+	my @ma;
+	foreach my $av (@_)
+	  {
+	    my $avc = $av;
+	    my ($c,$a,$eq,$v);
+	    $avc =~ s/^([\+\-\&]?)([^\&\+\-=]+)\s*//o;
+	    $c = $1;
+	    $a = $2;
+	    if ($avc)
+	      {
+		$avc =~ s/(==|=)\s*(.*)//o;
+		$eq = $1;
+		$v = LDAPShell::_unescapespace($2);
+	      }
+	    if ($c eq '&')
+	      {
+		die "Improperly formatted value append request: \'$av\'\n"
+		  unless $a && $v;
+		$e->add($a => $v),$mod++,push(@ma,$a) unless
+		  grep { _utf_eq($self,$_,$v,$eq eq '='); } $e->get_value($a);
+	      }
+	    elsif ($c eq '+')
+	      {
+		die "Improperly formatted add request: \'$av\'\n"
+		  unless $a && $v;
+		$e->add($a => $v),$mod++,push(@ma,$a);
+	      }
+	    elsif ($c eq '-')
+	      {
+		die "Improperly formatted remove request: \'$av\'\n"
+		  unless $a;
+		unless ($v)
+		  {
+		    $e->delete($a),$mod++,push(@ma,$a);
+		  }
+		else
+		  {
+		    my @v = $e->get_value($a);
+		    my @nv = grep { !_utf_eq($self,$v,$_,$eq eq '='); } @v;
+		    $e->replace($a => \@nv),$mod++,push(@ma,$a) if scalar @nv != scalar @v;
+		  }
+	      }
+	    else
+	      {
+		die "Improperly formatted replace request: \'$av\'\n"
+		  unless $a && $v;
+		$e->replace($a => $v),$mod++,push(@ma,$a);
+	      }
+	  }
+	$self->print("No modifications required\n"),next unless $mod;
+	$self->callbacks->modify_callbacks($e,$self->connection,\@ma);
+
+	if ($args->{interactive})
+	  {
+	    $self->write($e);
+	    $self->print("\n");
+	    die "Cancelled\n" unless $self->yesno("++ Really save these MODIFIED attributes?");
+	  }
+	
+	$res = $e->update($self->connection);
+	$res->code && die "mv ".$e->dn().": ".$res->error."\n";
+      }
+    $self->setup_autocompletion();
+  }
+
+sub _delete
+  {
+    my $self = shift;
+    my $args = shift;
+
+    foreach my $dn ($self->getDN($self->toutf8($_[0])))
+      {
+	my $res = $self->connection->search(filter=>'objectClass=*',
+					    base=>$dn,
+					    scope=>'base');
+	$res->code && $res->error;
+	my $e = $res->pop_entry();
+	die "No such entry $dn\n" unless $e;
+	$e->delete();
+	if ($args->{interactive})
+	  {
+	    $self->write($e);
+	    $self->print("\n");
+	    die "Cancelled\n" unless $self->yesno("++ Really DELETE this entry?");
+	  }
+	$res = $e->update($self->connection);
+	$res->code && die "delete ".$e->dn().": ".$res->error."\n";
+      }
+    $self->setup_autocompletion();
+  }
+
+
+package LDAPShell;
+
+1;
+__END__
+# Below is stub documentation for your module. You better edit it!
+
+=head1 NAME
+
+LDAPShell - Perl extension for blah blah blah
+
+=head1 SYNOPSIS
+
+  use LDAPShell;
+  blah blah blah
+
+=head1 DESCRIPTION
+
+Stub documentation for LDAPShell, created by h2xs. It looks like the
+author of the extension was negligent enough to leave the stub
+unedited.
+
+Blah blah blah.
+
+=head2 EXPORT
+
+None by default.
+
+
+=head1 AUTHOR
+
+A. U. Thor, E<lt>a.u.thor@a.galaxy.far.far.awayE<gt>
+
+=head1 SEE ALSO
+
+L<perl>.
+
+=cut
diff --git a/LDAPShell/CVS/Entries b/LDAPShell/CVS/Entries
new file mode 100755
index 0000000..f58e41c
--- /dev/null
+++ b/LDAPShell/CVS/Entries
@@ -0,0 +1,2 @@
+/Callbacks.pm/1.1.1.1/Mon Feb 17 22:14:12 2003//
+D
diff --git a/LDAPShell/CVS/Repository b/LDAPShell/CVS/Repository
new file mode 100755
index 0000000..e12e473
--- /dev/null
+++ b/LDAPShell/CVS/Repository
@@ -0,0 +1 @@
+LDAPShell/LDAPShell
diff --git a/LDAPShell/CVS/Root b/LDAPShell/CVS/Root
new file mode 100755
index 0000000..1c43cd7
--- /dev/null
+++ b/LDAPShell/CVS/Root
@@ -0,0 +1 @@
+:ext:leifj@cvs.it.su.se:/afs/su.se/services/cvs/public/cvsroot
diff --git a/LDAPShell/Callbacks.pm b/LDAPShell/Callbacks.pm
new file mode 100755
index 0000000..b4e60ba
--- /dev/null
+++ b/LDAPShell/Callbacks.pm
@@ -0,0 +1,180 @@
+package LDAPShell::Callbacks;
+
+use Net::LDAP;
+
+@LDAPShell::Callbacks::ISA = qw(Exporter);
+@LDAPShell::Callbacks::EXPORT = qw(check_global_uid_uniqueness
+				   check_global_group_gid_uniqueness
+				   check_global_group_cn_uniqueness
+				   track_cn_and_displayname
+				   track_mail
+				   add_top_unless_present);
+
+sub new
+  {
+    my $self = shift;
+    my $class = ref $self || $self;
+
+    bless {},$class;
+  }
+
+sub add_callbacks
+  {
+    my $self = shift;
+    my $entry = shift;
+    my $ldap = shift;
+    my @attrs = @{shift} || $entry->attributes;
+
+    foreach my $attr (@attrs)
+      {
+	foreach my $cb (@{$self->{add}->{$attr}})
+	  {
+	    &$cb($ldap,$attr,$entry,\@attrs);
+	  }
+	foreach my $cb (@{$self->{any}->{$attr}})
+	  {
+	    &$cb($ldap,$attr,$entry,\@attrs);
+	  }
+      }
+  }
+
+sub modify_callbacks
+  {
+    my $self = shift;
+    my $entry = shift;
+    my $ldap = shift;
+    my @attrs = @{shift} || $entry->attributes;
+
+    foreach my $attr (@attrs)
+      {
+	foreach my $cb (@{$self->{modify}->{$attr}})
+	  {
+	    &$cb($ldap,$attr,$entry,\@attrs);
+	  }
+	foreach my $cb (@{$self->{any}->{$attr}})
+	  {
+	    &$cb($ldap,$attr,$entry,\@attrs);
+	  }
+      }
+  }
+
+sub callback
+  {
+    my $self = shift;
+    my $attr = shift;
+    my $type = shift;
+    my $code = shift;
+
+    die "Must be a CODE reference\n" unless ref $code eq 'CODE';
+
+    push(@{$self->{lc($type)}->{lc($attr)}},$code);
+  }
+
+sub check_global_uid_uniqueness
+  {
+    my $c = shift;
+    my $attr = shift;
+    my $entry = shift;
+    my $attrs = shift;
+
+    return unless grep /(uid|userid)/is,@{$attrs};
+    my $uid = $entry->get_value('uid');
+    $uid = $entry->get_value('userid') unless $uid;
+    return unless $uid;
+
+    my $res = $c->search(filter=>"uid=$uid",base=>'',attrs=>['uid']);
+    return if $res->code == LDAP_NO_SUCH_OBJECT;
+    $res->code && die "LDAP Error: ".$res->error."\n";
+    my $e = $res->pop_entry;
+    return unless $e;
+    $e->dump();
+    my $dn = $e->dn();
+    die "The username \'$uid\' already exists: \"$dn\"\n";
+  }
+
+sub check_global_group_cn_uniqueness
+  {
+    my $c = shift;
+    my $attr = shift;
+    my $entry = shift;
+    my $attrs = shift;
+
+    return unless $c->isA($entry,'posixGroup');
+    my $cn = $entry->get_value('cn');
+    return unless $cn;
+
+    my $res = $c->search(filter=>"(&(cn=$cn)(posixGroup))",base=>'',scope=>'sub',attrs=>['cn']);
+    return if $res->code == LDAP_NO_SUCH_OBJECT;
+    $res->code && die "LDAP Error: ".$res->error."\n";
+    my $e = $res->pop_entry;
+    return unless $e;
+    my $dn = $e->dn();
+    die "The group \'$cn\' already exists: \"$dn\"\n";
+  }
+
+sub check_global_group_gid_uniqueness
+  {
+    my $c = shift;
+    my $attr = shift;
+    my $entry = shift;
+    my $attrs = shift;
+
+    return unless $c->isA($e,'posixGroup');
+    my $gidNumber = $entry->get_value('gidNumber');
+    return unless $gidNumber;
+
+    my $res = $c->search(filter=>"(&(gidNumber=$gidNumber)(posixGroup))",base=>'',scope=>'sub',attrs=>['cn']);
+    return if $res->code == LDAP_NO_SUCH_OBJECT;
+    $res->code && die "LDAP Error: ".$res->error."\n";
+    my $e = $res->pop_entry;
+    return unless $e;
+    my $dn = $e->dn();
+    die "The group with GID \'$gidNumber\' already exists: \"$dn\"\n";
+  }
+
+sub track_cn_and_displayname
+  {
+    my $c = shift;
+    my $attr = shift;
+    my $entry = shift;
+    my $attrs = shift;
+
+    return unless $c->isA($entry,'inetOrgPerson');
+    return unless grep /sn/is,@{$attrs};
+    return unless grep /givenName/is,@{$attrs};
+
+    my $sn = $entry->get_value('sn');
+    my $givenName = $entry->get_value('givenName');
+    return unless $sn && $givenName;
+
+    my $cn = "$givenName $sn";
+    $entry->replace(cn=>$cn);
+    $entry->replace(displayName=>$cn);
+  }
+
+sub track_mail
+  {
+    my $c = shift;
+    my $attr = shift;
+    my $entry = shift;
+    my $attrs = shift;
+
+    return unless $c->isA($entry,'inetOrgPerson');
+    my $uid = $entry->get_value('uid');
+    my $domain = $c->domainOf($entry);
+    return unless $uid && $domain;
+    $entry->add(mail=>"$uid\@$domain") 
+      unless grep /$uid\@$domain/is,$entry->get_value('mail');
+  }
+
+sub add_top_unless_present
+  {
+    my $c = shift;
+    my $attr = shift;
+    my $entry = shift;
+    my $attrs = shift;
+
+    my @oc = $entry->get_value('objectClass');
+    push(@oc,'top') unless grep /top/is,@oc;
+    $entry->replace(objectClass=>\@oc);
+  }
diff --git a/MANIFEST b/MANIFEST
new file mode 100755
index 0000000..8364826
--- /dev/null
+++ b/MANIFEST
@@ -0,0 +1,9 @@
+Changes
+LDAPShell.pm
+Makefile.PL
+MANIFEST
+README
+dirsh
+adsh
+META.yml                                 Module meta-data (added by MakeMaker)
+LDAPShell/Callbacks.pm
diff --git a/META.yml b/META.yml
new file mode 100755
index 0000000..4b9600b
--- /dev/null
+++ b/META.yml
@@ -0,0 +1,21 @@
+# http://module-build.sourceforge.net/META-spec.html
+#XXXXXXX This is a prototype!!!  It will change in the future!!! XXXXX#
+name:         LDAPShell
+version:      1.00
+version_from: LDAPShell.pm
+installdirs:  site
+requires:
+    Getopt::Long:                  0
+    Net::LDAP:                     0
+    Net::LDAP::LDIF:               0
+    ResourcePool:                  0
+    ResourcePool::Factory::Net::LDAP: 0
+    Term::ANSIColor:               0
+    Term::ReadLine:                0
+    Term::ReadLine::Gnu:           0
+    Text::FormatTable:             0
+    Unicode::String:               0
+    URI:                           0
+
+distribution_type: module
+generated_by: ExtUtils::MakeMaker version 6.17
diff --git a/Makefile.PL b/Makefile.PL
new file mode 100755
index 0000000..b90d45d
--- /dev/null
+++ b/Makefile.PL
@@ -0,0 +1,23 @@
+use ExtUtils::MakeMaker;
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+WriteMakefile(
+    'NAME'		=> 'LDAPShell',
+    'VERSION_FROM'	=> 'LDAPShell.pm', # finds $VERSION
+    'PREREQ_PM'		=> {
+			    Net::LDAP=>0,
+			    Net::LDAP::LDIF=>0,
+			    Term::ReadLine::Gnu=>0,
+			    Term::ReadLine=>0,
+			    Term::ANSIColor=>0,
+			    Getopt::Long=>0,
+			    URI=>0,
+			    Text::FormatTable=>0,
+			    Unicode::String=>0,
+			    ResourcePool=>0,
+			    ResourcePool::Factory::Net::LDAP=>0
+			   },
+    ($] >= 5.005 ?    ## Add these new keywords supported since 5.005
+      (ABSTRACT_FROM => 'LDAPShell.pm', # retrieve abstract from module
+       AUTHOR     => 'A. U. Thor <a.u.thor@a.galaxy.far.far.away>') : ()),
+);
diff --git a/README b/README
new file mode 100755
index 0000000..d2e8212
--- /dev/null
+++ b/README
@@ -0,0 +1,35 @@
+LDAPShell version 0.01
+======================
+
+The README is used to introduce the module and provide instructions on
+how to install the module, any machine dependencies it may have (for
+example C compilers and installed libraries) and any other information
+that should be provided before the module is installed.
+
+A README file is required for CPAN modules since CPAN extracts the
+README file from a module distribution so that people browsing the
+archive can use it get an idea of the modules uses. It is usually a
+good idea to provide version information here so that people can
+decide whether fixes for the module are worth downloading.
+
+INSTALLATION
+
+To install this module type the following:
+
+   perl Makefile.PL
+   make
+   make test
+   make install
+
+DEPENDENCIES
+
+This module requires these other modules and libraries:
+
+  blah blah blah
+
+COPYRIGHT AND LICENCE
+
+Put the correct copyright and licence information here.
+
+Copyright (C) 2002 A. U. Thor blah blah blah
+
diff --git a/adsh b/adsh
new file mode 100755
index 0000000..bb4f587
--- /dev/null
+++ b/adsh
@@ -0,0 +1,7 @@
+#!/bin/sh
+
+export KRB5_CONFIG=$HOME/krb5-ad.conf
+export DSH_AUTOCONNECT=ldap://adwsrv01.win.su.se/dc=win,dc=su,dc=se
+export DSH_AUTH=sasl
+export DSH_BASE="dc=win,dc=su,dc=se"
+dirsh
diff --git a/dirsh b/dirsh
new file mode 100755
index 0000000..b48a2e5
--- /dev/null
+++ b/dirsh
@@ -0,0 +1,37 @@
+#!/usr/bin/env perl
+
+use lib './blib/lib/';
+use LDAPShell;
+use Getopt::Long;
+
+my $usage=<<EOU;
+Usage: $0
+
+$0 is a command-line shell for administration of directory-based information.
+Using $0 it is possible to add, delete and modify entries in a directory. The
+shell presents a filesystem-like interface (with some support for tab-completion
+of directory names) to a directory server.
+
+$0 always runs over a secure connection (using TLS) and will not start unless
+the START_TLS extended operation is supported by the directory server.
+
+$0 implements a basic set of unix-like command look-alikes (cd,ls,pwd etc)
+together with a few ldap-specific commands (modify,add,delete) and add-ons which
+perform specific tasks (for instance the 'user' command which looks up a user based
+on the 'uid' attribute).
+
+$0 supports the notion of basic batch-file like scripts. These script are simply
+lines which are executed one line at a time with simple substitution of command
+line arguments from the batch-file call (%{0} is the first variable etc etc). Such
+scripts can be used to automate tasks (creating new users, gropus, or adding members
+to groups for instance).
+
+EOU
+
+my %args = ('verbose'=>0,'help'=>0);
+my @args = ("config=s","verbose+","help!","template=s");
+GetOptions(\%args,@args) or die $usage;
+die $usage if $args{help};
+
+my $shell = LDAPShell->new($ini);
+$shell->loop();
diff --git a/test.pl b/test.pl
new file mode 100755
index 0000000..da79591
--- /dev/null
+++ b/test.pl
@@ -0,0 +1,17 @@
+# Before `make install' is performed this script should be runnable with
+# `make test'. After `make install' it should work as `perl test.pl'
+
+#########################
+
+# change 'tests => 1' to 'tests => last_test_to_print';
+
+use Test;
+BEGIN { plan tests => 1 };
+use LDAPShell;
+ok(1); # If we made it this far, we're ok.
+
+#########################
+
+# Insert your test code below, the Test module is use()ed here so read
+# its man page ( perldoc Test ) for help writing this test script.
+