# Cygwin.pm: Cygwin Methods for RDA::Object::Rda

package RDA::Local::Cygwin;

# $Id: Cygwin.pm,v 1.21 2014/09/26 09:08:46 RDA Exp $
# ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Local/Cygwin.pm,v 1.21 2014/09/26 09:08:46 RDA Exp $
#
# Change History
# 20140924  MSC  Improve the basename and parse_path methods.

=head1 NAME

RDA::Local::Cygwin - Cygwin Methods for RDA::Object::Rda

=head1 SYNOPSIS

 require RDA::Local::Cygwin;

=head1 DESCRIPTION

See L<RDA::Object::Rda|RDA::Object::Rda> and
L<RDA::Local::Unix|RDA::Local::Unix>. 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.21 $ =~ /(\d+)\.(\d+)/);

require RDA::Local::Unix;
require RDA::Local::Windows;
@ISA = qw(RDA::Local::Unix Exporter);

# Define the global private constants

# Define the global private variables

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

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

This method adds a C<.bat> extension to the specified path.

=cut

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

  return defined($pth) ? "$pth.bat" : '.bat';
}

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

This method adds a C<.cmd> extension to the specified path.

=cut

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

  return defined($pth) ? "$pth.cmd" : '.cmd';
}

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

This method adds a C<.exe> extension to the specified path.

=cut

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

  return defined($pth) ? "$pth.exe" : '.exe';
}

=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) = @_;

  return unless defined($fil);
  $fil =~ s{\\}{/}g;
  $fil =~ s{^([A-Za-z]:|/cygdrive/[A-Za-z]\b|//[^/]+)}{};
  return RDA::Local::Unix->basename($fil, @suf);
}

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

This method performs a logical cleanup of a path. It removes successive slashes
(C</>) and successive C</.>. It converts backslashes (C<\>) to slashes (C</>)
also. 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) = @_;
  my ($pre, $vol);

  if (ref($pth) eq 'ARRAY')
  { return unless @{$pth};
    $pre = shift(@{$pth});
    $pre =~ s{\\}{/}g;
    $vol = ($pre =~ s{^(//[^/]+)(/|\z)}{/}s) ? $1 :
           ($pre =~ s{^([a-z]:)}{}is)        ? uc($1) :
                                               q{};
    $pth = join(q{/}, $pre, @{$pth});
    $pth =~ s{\\}{/}g;
  }
  else
  { return unless defined($pth);
    $pth =~ s{\\}{/}g;
    $vol = ($pth =~ s{^(//[^/]+)(/|\z)}{/}s) ? $1 :
           ($pth =~ s{^([a-z]:)}{}is)        ? uc($1) :
                                               q{};
  }
  $pth =~ s{/+}{/}g;
  return length($vol)
    ? RDA::Local::Windows->clean_native($vol.$pth)
    : $slf->native($slf->SUPER::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
(C</>) and successive C</.>. It converts backslashes (C<\>) to slashes (C</>)
also. 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) = @_;
  my ($pre, $vol);

  if (ref($pth) eq 'ARRAY')
  { return unless @{$pth};
    $pre = shift(@{$pth});
    $pre =~ s{\\}{/}g;
    $vol = ($pre =~ s{^(//[^/]+)(/|\z)}{/}s) ? $1 :
           ($pre =~ s{^([a-z]):}{}is)        ? '/cygdrive/'.lc($1) :
                                               q{};
    $pth = join(q{/}, $pre, @{$pth});
    $pth =~ s{\\}{/}g;
  }
  else
  { return unless defined($pth);
    $pth =~ s{\\}{/}g;
    $vol = ($pth =~ s{^(//[^/]+)(/|\z)}{/}s) ? $1 :
           ($pth =~ s{^([a-z]):}{}is)        ? '/cygdrive/'.lc($1) :
                                               q{};
  }
  return $vol.$slf->SUPER::clean_path($pth, $flg);
}

=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) = @_;

  return unless defined($fil);
  $fil =~ s{\\}{/}g;
  return RDA::Local::Unix->dirname($fil)
    unless $fil =~ s{^([A-Za-z]:|/cygdrive/[A-Za-z]\b|//[^/]+)}{};
  return $slf->cat_dir($1, RDA::Local::Unix->dirname($fil));
}

=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})
    { next unless opendir(DIR, $dir);
      foreach my $nam (readdir(DIR))
      { next unless $nam =~ m/^(\Q$cmd\E(\.(bat|cmd|exe))?)$/i;
        $fil = $slf->cat_file($dir, $1);
        if (stat($fil) && (-f $fil || -l $fil))
        { closedir(DIR);
          return $flg ? $fil : $slf->quote($fil)
        }
      }
    }
  }
  return;
}

=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 1;
}

=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{^([a-z]:)?[\\/]}is)
   : 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 1;
}

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

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

=cut

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

  return 0 unless defined($pth);

  $pth =~ s{\\}{/}g;
  $pth =~ s{^/cygdrive/[a-z](/|\z)}{/};
  $pth =~ s{^[a-z]:}{}is;
  return $slf->SUPER::is_root_dir($pth);
}

=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 0;
}

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

This method converts the path to its Windows representation. When the flag is
set, it converts the path to lowercase.

=cut

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

  return unless defined($pth = $slf->is_path($pth));

  # Try cygpath first
  $str = $pth;
  $str =~ s/'/'"'"'/g;
  ($str) = `/bin/cygpath -w '$str' 2>/dev/null`;
  return $flg ? RDA::Local::Windows->lc_path($1) : $1
    if defined($str) && $str =~ m/^(.*?)[\n\r]*$/;

  # Do minimal transformations
  $pth =~ s{^/cygdrive/([a-z])(/|\z)}{$1:/}is;
  $pth = lc($pth) if $flg;
  $pth =~ s{^([a-z]:)}{\U$1\Q};
  $pth =~ s{/}{\\}g;
  return $pth;
}

=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 ($dir, $vol, @res);

  return () unless defined($pth);
  $pth =~ s{\\}{/}g;
  return RDA::Local::Unix->parse_path($pth, @suf)
    unless $pth =~ s{^([A-Za-z]:|/cygdrive/[A-Za-z]\b|//[^/]+)}{};
  $vol = $1;
  ($dir, @res) = RDA::Local::Unix->parse_path($pth, @suf);
  return ($slf->cat_dir($vol, $dir), @res);
}

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

This method converts the path to its native representation using only short
names. When the flag is set, it converts the path to lowercase.

=cut

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

  if (defined($pth = $slf->is_path($pth)))
  { $res = _short($slf, $pth, $flg);
    $slf->{'_sht'}->{$pth} = $res
      if ref($slf) eq 'RDA::Object::Rda' && $slf->is_absolute($pth);
  }
  return $res;
}

sub _short  ## no critic (Unpack)
{ my ($slf, $pth, $flg) = @_;
  my ($str);

  # Try cygpath first
  $str = $pth;
  $str =~ s/'/'"'"'/g;
  ($str) = `/bin/cygpath -d '$pth' 2>/dev/null`;
  return $flg ? RDA::Local::Windows->lc_path($1) : $1
    if defined($str) && $str =~ m/^(.*?)[\n\r]*$/;

  # Do minimal transformations
  $str = $pth = native(@_);
  $str =~ s/\\/\\/g;
  $str =~ s/"/^"/g;
  foreach my $lin (`echo 'FOR %D IN ("$str") DO ECHO %~sD' | cmd`)
  { return $flg ? RDA::Local::Windows->lc_path($1) : $1
      if $lin =~ m/>ECHO (.*?)[\n\r\s]+$/;
  }
  return $flg ? RDA::Local::Windows->lc_path($pth) : $pth;
}

=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) = @_;
  my ($vol, @dir);

  if (defined($pth))
  { ($vol, $pth) = $slf->split_volume($pth);
    @dir = split(/[\/\\]/, $pth, -1);
    $dir[0] = $vol.$dir[0];
  }
  return @dir;
}

