# Unix.pm: UNIX Methods for RDA::Object::Rda

package RDA::Local::Unix;

# $Id: Unix.pm,v 1.30 2015/06/11 08:00:04 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Local/Unix.pm,v 1.30 2015/06/11 08:00:04 RDA Exp $
#
# Change History
# 20150609  MSC  Add the can_spawn method.

=head1 NAME

RDA::Local::Unix - UNIX Methods for RDA::Object::Rda

=head1 SYNOPSIS

 require RDA::Local::Unix;

=head1 DESCRIPTION

See L<RDA::Object::Rda|RDA::Object::Rda>. This package overrides the
implementation of these methods, not the semantics.

The following methods are available:

=cut

use strict;

BEGIN
{ use Exporter;
  use RDA::Text qw(get_string);
}

# Define the global public variables
use vars qw($STRINGS $VERSION @ISA);
$VERSION = sprintf('%d.%02d', q$Revision: 1.30 $ =~ /(\d+)\.(\d+)/);
@ISA     = qw(Exporter);

# Define the global private constants
my $PTH = qr/^([\001-\377]+)$/;

# Define the global private variables

# Report the package version
sub Version
{ return $VERSION;
}

=head2 S<RDA::Object::Rda-E<gt>as_bat([$path[,$flag]])>

This method adds a C<.sh> extension to the specified path unless the flag is
set.

=cut

sub as_bat
{ my ($slf, $pth, $flg) = @_;
  my ($ext);

  $ext = $flg ? q{} : '.sh';
  return defined($pth) ? $pth.$ext : $ext;
}

=head2 S<RDA::Object::Rda-E<gt>as_cmd([$path[,$flag]])>

This method adds a C<.sh> extension to the specified path unless the flag is
set.

=cut

sub as_cmd
{ my ($slf, $pth, $flg) = @_;
  my ($ext);

  $ext = $flg ? q{} : '.sh';
  return defined($pth) ? $pth.$ext : $ext;
}

=head2 S<RDA::Object::Rda-E<gt>as_exe([$path])>

This method returns the specified path.

=cut

sub as_exe
{ my ($slf, $pth) = @_;

  return defined($pth) ? $pth : q{};
}

=head1 FILE MACROS

=head2 S<RDA::Object::Rda-E<gt>basename($file[,@suf])>

This method extracts the base name of the file specification and  removes the
suffix when it belongs to the suffix list. It matches each element of this list
as a string against the end of the name.

=cut

