Example code from Perl for System Administration by David N. Blank-Edelman
O'Reilly and Associates, 1st Edition, ISBN 1-56592-609-9

Chapter Three
=============
#*
#* parsing the UNIX password file "by hand"
#*

$passwd = "/etc/passwd";
open(PW,$passwd) or die "Can't open $passwd:$!\n";
while (<PW>){
    ($name,$passwd,$uid,$gid,$gcos,$dir,$shell) = split(/:/);
    # <your code here>
}
close(PW);
-------
#*
#* parsing the UNIX password file using the system libraries
#*
while(($name,$passwd,$uid,$gid,$gcos,$dir,$shell) = getpwent()){
       # <your code here>
}
endpwent();           
-------
#*
#* finding the next available UID
#*

$passwd = "/etc/passwd";
open(PW,$passwd) or die "Can't open $passwd:$!\n";
while (<PW>){
    @fields = split(/:/);
    $highestuid = ($highestuid < $fields[2]) ? $fields[2] : $highestuid;
}
close(PW);
print "The next available UID is " . ++$highestuid . "\n";
-------
#*
#* check to make sure every user owns their own home directory and
#* that the directory is not world writeable
#*

use User::pwent;
use File::stat;

# note: this code will beat heavily upon any machine using automounted homedirs
while($pwent = getpwent()){
    # make sure we stat the actual dir,even through layers of symlink
    # indirection
    $dirinfo = stat($pwent->dir."/."); 
    unless (defined $dirinfo){
        warn "Unable to stat ".$pwent->dir.": $!\n";
        next;
    }
    warn $pwent->name."'s homedir is not owned by the correct uid (".
      $dirinfo->uid." instead ".$pwent->uid.")!\n"
        if ($dirinfo->uid != $pwent->uid);

    # world writable is fine if dir is set "sticky" (i.e. 01000), 
    # see the manual page for chmod for more information
    warn $pwent->name."'s homedir is world-writable!\n"
      if ($dirinfo->mode & 022 and (!$stat->mode & 01000));
}

endpwent();
-------
#*
#* check to make sure all users have "standard" shells
#*

use User::pwent;

$shells = "/etc/shells";
open (SHELLS,$shells) or die "Unable to open $shells:$!\n";
while(<SHELLS>){
    chomp;
    $okshell{$_}++;
}
close(SHELLS);

while($pwent = getpwent()){
   warn $pwent->name." has a bad shell (".$pwent->shell.")!\n"
     unless (exists $okshell{$pwent->shell});
}
endpwent();
-------
#*
#* dump information about all local users on an NT/2000 machine
#*

use Win32::AdminMisc

# retrieve all of the local users
Win32::AdminMisc::GetUsers('','',\@users) or 
   die "Unable to get users: $!\n";

# get their attributes and print them
foreach $user (@users){
  Win32::AdminMisc::UserGetMiscAttributes('',$user,\%attribs) or 
    warn "Unable to get attrib: $!\n";
  print join(":",$user,
                 '*',
                 $attribs{USER_USER_ID},
                 $attribs{USER_PRIMARY_GROUP_ID},
                 '',
                 $attribs{USER_COMMENT},
                 $attribs{USER_FULL_NAME},
                 $attribs{USER_HOME_DIR_DRIVE}."\\".
                 $attribs{USER_HOME_DIR},
                 ''),"\n";
}
-------
#*
#* show the RID for a particular user on an NT/2000 machine
#*

use Win32::AdminMisc;

Win32::AdminMisc::UserGetMiscAttributes('',$user,\%attribs);
print $attribs{USER_USER_ID},"\n";
-------
#*
#* change the owner of a directory (and its contents) on NT/2000
#*

use Win32::Perms;
    
$acl  = new Win32::Perms();
$acl->Owner($NewAccountName);
$result = $acl->SetRecurse($dir);
$acl->Close();
-------
#*
#* retrieve the user rights for the user 'Guest' on NT/2000
#*
use Win32::Lanman;