=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) = @_;
  my ($vol);

  return () unless defined($pth);
  $pth =~ s{\\}{/}g;
  $pth =~ s{^/cygdrive/([a-z])(/|\z)}{$1:/}is;
  $vol = ($pth =~ s{^(//[^/]+)/?\z}{/}s) ? $1 :
         ($pth =~ s{^(//[^/]+/)}{}s)     ? $1 :
         ($pth =~ s{^([a-z]:)}{}is)      ? uc($1) :
                                           q{};
  $pth = q{.} unless defined($pth) && length($pth);
  return ($vol, ($pth eq q{}) ? q{.} : $pth);
}

# --- 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 $sys unless $@;

  # Try to emulate it
  $sys = [q{?}, q{?}, q{?}, q{?}, q{?}];
  ($str) = `echo exit | cmd`;
  if ($str =~ m/^(.*) \[Version\s+(\d+\.\d+)\.([^]]*)\]/)
  { ($sys->[0], $sys->[2], $sys->[3]) = ($1, $2, $3);
  }
  elsif ($str =~ m/^Microsoft\(R\) Windows NT\(TM\)/i)
  { $sys->[0] = 'Microsoft Windows NT';
  }
  $sys->[1] = $slf->get_node;
  $sys->[4] = $str if defined($str = $slf->get_env('PROCESSOR_ARCHITECTURE'));
  return $sys;
}

1;

__END__

=head1 SEE ALSO

L<RDA::Agent|RDA::Agent>,
L<RDA::Local::Unix|RDA::Local::Unix>,
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