granicus.if.org Git - apache/blob - support/dbmmanage

   1 #!/usr/local/bin/perl
   2 # ====================================================================
   3 # The Apache Software License, Version 1.1
   4 #
   5 # Copyright (c) 2000 The Apache Software Foundation.  All rights
   6 # reserved.
   7 #
   8 # Redistribution and use in source and binary forms, with or without
   9 # modification, are permitted provided that the following conditions
  10 # are met:
  11 #
  12 # 1. Redistributions of source code must retain the above copyright
  13 #    notice, this list of conditions and the following disclaimer.
  14 #
  15 # 2. Redistributions in binary form must reproduce the above copyright
  16 #    notice, this list of conditions and the following disclaimer in
  17 #    the documentation and/or other materials provided with the
  18 #    distribution.
  19 #
  20 # 3. The end-user documentation included with the redistribution,
  21 #    if any, must include the following acknowledgment:
  22 #       "This product includes software developed by the
  23 #        Apache Software Foundation (http://www.apache.org/)."
  24 #    Alternately, this acknowledgment may appear in the software itself,
  25 #    if and wherever such third-party acknowledgments normally appear.
  26 #
  27 # 4. The names "Apache" and "Apache Software Foundation" must
  28 #    not be used to endorse or promote products derived from this
  29 #    software without prior written permission. For written
  30 #    permission, please contact apache@apache.org.
  31 #
  32 # 5. Products derived from this software may not be called "Apache",
  33 #    nor may "Apache" appear in their name, without prior written
  34 #    permission of the Apache Software Foundation.
  35 #
  36 # THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESSED OR IMPLIED
  37 # WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
  38 # OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
  39 # DISCLAIMED.  IN NO EVENT SHALL THE APACHE SOFTWARE FOUNDATION OR
  40 # ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  41 # SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
  42 # LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
  43 # USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
  44 # ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
  45 # OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
  46 # OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
  47 # SUCH DAMAGE.
  48 # ====================================================================
  49 #
  50 # This software consists of voluntary contributions made by many
  51 # individuals on behalf of the Apache Software Foundation.  For more
  52 # information on the Apache Software Foundation, please see
  53 # <http://www.apache.org/>.
  54 #
  55 # Portions of this software are based upon public domain software
  56 # originally written at the National Center for Supercomputing Applications,
  57 # University of Illinois, Urbana-Champaign.
  58 #
  59 #for more functionality see the HTTPD::UserAdmin module:
  60 # http://www.perl.com/CPAN/modules/by-module/HTTPD/HTTPD-Tools-x.xx.tar.gz
  61 #
  62 # usage: dbmmanage <DBMfile> <command> <key> <value>
  63
  64 package dbmmanage;
  65 #                               -ldb    -lndbm    -lgdbm
  66 BEGIN { @AnyDBM_File::ISA = qw(DB_File NDBM_File GDBM_File) }
  67 use strict;
  68 use Fcntl;
  69 use AnyDBM_File ();
  70
  71 my($file,$command,$key,$crypted_pwd) = @ARGV;
  72
  73 usage() unless $file and $command and defined &{$dbmc::{$command}};
  74
  75 # if your osname is in $newstyle_salt, then use new style salt (starts with '_' and contains
  76 # four bytes of iteration count and four bytes of salt).  Otherwise, just use
  77 # the traditional two-byte salt.
  78 # see the man page on your system to decide if you have a newer crypt() lib.
  79 # I believe that 4.4BSD derived systems do (at least BSD/OS 2.0 does).
  80 # The new style crypt() allows up to 20 characters of the password to be
  81 # significant rather than only 8.
  82 my $newstyle_salt = join '|', qw{bsdos}; #others?
  83
  84 # remove extension if any
  85 my $chop = join '|', qw{db.? pag dir};
  86 $file =~ s/\.($chop)$//;
  87
  88 my $is_update = $command eq "update";
  89 my $Is_Win32  = $^O eq "MSWin32";
  90 my %DB = ();
  91 my @range = ();
  92 my($mode, $flags) = $command =~
  93     /^(?:view|check)$/ ? (0644, O_RDONLY) : (0644, O_RDWR|O_CREAT);
  94
  95 tie %DB, "AnyDBM_File", $file, $flags, $mode || die "Can't tie $file: $!";
  96 dbmc->$command();
  97 untie %DB;
  98
  99 sub usage {
 100     my $cmds = join "|", sort keys %dbmc::;
 101     die "usage: $0 filename [$cmds] [username]\n";
 102 }
 103
 104 my $x;
 105 sub genseed {
 106     my $psf;
 107     for (qw(-xlwwa -le)) {
 108         `ps $_ 2>/dev/null`;
 109         $psf = $_, last unless $?;
 110     }
 111     srand (time ^ $$ ^ unpack("%L*", `ps $psf | gzip -f`));
 112     @range = (qw(. /), '0'..'9','a'..'z','A'..'Z');
 113     $x = int scalar @range;
 114 }
 115
 116 sub randchar {
 117     join '', map $range[rand $x], 1..shift||1;
 118 }
 119
 120 sub salt {
 121     my $newstyle = $^O =~ /(?:$newstyle_salt)/;
 122     genseed() unless @range;
 123     return $newstyle ?
 124         join '', "_", randchar, "a..", randchar(4) :
 125         randchar(2);
 126 }
 127
 128 sub getpass {
 129     my $prompt = shift || "Enter password:";
 130
 131     unless($Is_Win32) {
 132         open STDIN, "/dev/tty" or warn "couldn't open /dev/tty $!\n";
 133         system "stty -echo;";
 134     }
 135
 136     my($c,$pwd);
 137     print STDERR $prompt;
 138     while (($c = getc(STDIN)) ne '' and $c ne "\n" and $c ne "\r") {
 139         $pwd .= $c;
 140     }
 141
 142     system "stty echo" unless $Is_Win32;
 143     print STDERR "\n";
 144     die "Can't use empty password!\n" unless length $pwd;
 145     return $pwd;
 146 }
 147
 148 sub dbmc::update {
 149     die "Sorry, user `$key' doesn't exist!\n" unless $DB{$key};
 150     dbmc->adduser;
 151 }
 152
 153 sub dbmc::add {
 154     die "Can't use empty password!\n" unless $crypted_pwd;
 155     unless($is_update) {
 156         die "Sorry, user `$key' already exists!\n" if $DB{$key};
 157     }
 158     $DB{$key} = $crypted_pwd;
 159     my $action = $is_update ? "updated" : "added";
 160     print "User $key $action with password encrypted to $DB{$key}\n";
 161 }
 162
 163 sub dbmc::adduser {
 164     my $value = getpass "New password:";
 165     die "They don't match, sorry.\n" unless getpass("Re-type new password:") eq $value;
 166     $crypted_pwd = crypt $value, caller->salt;
 167     dbmc->add;
 168 }
 169
 170 sub dbmc::delete {
 171     die "Sorry, user `$key' doesn't exist!\n" unless $DB{$key};
 172     delete $DB{$key}, print "`$key' deleted\n";
 173 }
 174
 175 sub dbmc::view {
 176     print $key ? "$key:$DB{$key}\n" : map { "$_:$DB{$_}\n" if $DB{$_} } keys %DB;
 177 }
 178
 179 sub dbmc::check {
 180     die "Sorry, user `$key' doesn't exist!\n" unless $DB{$key};
 181     print crypt(getpass(), $DB{$key}) eq $DB{$key} ? "password ok\n" : "password mismatch\n";
 182 }
 183
 184 sub dbmc::import {
 185     while(defined($_ = <STDIN>) and chomp) {
 186         ($key,$crypted_pwd) = split /:/, $_, 2;
 187         dbmc->add;
 188     }
 189 }
 190