view release on metacpan or  search on metacpan

lib/Data/Table/Text.pm  view on Meta::CPAN

sub onWindows                                                                   #P Are we on windows.
 {$^O =~ m(MSWin32)
 }

sub onMac                                                                       #P Are we on mac.
 {$^O =~ m(darwin)
 }

sub filePathSeparatorChar                                                       #P File path separator.
 {onWindows ? '\\' : '/';
 }

sub denormalizeFolderName($)                                                    #P Remove any trailing folder separator from a folder name.
 {my ($name) = @_;                                                              # Folder name
  $name =~ s([\/\\]+\Z) ()gsr;
 }

sub renormalizeFolderName($)                                                    #P Normalize a folder name by ensuring it has a single trailing directory separator.
 {my ($name) = @_;                                                              # Name
  ($name =~ s([\/\\]+\Z) ()gsr).filePathSeparatorChar;                          # Put a trailing / on the folder name
 }

sub prefferedFileName($)                                                        #P Normalize a file name.
 {my ($name) = @_;                                                              # Name
  onWindows ? $name =~ s([\/\\]+) (\\)gsr :
              $name =~ s([\/\\]+)  (/)gsr ;
 }

sub filePath(@)                                                                 #I Create a file name from a list of  names. Identical to L<fpf|/fpf>.
 {my (@file) = @_;                                                              # File name components
  defined($_) or confess "Missing file component\n" for @file;                  # Check that there are no undefined file components
  my @components = grep {$_ || $_ eq "0"} map {denormalizeFolderName($_)} @file;# Skip blank components but not zero components
  return '' unless @components;                                                 # No components resolves to '' rather than '/'
  prefferedFileName join '/', @components;                                      # Join separate components
 }

sub filePathDir(@)                                                              #I Create a folder name from a list of  names. Identical to L<fpd|/fpd>.
 {my (@file) = @_;                                                              # Directory name components
  my $file = filePath(@_);
  return '' unless $file;                                                       # No components resolves to '' rather than '/'
  renormalizeFolderName($file)                                                  # Normalize with trailing separator
 }

sub filePathExt(@)                                                              #I Create a file name from a list of  names the last of which is assumed to be the extension of the file name. Identical to L<fpe|/fpe>.
 {my (@File) = @_;                                                              # File name components and extension
  my @file = grep{defined and /\S/} @_;                                         # Remove undefined and blank components
  @file > 1 or confess "At least two non blank file name components required\n";
  my $x = pop @file;
  my $n = pop @file;
  my $f = "$n.$x";
  return $f unless @file;
  filePath(@file, $f)
 }

BEGIN{*fpd=*filePathDir}
BEGIN{*fpe=*filePathExt}
BEGIN{*fpf=*filePath}

#D3 Fission                                                                     # Get file name components from a file name.

sub fp($)                                                                       # Get the path from a file name.
 {my ($file) = @_;                                                              # File name
  $file or confess "File required";
  if (onWindows)
   {return '' unless $file =~ m(\\);                                            # Must have a \ in it else no path
    $file =~ s([^\\]*\Z) ()gsr
   }
  else
   {return '' unless $file =~ m(/);                                             # Must have a / in it else no path
    $file =~ s([^/]*\Z) ()gsr
   }
 }

sub fpn($)                                                                      # Remove the extension from a file name.
 {my ($file) = @_;                                                              # File name
  $file or confess "File required";
  if (onWindows)
   {return '' unless $file =~ m(\\);                                            # Must have a \ in it else no path
   }
  else
   {return '' unless $file =~ m(/);                                             # Must have a / in it else no path
   }
  $file =~ s(\.[^.]+?\Z) ()gsr
 }

sub fn($)                                                                       #I Remove the path and extension from a file name.
 {my ($file) = @_;                                                              # File name
  $file or confess "File required";
  if (onWindows)
   {$file =~ s(\A.*\\) ()gsr =~ s(\.[^.]+?\Z) ()gsr
   }
  else
   {$file =~ s(\A.*/) ()gsr =~ s(\.[^.]+?\Z) ()gsr
   }
 }

sub fne($)                                                                      # Remove the path from a file name.
 {my ($file) = @_;                                                              # File name
  $file or confess "File required";
  if (onWindows)
   {$file =~ s(\A.*\\) ()gsr;
   }
  else
   {$file =~ s(\A.*/) ()gsr;
   }
 }

sub fe($)                                                                       # Get the extension of a file name.
 {my ($file) = @_;                                                              # File name
  $file or confess "File required";
  return '' unless $file =~ m(\.)s;                                             # Must have a period
  my $f = $file =~ s(\.[^.]*?\Z) ()gsr;
  substr($file, length($f)+1)
 }

sub checkFile($)                                                                # Return the name of the specified file if it exists, else confess the maximum extent of the path that does exist.
 {my ($file) = @_;                                                              # File to check
  unless(-e $file)
   {confess "Can only find the prefix (below) of the file (further below):\n".
      matchPath($file)."\n$file\n";
   }
  $file
 }

sub quoteFile($)                                                                # Quote a file name.
 {my ($file) = @_;                                                              # File name
  $file or confess "Undefined file to quote";
  $file =~ s(")  (\\\")gs;
  $file =~ s(\$) (\\\$)gs;
  qq(\"$file\")
 }

sub removeFilePrefix($@)                                                        # Removes a file B<$prefix> from an array of B<@files>.
 {my ($prefix, @files) = @_;                                                    # File prefix, array of file names
  my @f = map {s(\A$prefix) ()r} @files;
  return $f[0] if @f == 1 and !wantarray;                                       # Special case of wanting one file in scalar context
  @f
 }

sub swapFilePrefix($$;$)                                                        # Swaps the start of a B<$file> name from a B<$known> name to a B<$new> one if the file does in fact start with the $known name otherwise returns the original file name a...
 {my ($file, $known, $new) = @_;                                                # File name, existing prefix, optional new prefix defaults to q()
  my $L = length($file);
  my $l = length($known);
  if ($L >= $l)
   {if (substr($file, 0, $l) eq $known)
     {return ($new//q()).substr($file, $l);
     }
    return $file;
   }
  confess "Known $l longer than file name $L:\n$known\n$file\n";
 } # swapFilePrefix

sub setFileExtension($;$)                                                       # Given a B<$file>, change its extension to B<$extension>. Removes the extension if no $extension is specified.
 {my ($file, $extension) = @_;                                                  # File name, optional new extension
  return $file =~ s(\.\w+\Z) ()sr unless defined $extension;                    # Remove extension
  my $ext = $extension =~ s(\A\.+) ()gsr;                                       # Remove leading dots
  return $file                    unless $ext;                                  # No extension after dot removal
  ($file =~ s(\.\w+\Z) ()gsr).q(.).$ext;                                        # Change extension
 } # setFileExtension

sub swapFolderPrefix($$$)                                                       # Given a B<$file>, swap the folder name of the $file from B<$known> to B<$new> if the file $file starts with the $known folder name else return the $file as it is.
 {my ($file, $known, $new) = @_;                                                # File name, existing prefix, new prefix
  swapFilePrefix($file, fpd($known), fpd($new));
 } # swapFolderPrefix

sub fullyQualifiedFile($;$)                                                     # Check whether a B<$file> name is fully qualified or not and, optionally, whether it is fully qualified with a specified B<$prefix> or not.
 {my ($file, $prefix) = @_;                                                     # File name to test, file name prefix
  return $file =~ m(\A/)s unless $prefix;                                       # Check against /