sub basename
{ my ($slf, $fil, @suf) = @_;
  my ($bas, $dir, $suf);

  return unless defined($fil);

  # Parse the file
  $fil =~ s{(.)/*\z}{$1}s;
  ($dir, $bas, $suf) = $slf->parse_path($fil, @suf);

  # Adjust the base name
  return length($bas)                  ? $bas :
         defined($suf) && length($suf) ? $suf :
                                         $dir;
}

=head2 S<RDA::Object::Rda-E<gt>can_spawn>

This method indicates whether it is possible to launch background processes.

=cut

sub can_spawn
{ return 1;
}

=head2 S<RDA::Object::Rda-E<gt>cat_dir([$dir...,]$dir)>

This method concatenates directory names to form a complete path ending with a
directory. It removes the trailing slash from the resulting string, except for
the root directory.

It discards undefined values and references from the argument list.

=cut

sub cat_dir
{ my $slf = shift;
  my @tbl = grep {defined($_) && !ref($_)} @_;

  return (scalar @tbl) ? $slf->clean_path([@tbl, q{}]) : $slf->current_dir;
}

*arg_dir = \&cat_dir;

=head2 S<RDA::Object::Rda-E<gt>cat_file([$dir...,]$file)>

This method concatenates directory names and a file name to form a complete path
ending with a file name.

It discards undefined values and references from the argument list.

=cut

sub cat_file
{ my $slf = shift;
  my @tbl = grep {defined($_) && !ref($_)} @_;

  return (scalar @tbl) ? $slf->clean_path([@tbl]) : undef;
}

*arg_file = \&cat_file;

=head2 S<RDA::Object::Rda-E<gt>cat_native([$dir...,]$file)>

This method concatenates directory names and a file name to form a complete
native path ending with a file name.

It discards undefined values and references from the argument list.

=cut

sub cat_native
{ my $slf = shift;
  my @tbl = grep {defined($_) && !ref($_)} @_;

  return (scalar @tbl) ? $slf->clean_native([@tbl]) : undef;
}

=head2 S<RDA::Object::Rda-E<gt>clean_dir($path)>

This method deletes the content of a directory but not the directory itself. It
returns the directory path.

=cut

sub clean_dir
{ my ($slf, $pth) = @_;

  return defined($pth = $slf->is_path($pth)) ? _clean_dir($slf, $pth) : undef;
}

sub _clean_dir
{ my ($slf, $top) = @_;

  if (opendir(DIR, $top))
  { my ($pth, @dir);

    # Remove files
    foreach my $nam (readdir(DIR))
    { next if $nam =~ /^\.+$/ || $nam !~ $PTH;
      $pth = $slf->cat_file($top, $nam = $1);
      if (-d $pth)
      { push(@dir, $nam);
      }
      else
      { 1 while unlink($pth);
      }
    }
    closedir(DIR);

    # Remove subdirectories
    foreach my $nam (@dir)
    { rmdir(_clean_dir($slf, $slf->cat_dir($top, $nam)));
    }
  }

  # Return the directory name
  return $top
}

=head2 S<RDA::Object::Rda-E<gt>clean_native($path[,$flag])>

This method performs a logical cleanup of a path. It removes successive slashes
and successive C</.>. When the flag is set, it attempts to further reduce the
number of C</..> present in the path. It returns a native path.

=cut

sub clean_native
{ my ($slf, $pth, $flg) = @_;

  return $slf->native($slf->clean_path($pth, $flg));
}

=head2 S<RDA::Object::Rda-E<gt>clean_path($path[,$flag])>

This method performs a logical cleanup of a path. It removes successive slashes
and successive C</.>. When the flag is set, it attempts to further reduce the
number of C</..> present in the path.

=cut

sub clean_path
{ my ($slf, $pth, $flg) = @_;

  if (defined($pth))
  { $pth = _clean_min((ref($pth) eq 'ARRAY') ? join(q{/}, @{$pth}) : $pth);
    $pth = _clean_max($slf, $pth, 8) if $flg && $pth =~ m{/\.\.(/|\z)};
  }
  return $pth;
}

sub _clean_max
{ my ($slf, $src, $lvl) = @_;
  my ($itm, $pth, @dst, @src);

  @src = split(/\//, $src, -1);
  while (defined($itm = shift(@src)))
  { if ($itm eq q{..} && @dst)
    { $itm = pop(@dst);
      push(@dst, $itm)        if $itm eq q{};
      push(@dst, $itm, q{..}) if $itm eq q{..};

      $pth = join(q{/}, @dst, $itm);
      if (-l ($pth = join(q{/}, @dst, $itm)))
      { $pth = _clean_min($slf->is_absolute($pth = readlink($pth))
          ? join(q{/}, $pth, q{..})
          : join(q{/}, @dst, $pth, q{..}));
        $pth = _clean_max($slf, $pth, $lvl - 1) if $lvl > 0;
        @dst = split(/\//, $pth, -1);
      }
    }
    else
    { push(@dst, $itm);
    }
  }
  return ((scalar @dst) > 1)        ? join(q{/}, @dst) :
         !defined($itm = pop(@dst)) ? q{.} :
         ($itm eq q{})              ? q{/} :
                                      $itm;
}

sub _clean_min
{ my ($pth) = @_;

  $pth =~ s{/+}{/}g;                # x////x  -> x/x
  $pth =~ s{(/\.)+(/|\z)}{/}g;      # x/././x -> x/x
  $pth =~ s{^(\./)+(.)}{$2}s;       # ./x     -> x
  $pth =~ s{^(/\.\.)+(/|\z)}{/}s;   # /../..  -> /
  $pth =~ s{(.)/$}{$1};             # x/      -> x
  return $pth;
}

=head2 S<RDA::Object::Rda-E<gt>create_dir($path[,$mode[,$flag]])>

This method creates a directory when it does not yet exist. It makes parent
directories as needed. If directory permissions are omitted, 0750 is used as
default. When the flag is set, it cleans an existing directory. It returns the
directory path.

=cut

sub create_dir
{ my ($slf, $pth, $mod, $cln, $stk, $err) = @_;
  my ($dir, $flg, @tbl);

  if (defined($pth = $slf->is_path($pth)))
  { if (-d $pth)
    { _clean_dir($slf, $pth) if $cln;
    }
    else
    { $flg = $slf->is_absolute($pth);
      $mod = 0750 unless defined($mod);  ## no critic (Number,Zero)
      ($dir, @tbl) = $slf->split_dir($pth);
      unless ($flg || -d $dir)
      { die get_string($err || 'ERR_CREATE', $dir, $!)
          unless mkdir($dir, $mod);
        push(@{$stk}, $dir) if ref($stk);
      }
      foreach my $nam (@tbl)
      { $dir = $slf->cat_dir($dir, $nam);
        unless (-d $dir)
        { die get_string($err || 'ERR_CREATE', $dir, $!)
            unless mkdir($dir, $mod);
          push(@{$stk}, $dir) if ref($stk);
        }
      }
    }
  }
  return $pth;
}

=head2 S<RDA::Object::Rda-E<gt>current_dir>

This method returns a string representation of the current directory (C<.> for
UNIX).

=cut

sub current_dir
{ return q{.};
}

=head2 S<RDA::Object::Rda-E<gt>delete_dir($path)>

This method deletes a directory and its content.

=cut

sub delete_dir
{ my ($slf, $pth) = @_;

  return rmdir(_clean_dir($slf, $pth)) if defined($pth);
  return;
}

=head2 S<RDA::Object::Rda-E<gt>dev_null>

This method returns a string representation of the null device.

=cut

sub dev_null
{ return '/dev/null';
}

=head2 S<RDA::Object::Rda-E<gt>dev_tty>

This method returns a string representation of the terminal device.

=cut

sub dev_tty
{ return '/dev/tty';
}

=head2 S<RDA::Object::Rda-E<gt>dirname($file)>

This method returns the directory portion of the input file specification.

=cut

sub dirname
{ my ($slf, $fil) = @_;
  my ($bas, $dir);

  if (defined($fil))
  { # Parse the file as it is
    ($dir, $bas) = $slf->parse_path($fil);

    # Avoid empty base
    ($dir) = $slf->parse_path($dir) unless length($bas);
  }
  return $dir;
}

=head2 S<RDA::Object::Rda-E<gt>find_path($path,$command[,$flag])>

This method explores the path to find where a command is located. When the
command is found, it returns a full path name. Otherwise, it returns an
undefined variable. It only considers files or symbolic links in its
search. Unless the flag is set, the file path is quoted as required by a
command shell.

=cut

sub find_path
{ my ($slf, $pth, $cmd, $flg) = @_;
  my ($fil, $sep);

  if ($cmd && $pth)
  { unless (ref($pth) eq 'ARRAY')
    { $sep = $slf->get_separator;
      $pth = [split(/$sep/, $pth)];
    }

    foreach my $dir (@{$pth})
    { $dir = $slf->current_dir if $dir eq q{};
      next unless opendir(DIR, $dir);
      foreach my $nam (readdir(DIR))
      { next unless $nam eq $cmd;
        $fil = $slf->cat_file($dir, $cmd);
        if (stat($fil) && (-f $fil || -l $fil) && -x $fil)
        { closedir(DIR);
          return $flg ? $fil : $slf->quote($fil);
        }
      }
      closedir(DIR);
    }
  }
  return;
}

=head2 S<RDA::Object::Rda-E<gt>get_last_modify($file[,$default])>

This method gets the last modification date of the file. It returns the default
value when there are problems.

=cut

sub get_last_modify
{ my ($slf, $fil, $dft) = @_;

  return $dft unless defined($fil);
  my @sta = lstat($fil);
  return defined($sta[9]) ? $sta[9] : $dft;
}

=head2 S<$h-E<gt>get_login>

This method returns the login name.

=cut

sub get_login
{ my ($slf) = @_;
  my ($log);

  unless (exists($slf->{'_log'}))
  { eval {$slf->{'_log'} = getlogin() || getpwuid($<)};
    $slf->{'_log'} = defined($log = $slf->get_env('USERNAME')) ? $log : q{?}
      if $@;
  }
  return $slf->{'_log'};
}

=head2 S<$h-E<gt>get_path>

This method returns the C<PATH> environment variable as a list.

=cut

sub get_path
{ return shift->{'agt'}->get_system->get_list('pth');
}

=head2 S<RDA::Object::Rda-E<gt>get_separator>

This method returns the character used as separator.

=cut

sub get_separator
{ return q{:};
}

=head2 S<$h-E<gt>get_user>

This method returns the user name.

=cut

sub get_user
{ my ($slf) = @_;
  my ($usr);

  unless (exists($slf->{'_usr'}))
  { eval {$slf->{'_usr'} = getpwuid($>)};
    eval {$slf->{'_usr'} = getlogin()} if $@;
    $slf->{'_usr'} = defined($usr = $slf->get_env('USERNAME')) ? $usr : q{?}
      if $@;
  }
  return $slf->{'_usr'};
}

=head2 S<RDA::Object::Rda-E<gt>has_short>

This method indicates whether the files and directories can have short names.

=cut

sub has_short
{ return 0;
}

=head2 S<RDA::Object::Rda-E<gt>is_absolute($path)>

This method indicates whether the argument is an absolute path.

=cut

sub is_absolute
{ my ($slf, $pth) = @_;

  return defined($pth)
    ? scalar ($pth =~ m{^/}s)
    : 0;
}

=head2 S<RDA::Object::Rda-E<gt>is_cygwin>

This method returns a true value when the operating system is Cygwin.

=cut

sub is_cygwin
{ return 0;
}

=head2 S<RDA::Object::Rda-E<gt>is_path($string)>

This method verifies that the string does not contain characters invalid in a
path.

=cut

sub is_path
{ my ($slf, $pth) = @_;

  return unless defined($pth);
  return $1 if $pth =~ $PTH;
  die get_string('BAD_PATH', $pth);
}

=head2 S<RDA::Object::Rda-E<gt>is_root_dir($path)>

This method indicates whether the path represents a root directory. It assumes
that the provided path is already cleaned.

=cut

sub is_root_dir
{ my ($slf, $pth) = @_;

  return defined($pth)
    ? $pth eq q{/}
    : 0;
}

=head2 S<RDA::Object::Rda-E<gt>is_unix>

This method returns a true value when the operating system belongs to the UNIX
family.

=cut

sub is_unix
{ return 1;
}

=head2 S<RDA::Object::Rda-E<gt>is_vms>

This method returns a true value when the operating system is VMS.

=cut

sub is_vms
{ return 0;
}

=head2 S<RDA::Object::Rda-E<gt>is_windows>

This method returns a true value when the operating system belongs to the
Windows family.

=cut

sub is_windows
{ return 0;
}

=head2 S<RDA::Object::Rda-E<gt>kill_child($pid)>

This method kills a child process.

=cut

sub kill_child
{ my ($slf, $pid) = @_;

  return unless defined($pid);
  return kill(9, $pid);
}

=head2 S<RDA::Object::Rda-E<gt>native($path)>

This method converts the path to its native representation. It does not make
any transformation for UNIX.

=cut

*native = \&is_path;

=head2 S<RDA::Object::Rda-E<gt>parse_path($path[,@suf])>

This method divides a file path into the directories, its file name, and
optionally the file suffix. The directory part contains everything up to and
including the last directory separator in the $path including the volume, when
applicable. The remainder of the path is the file name.

=cut

sub parse_path
{ my ($slf, $pth, @suf) = @_;
  my ($bas, $dir, $ext, @ext);

  return () unless defined($pth);

  # Parse the file
  ($dir, $bas) = ($pth =~ m{^(.*/)?(.*)}s);
  if (defined($dir))
  { $dir =~ s{(.)/*\z}{$1}s;
  }
  else
  { $dir = q{.};
  }

  # Extract the file suffix
  if (@suf)
  { $ext = q{};
    foreach my $suf (@suf)
    { $ext = $1.$ext if defined($suf) && $bas =~ s/(\Q$suf\E)\z//s;
    }
    @ext = ($ext) unless $ext eq q{};
  }

  # Return the parsing result
  return ($dir, $bas, @ext);
}

=head2 S<RDA::Object::Rda-E<gt>quote($string[,$flag])>

This method encodes a string to be considered as a single argument by a command
shell. Unless the flag is set, variable substitution is disabled.

=cut

sub quote
{ my ($slf, $str, $flg) = @_;

  return        unless defined($str);
  return q{""}  unless length($str);
  die get_string('BAD_STRING', $str) unless $str =~ m/^([\001-\377]+)$/;
  $str = $1;
  return $str
    unless $str =~ m/[\000-\037\s\&\(\)\[\]\{\}\|\<\>\^\!\"\'\`\~\*\?\$\#\\]/;
  $str =~ s{(\\*)([\"\`\\])}{$1.((length($1) & 1) ? q{} : '\\').$2}eg;
  $str =~ s{\$}{\\\$}g unless $flg;
  return q{"}.$str.q{"};
}

=head2 S<RDA::Object::Rda-E<gt>quote2($string[,$flag])>

This method is similar to the C<quote> method but the result does not contain
the leading and trailing quotation marks.

=cut

sub quote2
{ my ($slf, $str, $flg) = @_;

  return     unless defined($str);
  return q{} unless length($str);
  die get_string('BAD_STRING', $str) unless $str =~ m/^([\001-\377]+)$/;
  $str = $1;
  return $str
    unless $str =~ m/[\000-\037\s\&\(\)\[\]\{\}\|\<\>\^\!\"\'\`\~\*\?\$\#\\]/;
  $str =~ s{(\\*)([\"\`\\])}{$1.((length($1) & 1) ? q{} : '\\').$2}eg;
  $str =~ s{\$}{\\\$}g unless $flg;
  return $str;
}

=head2 S<RDA::Object::Rda-E<gt>re($str)>

This method converts a string containing wild cards into a Perl regular
expression. It scans for the characters C<*>, C<?>, C<[>, and C<]>. C<*>
matches any string, including the null string. C<?> matches any single
character. C<[...]> matches any one of the enclosed characters, which are taken
literally. It assumes that backslashes are used as escape characters. When a
path element starts with a C<.>, this character must be matched explicitly.

=cut

sub re
{ my ($slf, $str) = @_;
  my ($itm, $nxt, @tbl);

  @tbl = split(/([\*\?\[\]])/, $str, -1);
  $nxt = q{};
  $str = q{^};
  while (defined($itm = shift(@tbl)))
  { $itm = $nxt.$itm;
    $nxt = q{};
    if ($itm eq q{*})
    { $str .= q{.*};
    }
    elsif ($itm eq q{?})
    { $str .= q{.};
    }
    elsif ($itm eq q{[})
    { $str .= $itm;
      while (defined($itm = shift(@tbl)))
      { $str .= $itm;
        last if $itm eq q{]};
      }
    }
    elsif ($itm eq q{]})
    { $str .= q{\\]};
    }
    else
    { if ($itm =~ m/(\\+)$/ && length($1) & 1)  ## no critic (Bit)
      { $nxt = q{\\};
        $itm = substr($itm, 0, -1);
      }
      $itm =~ s{([\#\.\+\|\(\)\{\}\^\$])}{\\$1}g;
      $str .= $itm;
    }
  }
  $str .= q{$};
  $str =~ s{(\A\^|\/)\.\*}{$1\(\?:\[\^\\\.\]\.\*\)?}g;
  $str =~ s{(\A\^|\/)\.}{$1\[\^\\\.\]}g;
  return $str;
}

=head2 S<RDA::Object::Rda-E<gt>short($path)>

This method converts the path to its native representation using only short
names. It does not make any transformation for UNIX.

=cut

*short = \&is_path;

=head2 S<RDA::Object::Rda-E<gt>split_dir($path)>

This method returns the list of directories contained in the specified path. It
returns an empty list when the path is missing.

=cut

sub split_dir
{ my ($slf, $pth) = @_;

  return () unless defined($pth);
  return split(/\//, $pth, -1);
}

=head2 S<RDA::Object::Rda-E<gt>split_volume($path)>

This method separates the volume from the other path information. It returns an
empty list when the path is missing.


=cut

sub split_volume
{ my ($slf, $pth) = @_;

  return () unless defined($pth);
  return (q{}, $pth);
}

=head2 S<RDA::Object::Rda-E<gt>unquote($string)>

This method removes the quoting characters from a string.

=cut

sub unquote
{ my ($slf, $str) = @_;
  my ($buf);

  if (defined($str))
  { for ($buf = q{} ;;)  ## no critic (For)
    { return $buf.$str unless $str =~ s/\A(.*?)([\'\"]|\\.)//s;
      $buf .= $1;
      if ($2 eq q{'})
      { return $buf.$str unless $str =~ s/\A(.*?)\'//s;
        $buf .= $1;
      }
      elsif ($2 eq q{"})
      { $buf .= $1.$2 while $str =~ s/\A([^\"\\]*)\\(.)//s;
        return $buf.$str unless $str =~ s/\A(.*?)\"//s;
        $buf .= $1;
      }
      else
      { $buf .= substr($2, 1);
      }
    }
  }
  return;
}

=head2 S<RDA::Object::Rda-E<gt>up_dir>

This method returns a string representation of the parent directory (C<..> for
UNIX).

=cut

sub up_dir
{ return q{..};
}

# --- Auxiliary routines ------------------------------------------------------

# Get uname information
sub sys_uname
{ my ($slf) = @_;
  my ($str, $sys);

  # Try to get it from perl
  eval {
    require POSIX;
    $sys = [POSIX::uname()];  ## no critic (Call)
  };
  return $sys unless $@;

  # Try to get from the operating system
  eval {
    ($str) = `uname -a`;
    $sys = [split(/\s/, $str)];
  };
  return $@ ? [q{?}, q{?}, q{?}, q{?}, q{?}] : $sys;
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Object::Rda|RDA::Object::Rda>,
L<RDA::Text|RDA::Text>

=head1 COPYRIGHT NOTICE

Copyright (c) 2002, 2016, Oracle and/or its affiliates. All rights reserved.

=head1 TRADEMARK NOTICE

Oracle and Java are registered trademarks of Oracle and/or its
affiliates. Other names may be trademarks of their respective owners.

=cut