unless(Win32::Lanman::LsaLookupNames($server, ['Guest'], \@info)
       die "Unable to lookup SID: ".Win32::Lanman::GetLastError()."\n";

unless (Win32::Lanman::LsaEnumerateAccountRights($server, 
                                                 ${$info[0]}{sid},
                                                 \@rights);
	die "Unable to query rights: ".Win32::Lanman::GetLastError()."\n"; 
-------
#*
#* add the user right that enables a user to shut down a machine to 'Guest'
#*
use Win32::Lanman;

unless (Win32::Lanman::LsaLookupNames($server, ['Guest'], \@info))
	die "Unable to lookup SID: ".Win32::Lanman::GetLastError()."\n";

unless (Win32::Lanman::LsaAddAccountRights($server, ${$info[0]}{sid}, 
					   [&SE_SHUTDOWN_NAME]))
	die "Unable to change rights: ".Win32::Lanman::GetLastError()."\n"
-------
#*
#* a subroutine that queries a user for account info and then returns
#* a data structure with this information in it (used as part of our example
#* account system)
#*
sub CollectInformation{
    # list of fields init'd here for demo purposes, this should 
    # really be kept in a central configuration file
    my @fields = qw{login fullname id type password};
    my %record;

    foreach my $field (@fields){
        print "Please enter $field: ";
        chomp($record{$field} = <STDIN>);
    }
    $record{status}="to_be_created";
    return \%record; 
}
-------
#*
#* subroutine to append account information to a queue file in XML format
#*

sub AppendAccountXML {
    # receive the full path to the file
    my $filename = shift;
    # receive a reference to an anonymous record hash  
    my $record = shift;    

    # XML::Writer uses IO::File objects for output control
    use IO::File;

    # append to that file
    $fh = new IO::File(">>$filename") or 
      die "Unable to append to file:$!\n";

    # initialize the XML::Writer module and tell it to write to 
    # filehandle $fh
    use XML::Writer;
    my $w = new XML::Writer(OUTPUT => $fh);

    # write the opening tag for each <account> record
    $w->startTag("account");

    # write all of the <account> data start/end sub-tags & contents
    foreach my $field (keys %{$record}){
	print $fh "\n\t";
	$w->startTag($field);
	$w->characters($$record{$field});
	$w->endTag;
    }
    print $fh "\n";

    # write the closing tag for each <account> record
    $w->endTag;
    $w->end;
    $fh->close();
}
-------
#*
#* parsing our queue file using XML::Parser
#*

use XML::Parser;
use Data::Dumper; # used for debugging output, not needed for XML parse
$p = new XML::Parser(ErrorContext => 3, 
		     Style        => 'Stream',
		     Pkg          => 'Account::Parse');

# handle multiple account records in a single XML queue file
open(FILE,$addqueue) or die "Unable to open $addqueue:$!\n";

# this clever read idiom courtesy of Jeff Pinyan
read(FILE, $queuecontents, -s FILE);
$p->parse("<queue>".$queuecontents."</queue>");

package Account::Parse;

sub StartTag {
    undef %record if ($_[1] eq "account");
}

sub Text {
    my $ce = $_[0]->current_element();
    $record{$ce}=$_ unless ($ce eq "account");
}

sub EndTag {
    print Data::Dumper->Dump([\%record],["account"]) 
      if ($_[1] eq "account");    
    # here's where we'd actually do something, instead of just
    # printing the record
}
-------
#*
#* writing XML using XML::Simple
#*

use XML::Simple;

# rootname sets the root element's name, we could also use xmldecl to
# add an XML declaration
print XMLout($queue, rootname =>"queue"); 
-------
#*
#* reading and printing out a queue file using XML::Simple
#*

use XML::Simple;
use Data::Dumper;  # just needed to show contents of our data structures

$queuefile = "addqueue.xml";
open(FILE,$queuefile) or die "Unable to open $queuefile:$!\n";
read (FILE, $queuecontents, -s FILE);

$queue = XMLin("<queue>".$queuecontents."</queue>");

print Data::Dumper->Dump([$queue],["queue"]);
-------
#*
#* subroutine to transform an easy to work with data structure from an 
#* XML::Simple read into a the data structure necessary to write it back
#* out again using XML::Simple (see text for more details).
#*

sub TransformForWrite{
    my $queueref = shift;
    my $toplevel = scalar each %$queueref;

    foreach my $user (keys %{$queueref->{$toplevel}}){
      my %innerhash = 
	map {$_,[$queueref->{$toplevel}{$user}{$_}] } 
	  keys %{$queueref->{$toplevel}{$user}};
      $innerhash{'login'} = [$user];
      push @outputarray, \%innerhash;
    }

    $outputref = { $toplevel => \@outputarray};
    return $outputref;
}

# sample usage
$queue = XMLin("<queue>".$queuecontents."</queue>",keyattr => ["login"]);
# <manipulate the data>
print OUTPUTFILE XMLout(TransformForWrite($queue),rootname => "queue");
-------
#*
#* wrapping an XML parse in eval to protect against bad XML code
#*
eval {$p->parse("<queue>".$queuecontents."</queue>")};
if ($@) { 
 # <do something graceful to handle the error before quitting>
};
-------
#*
#* basic UNIX account creation routine
#*

# these variables should really be set in a central configuration file
$useraddex    = "/usr/sbin/useradd";  # location of useradd executable
$passwdex     = "/bin/passwd";        # location of passwd executable
$homeUNIXdirs = "/home";              # home directory root dir
$skeldir      = "/home/skel";         # prototypical home directory
$defshell     = "/bin/zsh";           # default shell

sub CreateUNIXAccount{
    
    my ($account,$record) = @_;

    ### construct the command line, using:
    # -c = Comment field
    # -d = home dir
    # -g = group (assume same as user type)
    # -m = create home dir
    # -k = and copy in files from this skeleton dir
    # (could also use -G group, group, group to add to auxiliary groups)
    my @cmd = ($useraddex, 
	       "-c", $record->{"fullname"},
	       "-d", "$homeUNIXdirs/$account",
	       "-g", $record->{"type"},
	       "-m",
	       "-k", $skeldir,
	       "-s", $defshell,
	       $account);
    
    print STDERR "Creating account...";
    my $result = 0xff & system @cmd;
    # the return code is 0 for success, non-0 for failure, so we invert
    if ($result){
        print STDERR "failed.\n";
        return "$useraddex failed";        
    }
    else {
        print STDERR "succeeded.\n";        
    }

    print STDERR "Changing passwd...";
    unless ($result = &InitUNIXPasswd($account,$record->{"password"})){
        print STDERR "succeeded.\n";
        return "";
    }
    else {
        print STDERR "failed.\n";
        return $result;
    }
}
-------
#*
#* basic UNIX account deletion routine
#*

# these variables should really be set in a central configuration file
$userdelex = "/usr/sbin/userdel";  # location of userdel executable

sub DeleteUNIXAccount{
    my ($account,$record) = @_;

    ### construct the command line, using:
    # -r = remove the account's home directory for us
    my @cmd = ($userdelex, "-r", $account);
    
    print STDERR "Deleting account...";
    my $result = 0xffff & system @cmd;