#!/usr/bin/perl
=begin metadata
Name: mkdir
Description: create directories
Author: Abigail, perlpowertools@abigail.be
License: perl
=end metadata
=cut
use strict;
use File::Basename qw(basename);
use File::Spec;
use Getopt::Std qw(getopts);
our $VERSION = '1.6';
my $Program = basename($0);
$SIG{__WARN__} = sub { warn "$Program: @_\n" };
$SIG{__DIE__} = sub { die "$Program: @_\n" };
my %options;
getopts('m:p', \%options) or usage();
usage() unless @ARGV;
use constant EX_SUCCESS => 0;
use constant EX_ERROR => 1;
use constant EX_USAGE => 2;
sub VERSION_MESSAGE {
print "$Program version $VERSION\n";
exit EX_SUCCESS;
}
sub usage {
print { *STDERR } "usage: $Program [-p] [-m mode] directory ...\n";
exit EX_USAGE;
}
my $symbolic = 0;
if (defined $options{'m'}) {
if (length($options{'m'}) == 0) {
warn "invalid mode\n";
exit EX_ERROR;
}
$symbolic = 1 if $options{'m'} =~ /[^0-7]/;
}
my $rc = EX_SUCCESS;
DIRS: foreach my $dir (@ARGV) {
if ($options{'p'}) {
my @subdir = split_dir($dir);
$dir = shift @subdir;
my $ok = create_dir($dir, 0);
next DIRS unless $ok;
foreach my $d (@subdir) {
$ok = create_dir($d, 1);
next DIRS unless $ok;
}
} else {
create_dir($dir, 0);
}
}
exit $rc;
sub create_dir {
my ($dir, $intermediate) = @_;
# Existing directories don't create a warning when -p is in effect.
return 1 if $options{'p'} && -d $dir;
# Umask is applied on mkdir.
mkdir $dir => 0777 or do {
warn "cannot create directory '$dir': $!\n";
$rc = EX_ERROR;
return;
};
# Special case the intermediate directories.
if ($intermediate) {
# Get the current permissions of the directory; in oct.
my @st = stat $dir;
unless (@st) {
# 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";
$rc = EX_ERROR;
return;
}
# Turn on write and search permission for the user.
my $mode = $st[2];
$mode |= 3 << 6;
chmod $mode => $dir or do {
warn "chmod on $dir failed: $!\n";
$rc = EX_ERROR;
# Skip to next directory of arg list.
# The tests for @ARGV aren't really necessary.
shift while @ARGV && $ARGV[0][1];
shift if @ARGV;
return;
};
# -m has no effect on intermediate directories created due to -p.
return 1;
}
return 1 unless exists $options{'m'};
my $realmode = $options{'m'};
if ($symbolic) {
$realmode = mod($options{'m'}) or
die "invalid mode: $options{m}\n";
}
chmod oct($realmode) => $dir or warn "$!\n";
return 1;
}
sub split_dir {
my $dir = shift;
my (@parts, @dirs);
@parts = File::Spec->splitdir($dir);
for (0 .. $#parts) {
push @dirs, File::Spec->catfile(@parts[0 .. $_]);
}
shift @dirs if (@dirs && $dirs[0] eq ''); # absolute path
return @dirs;
}
#
# $Id: SymbolicMode.pm,v 1.1 2004/07/23 20:10:01 cwest Exp $
#
# $Log: SymbolicMode.pm,v $
# Revision 1.1 2004/07/23 20:10:01 cwest
# initial import
#
# Revision 1.1 1999/03/07 12:03:54 abigail
# Initial revision
#
#
sub mod {
my $symbolic = shift;
my $file = shift;
my @ugo = qw/u g o/;
my %bits = ('s' => 8, 't' => 8, 'r' => 4, 'w' => 2, 'x' => 1);
# For parsing.
my $who_re = '[augo]*';
my $action_re = '[-+=][rstwxXugo]*';
# Find the current permissions. This is what we start with.
my $mode = '777';
if ($symbolic =~ m/[\-\+]/) {
my @st = stat $file;
if (@st) {
$mode = sprintf '%04o', $st[2];
}
}
my $current = substr $mode => -3; # rwx permissions for ugo.
my %perms;
@perms {@ugo} = split // => $current;
# Handle the suid, guid and sticky bits.
# It looks like permission are 4 groups of 3 bits, groups for user,
# group and others, and a group for the special flags, but they are
# really 3 groups of 4 bits. Or maybe not.
# Anyway, this function is greatly simplified by treating them as
# 3 4-bit groups. The highest bit will be "special" one. suid for
# the users group, guid for the group group, and the sticky bit
# for the others group.
my $special = substr $mode => -4, 1;
my $bit = 1;
foreach my $c (reverse @ugo) {
$perms {$c} |= 8 if $special & $bit;
$bit <<= 1;
}
# Keep track of the original permissions.
my %orig = %perms;
# Find the umask setting, and store the bits for each group
# in a hash.
my %umask; # umask bits.
@umask {@ugo} = split // => sprintf "%03o" => umask;
# Time to parse...
foreach my $clause (split /,/ => $symbolic) {
# Perhaps we should die if we can't parse it?
return undef unless
my ($who, $actions) =
$clause =~ /^($who_re)((?:$action_re)+)$/o;
# We would rather split the different actions out here,
# but there doesn't seem to be a way to collect them.
# /^($who_re)($action_re)+/ only gets the last one.
# Now, we have to reparse in later.
my %who;
if ($who) {
$who =~ s/a/ugo/; # Ignore multiple 'a's.
@who {split // => $who} = undef;
}
# @who will contain who these settings applies to.
# if who isn't set, it might be masked with the umask,
# hence, this isn't the final decision.
# Maybe we don't need this.
my @who = $who ? keys %who : @ugo;
foreach my $action (split /(?=$action_re)/o => $actions) {
# The first character has to be the operator.
my $operator = substr $action, 0, 1;
# And the rest are the permissions.
my $perms = substr $action, 1;
# BSD documentation says 'X' is to be ignored unless
# the operator is '-'. GNU, HP, SunOS and Solaris handle
# '-' and '=', while OpenBSD ignores only '-'.
# Solaris, HP and OpenBSD all turn a file with permission
# 666 to a file with permission 000 if chmod =X is
# is applied on it. SunOS and GNU act as if chmod = was
# applied to it. I cannot find out what the reasoning
# behind the choices of Solaris, HP and OpenBSD is.
# GNU and SunOS seem to ignore the 'X', which, after
# careful studying of the documentation seems to be
# the right choice.
# Therefore, remove any 'X' if the operator ain't '+';
$perms =~ s/X+//g unless $operator eq '+';
# If there are no permissions, things are simple.
unless ($perms) {
# Things like u+ and go- are ignored; only = makes sense.
next unless $operator eq '=';
# Clear permissions on u= and go=.
if ($who) {@perms {keys %who} = (0) x 3;}
# '=' is special. Sets permissions to the umask.
else {%perms = %umask;}
next;
}
if ($operator eq '=') {
$perms{$who} = 0;
}
# If we arrive here, $perms is a string.
# We can iterate over the characters.
foreach (split // => $perms) {
if ($_ eq 'X') {
# We know the operator eq '+'.
# Permission of `X' is special. If used on a regular file,
# the execution bit will only be turned on if any of the
# execution bits of the _unmodified_ file are turned on.
# That is,
# chmod 600 file; chmod u+x,a+X file;
# should result in the file having permission 700, not 711.
# GNU and SunOS get this wrong;
# Solaris, HP and OpenBSD get it right.
next unless -d $file || grep {$orig {$_} & 1} @ugo;
# Now, do as if it's an x.
$_ = 'x';
}
if (/[st]/) {
# BSD man page says operations on 's' and 't' are to
# be ignored if they operate only on the "other" group.
# GNU and HP happely accept 'o+t'. Sun rejects 'o+t',
# but also rejects 'g+t', accepting only 'u+t'.
# OpenBSD acceps both 'u+t' and 'g+t', ignoring 'o+t'.
# We do too.
# OpenBSD however, accepts 'o=t', clearing all the bits
# of the "other" group.
# We don't, as that doesn't make any sense, and doesn't
# confirm to the documentation.
next if $who =~ /^o+$/;
}
# Determine the $bit for the mask.
my $bit = /[ugo]/ ? $orig {$_} & ~8 : $bits {$_};
die "Weird permission `$_' found\n" unless defined $bit;
# Should not happen.
# Determine the set on which to operate.
my @set = $who ? @who : grep {!($umask {$_} & $bit)} @ugo;
# If the permission is 's', don't operate on the other group.
# Unless the operator was '='. But in that case, don't set
# the 8 bit for 'other'.
my $equal_s;
if (/s/) {
if ($operator eq '=') {$equal_s = 1;}
else {@set = grep {!/o/} @set or next;}
}
# If the permission is 't', only operate on the other group;
# regardless what the 'who' settings are.
# Note that for a directory with permissions 1777, and a
# umask of 002, a chmod =t on HP and Solaris turn the
# permissions to 1000, GNU and SunOS turn the permissiosn
# to 1020, while OpenBSD keeps 1777.
/t/ and @set = qw /o/;
# Apply.
foreach my $s (@set) {
do {$perms {$s} |= $bit; next} if ($operator eq '+' || $operator eq '=');
do {$perms {$s} &= ~$bit; next} if $operator eq '-';
die "Weird operator `$operator' found\n";
# Should not happen.
}
# Special case '=s'.
$perms {o} &= ~$bit if $equal_s;
}
}
}
# Now, translate @perms to an *octal* number.
# First, deal with the suid, guid, and sticky bits by collecting
# the high bits of the ugo permissions.
my $first = 0;
$bit = 1;
for my $c (reverse @ugo) {
if ($perms {$c} & 8) {$first |= $bit; $perms {$c} &= ~8;}
$bit <<= 1;
}
join "" => $first, @perms {@ugo};
}
__END__
=pod
=head1 NAME
mkdir - create directories
=head1 SYNOPSIS
B<mkdir> [B<-p>] [B<-m> I<mode>] I<directory> ...
=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>.
=back
=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 AUTHOR
The Perl implementation of B<mkdir> was written by Abigail, I<perlpowertools@abigail.be>.
=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