The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/local/bin/perl -w
#
# $Id: mkdir.abigail,v 1.3 2004/08/05 14:20:34 cwest Exp $
#
# $Log: mkdir.abigail,v $
# Revision 1.3  2004/08/05 14:20:34  cwest
# cleanup, new version number on website
#
# Revision 1.1  2004/07/23 20:10:12  cwest
# initial import
#
# Revision 1.3  1999/03/09 02:53:25  abigail
# Removed the comparison of $dir to '.' and '/', as that's non-portable.
# All we need to do is checking for a fixed point.
#
# Revision 1.2  1999/03/09 02:44:57  abigail
# Fixed SybolicMode -> SymbolicMode typo.
#
# Revision 1.1  1999/03/09 02:27:17  abigail
# Initial revision
#
#

use strict;

my ($VERSION) = '$Revision: 1.3 $' =~ /([.\d]+)/;

my $warnings = 0;

$SIG {__WARN__} = sub {
    if (substr ($_ [0], 0, 14) eq "Unknown option") {die "Usage"};
    require File::Basename;
    $0 = File::Basename::basename ($0);
    $warnings = 1;
    warn "$0: @_";
};

$SIG {__DIE__} = sub {
    require File::Basename;
    $0 = File::Basename::basename ($0);
    if (substr ($_ [0], 0,  5) eq "Usage") {
        die <<EOF;
$0 (Perl bin utils) $VERSION
$0 [-p] [-m mode] directory [directories ...]
EOF
    }
    die "$0: @_";
};

# Get the options.
# We might be able to use Getopts, but the mode might be difficult.
my %options;
while (@ARGV && $ARGV [0] =~ /^-/) {
    local $_ = shift;

    /^-p$/ && do {$options {p} = 1; next;};
    /^-m$/ && do {
        die "Usage" unless @ARGV > 1;
        $options {m} = shift;
        next;
    };

    die "Usage";
}

die "Usage" unless @ARGV;

my $symbolic = 0;
if (exists $options {m} && $options {m} =~ /[^0-7]/) {
    require SymbolicMode;
    $symbolic = 1;
}

# Pay attention before you get lost. The argument list will be turned
# into a list of anon arrays. Each anon array has 2 elements, a directory
# name, and a flag to indicate whether it's an "intermediate" directory
# or not. "intermediate" directories are the directories interfered by
# -p, but not given on the command line. 
if (exists $options {p}) {
    require File::Basename;
    my @ARGV2;
    while (@ARGV) {
        my $dir = pop @ARGV;
        my $intermediate = 0;
        while ($dir ne File::Basename::dirname ($dir)) {
            push @ARGV2 => [$dir, $intermediate ++];
            $dir = File::Basename::dirname ($dir);
        }
    }
    @ARGV = reverse @ARGV2;
}
else {
    @ARGV = map {[$_ => 0]} @ARGV;
}

foreach my $directory (@ARGV) {
    my ($dir, $intermediate) = @$directory;

    # Existing directories don't create a warning when -p is in effect.
    next if -d $dir && exists $options {p};

    # Umask is applied on mkdir.
    mkdir $dir => 0777 or do {
        warn qq 'cannot create make directory "$dir": $!\n';
        next;
    };

    # Special case the intermediate directories.
    if ($intermediate) {
        # Get the current permissions of the directory; in oct.
        my $mode = sprintf "%03o" => (stat $dir) [2];
        unless (defined $mode) {
            # Skip to next directory of arg list.
            # The tests for @ARGV aren't really necessary.
            shift while @ARGV && $ARGV [0] -> [1];
            shift if    @ARGV;
            warn "stat on $dir failed: $!\n";
            next;
        }
        # Individual parts.
        my @modes   = split // => substr $mode => -3;

        # Turn on write and search permission for the user.
        $modes [0] |= 3;
        
        # Reassemble.
        $mode       = join "" => @modes;

        # Mode is an oct, remember?
        chmod oct ($mode) => $dir or do {
            warn "stat on $dir failed: $!\n";
            # Skip to next directory of arg list.
            # The tests for @ARGV aren't really necessary.
            shift while @ARGV && $ARGV [0] -> [1];
            shift if    @ARGV;
            next;
        };

        # -m has no effect on intermediate directories created due to -p.
        next;
    }

    next unless exists $options {m};

    my $realmode = $options {m};
    if ($symbolic) {
        $realmode = SymbolicMode::mod ($options {m}, $dir) or
                       die "invalid mode: $options{m}\n";
    }
    chmod oct ($realmode) => $dir or warn "$!\n";
}

__END__

=pod

=head1 NAME

B<mkdir> -- create directories

=head1 SYNOPSIS

B<mkdir> [B<-p>] [B<-m> I<mode>] I<directory> [I<directories> ...]

=head1 DESCRIPTION

B<mkdir> creates directories, giving it permission B<0777>, as modified
by the current I<umask>. Directories created in the order they are given.

=head2 OPTIONS

B<mkdir> accepts the options described below.

=over 4

=item B<-p>

Create any required intermediate directories. Such directories will be
created with permission B<0777>, as modified by the current I<umask>.
In addition, the I<write> and I<execute> bits for the I<owner> of the
directory will be set. If the B<-p> option is given, existing directories
will not trigger an error.

=item B<-m> I<mode>

Create the directory with permissions as indicated by I<mode>. I<mode>
can be of any form accepted by I<chmod(1)>. Symbolic I<mode>s are
relative to an initial mode of I<a=rwx>.

=head1 ENVIRONMENT

The working of B<mkdir> is not influenced by any environment variables.

=head1 BUGS

I<mkdir> does not have any known bugs.

=head1 STANDARDS

This implementation of I<mkdir> is compatible with the B<OpenBSD>
implementation, and is expected to be compatible with the
B<IEEE Std1003.2> aka B<POSIX.2> implementation.

=head1 REVISION HISTORY

    $Log: mkdir.abigail,v $
    Revision 1.3  2004/08/05 14:20:34  cwest
    cleanup, new version number on website

    Revision 1.1  2004/07/23 20:10:12  cwest
    initial import

    Revision 1.3  1999/03/09 02:53:25  abigail
    Removed the comparison of $dir to '.' and '/', as that's non-portable.
    All we need to do is checking for a fixed point.

    Revision 1.2  1999/03/09 02:44:57  abigail
    Fixed SybolicMode -> SymbolicMode typo.

    Revision 1.1  1999/03/09 02:27:17  abigail
    Initial revision

=head1 AUTHOR

The Perl implementation of B<mkdir> was written by Abigail, I<abigail@fnx.com>.

=head1 COPYRIGHT and LICENSE

This program is copyright by Abigail 1999.

This program is free and open software. You may use, copy, modify, distribute,
and sell this program (and any modified variants) in any way you wish,
provided you do not restrict others from doing the same.

=cut