view release on metacpan or  search on metacpan

lib/Spreadsheet/Edit/IO.pm  view on Meta::CPAN

use Exporter 'import';

our @EXPORT = qw/convert_spreadsheet OpenAsCsv cx2let let2cx cxrx2sheetaddr
                 sheetname_from_spec filepath_from_spec
                 form_spec_with_sheetname/;

our @EXPORT_OK = qw/can_cvt_spreadsheets can_extract_allsheets can_extract_named_sheet
                    openlibreoffice_path
                    @sane_CSV_read_options @sane_CSV_write_options/;

# TODO: Provide "known_attributes" function ala Text::CSV::known_attributes()

use version ();
use Carp;

use File::Copy ();
use File::Copy::Recursive ();
use File::Glob qw/bsd_glob/;

use Path::Tiny 0.146 qw/path/;

# Path::Tiny OBVIATES NEED for many but we still need this
use File::Spec ();
use File::Spec::Functions qw/devnull tmpdir rootdir catdir catfile/;

# Still sometimes convenient...
use File::Basename qw(basename);

use File::BOM ();
use File::Which qw/which/;
use URI::file ();
use Guard qw(guard scope_guard);
use Fcntl qw(:flock :seek);
use Symbol qw/qualify_to_ref/;
use Scalar::Util qw/blessed openhandle/;
use List::Util qw/none all notall first min max/;
use Encode qw(encode decode);
use File::Glob qw/bsd_glob GLOB_NOCASE/;
use Digest::MD5 qw/md5_base64/;
use Data::Hexify qw/Hexify/;
use Text::CSV ();
# DDI 5.025 is needed for Windows-aware qsh()
use Data::Dumper::Interp 5.025 qw/vis visq visO dvis dvisq dvisO ivis ivisq avis hvis qsh qshlist u visnew/;

use Spreadsheet::Edit::Log qw/log_call fmt_call log_methcall fmt_methcall oops :btw/;
our %SpreadsheetEdit_Log_Options = (
  is_public_api => sub{
     $_[1][3] =~ /(?: ::|^ )(?: [a-z][^:]* | OpenAsCsv | ConvertSpreadsheet )$/x
  },
  subst_pkg => "IO",
);

my $progname = path($0)->basename;

sub _get_username(;$) {
  my ($uid) = @_;
  $uid //= eval{ $> } // -1; # default to EUID
  state $answer = {};
  return $answer->{$uid} //= do {
    # https://stackoverflow.com/questions/12081246/how-to-get-system-user-full-name-on-windows-in-perl
    eval { getpwuid($uid) // $uid }
    ||
    ($^O =~ /MSWin/ && $uid == (eval{$>}//-1) && eval{  # untested...
      require Win32API::Net;
      Win32API::Net::UserGetInfo($ENV{LOGONSERVER}||'',Win32::LoginName(),10,my $info={});
      $info->{fullName}
    })
    ||
    "UID$uid"
  };
}


# A private Libre/Open Office profile dir is needed to avoid conflicts
# with interactive sessions, see
# https://ask.libreoffice.org/en/question/290306/how-to-start-independent-lo-instance-process
#
# We use a persistent profile dir shared among processes for a given user
# (actually one for each unique external tool which needs one).
# Sharing is okay because we get an exclusive lock before actually using it.
state $profile_parent_dir = do{ # also used for lockfile
  my $user = _get_username();
  my $dname = __PACKAGE__."_${user}_profileparent";
  $dname =~ s/::/-/g;
  $dname =~ s/[^-\w.:]/_/g;
  (my $path = path(File::Spec->tmpdir)->child($dname))->mkpath;
  $path # Path::Tiny
};
sub _get_tool_profdir($) {
  my ($tool_path) = @_;
  my $fingerprint = _file_fingerprint($tool_path);
  (my $toolname = path($tool_path)->basename(qw/\.\w+$/)) =~ s/[^-\w.:]/_/g;
  my $path = $profile_parent_dir->child("${toolname}_$fingerprint");
  $path->mkpath;
  $path
}

# Prevent concurrent document conversions.
# LO & OO can't handle concurrent access to the same profile.
my $locked_fh;
sub _get_exclusive_lock($) { # returns lock object
  my $opts = shift;
  my $lockfile_path = $profile_parent_dir->child("LOCKFILE")->canonpath;
  my $sleeptime = 1;
  my $lock_fh;
  while (! defined $lock_fh) {
    #warn "$$ : ### AA1 open $lockfile_path ...\n";
    open $lock_fh, "+>>", $lockfile_path or die $!;
    #warn "$$ : ### AA2 open succeeded.\n";
    eval { chmod 0666, $lock_fh; }; # sometimes not implemented
    #warn "$$ : ### AA3 flock ...\n";
    if (! flock($lock_fh, LOCK_EX|LOCK_NB)) {
      #warn "$$ : ### AA4 flock FAILED\n";
      seek($lock_fh, 0, SEEK_SET) or die;
      my @lines = <$lock_fh>;
      close($lock_fh) or die "close:$!"; $lock_fh = undef;
      #warn "$$ : ### AA6 fh closed...\n";
      my $owner = $lines[-1] // "";  # pid NNN (progname)
      { my ($pid) = ($owner =~ /pid (\d+)/) or last;
        my @s = stat("/proc/$pid") or last;
        $owner = _get_username($s[4])." ".$owner;