File Coverage

lib/ChordPro/Paths.pm

Criterion	Covered	Total	%
statement	130	195	66.6
branch	28	70	40.0
condition	3	12	25.0
subroutine	21	31	67.7
pod	0	22	0.0
total	182	330	55.1

#! perl

use v5.26;
use Object::Pad;
use utf8;
use Carp;

class ChordPro::Paths;

my $instance;

# Work around Object::Pad 0.817 breakage.
#method get :common ( $reset = 0 ) {
#    undef $instance if $reset;
#    $instance //= $class->new;
#}

sub get( $class, $reset = 0 ) {
    undef $instance if $reset;
    $instance //= $class->new;
}

use Cwd qw(realpath);
use File::HomeDir;
use ChordPro::Files;

field $home      :reader;	# dir
field $configdir :reader;	# dir
field $privlib   :reader;	# dir
field $resdirs   :reader;	# [ dir, ... ]
field $configs   :reader;	# { config => dir, ... }
field $pathsep   :reader;	# : or ;

field $packager  :reader;

# Cwd::realpath always returns forward slashes.
# On Windows, Cwd::realpath always returns a volume.

BUILD {
    my $app = "ChordPro";
    my $app_lc = lc($app);

    $pathsep = is_msw ? ';' : ':';

    $home     = realpath( $ENV{HOME} = File::HomeDir->my_home );

#    $desktop  = File::HomeDir->my_desktop;
#    $docs     = File::HomeDir->my_documents;
#    $music    = File::HomeDir->my_music;
#    $pics     = File::HomeDir->my_pictures;
#    $videos   = File::HomeDir->my_videos;
#    $data     = File::HomeDir->my_data;
#    $dist     = File::HomeDir->my_dist_data('ChordPro');
#    $dist     = File::HomeDir->my_dist_config('ChordPro');

    # Establish config files. Global config is easy.
    for ( $self->normalize("/etc/$app_lc.json") ) {
	next unless $_ && -f;
	$configs->{sysconfig} = $_;
    }

    $configs = {};
    # The user specific config requires some alternatives.
    # -d $XDG_CONFIG_HOME/$app_lc
    # -d ~/.config/$app_lc
    # -d ~/.$app_lc
    # -d my_dist_config
    my @try;
    if ( defined( $ENV{XDG_CONFIG_HOME} ) && $ENV{XDG_CONFIG_HOME} ne "" ) {
	push( @try,
	      # See https://specifications.freedesktop.org/basedir-spec/basedir-spec-latest.html
	      # fn_catdir( $ENV{XDG_CONFIG_HOME}, ".config", $app_lc ),
	      # fn_catdir( $ENV{XDG_CONFIG_HOME}, ".config" ),
	      # fn_catdir( $ENV{XDG_CONFIG_HOME}, ".$app_lc" ) );
	      fn_catdir( $ENV{XDG_CONFIG_HOME}, "$app_lc" ) );
    }
    else {
	push( @try,
	      fn_catdir( $home, ".config", $app_lc ),
	      fn_catdir( $home, ".$app_lc" ),
	      File::HomeDir->my_dist_config($app) );
    }

    for ( @try ) {
	next unless $_ && fs_test( d => $_);
	my $path = $self->normalize($_);
	warn("Paths: configdir try $_ => $path\n") if $self->debug > 1;
	next unless $path && fs_test( d => $path);
	$configdir = $path;
	for ( $self->normalize( fn_catfile( $path, "$app_lc.prp" ) ),
	      $self->normalize( fn_catfile( $path, "$app_lc.json" ) ) ) {
	    next unless $_ && fs_test( f => $_ );
	    $configs->{userconfig} = $_;
	    last;
	}
	last if $configdir;
    }
    warn("Paths: configdir = ", $configdir // "", "\n") if $self->debug;

    for ( $self->normalize(".$app_lc.json"),
	  $self->normalize("$app_lc.json") ) {
	    next unless $_ && fs_test( f => $_ );
	$configs->{config} = $_;
	last;
    }
    if ( $self->debug ) {
	for ( qw( sysconfig userconfig config ) ) {
	    warn(sprintf("Paths: %-10s = %s\n",
			 $_, $configs->{$_} // "" ) );
	}
    }

    # Private lib.
    $privlib = $INC{'ChordPro.pm'} =~ s/\.pm$/\/lib/r;

    # Now for the resources.
    $self->setup_resdirs;

    # Check for packaged image.
    for ( qw( OCI Docker AppImage PPL ) ) {
	next unless exists $ENV{uc($_)."_PACKAGED"}
	  && $ENV{uc($_)."_PACKAGED"};
	$packager = $_;
	last;
    }

};

# We need this to be able to re-establish the resdirs, e.g. after a change
# of CHORDPRO_LIB.
method setup_resdirs {
    $resdirs = [];
    my @try = ();
    push( @try, $self->path($ENV{CHORDPRO_LIB}) )
      if defined($ENV{CHORDPRO_LIB});
    push( @try, $configdir ) if $configdir;
    push( @try, $INC{'ChordPro.pm'} =~ s/\.pm$/\/res/r );

    for ( @try ) {
	next unless $_;
	my $path = $self->normalize($_);
	warn("Paths: resdirs try $_ => $path\n") if $self->debug > 1;
	next unless $path && fs_test( d => $path );
	push( @$resdirs, $path );
    }

    if ( $self->debug ) {
	for ( 0..$#{$resdirs} ) {
	    warn("Paths: resdirs[$_] = $resdirs->[$_]\n");
	}
    }

    unless ( @$resdirs ) {
	warn("Paths: Cannot find resources, prepare for disaster\n");
    }
}

method debug {
    # We need to take an env var into account, since the Paths
    # singleton is created far before any config processing.
    $ENV{CHORDPRO_DEBUG_PATHS} || $::config->{debug}->{paths} || 0;
}

# Is absolute.

method is_absolute ( $p ) {
    fn_is_absolute( $p );
}

# Is bare (no volume/dir).

method is_here ( $p ) {
    my ( $v, $d, $f ) = fn_splitpath($p);
    $v eq '' && $d eq '';
}

# Normalize - full path, forward slashes, ~ expanded.

method normalize ( $p, %opts ) {
    $p = $home . "/$1" if $p =~ /~[\\\/](.*)/;
    realpath($p)
}

# This is only used in ::runtimeinfo for display purposes.

method display ( $p ) {
    return "" unless defined $p;
    $p = $self->normalize($p);
    if ( index( $p, $home ) == 0 ) {
	substr( $p, 0, length($home), '~' );
    }
    return $p;
}

method path ( $p = undef ) {
    if ( defined($p) ) {
	local $ENV{PATH} = $p;
	my @p = File::Spec->path();
	# On MSWindows, '.' is always prepended.
	shift(@p) if is_msw;
	return @p;
    }
    return File::Spec->path();
}

# Prepend/append dirs to path.

method pathprepend( @d ) {
    $ENV{PATH} = $self->pathcombine( @d, $ENV{PATH} );
}

method pathappend( @d ) {
    $ENV{PATH} = $self->pathcombine( $ENV{PATH}, @d );
}

method pathcombine( @d ) {
    join( $pathsep, @d );
}

# Locate an executable file (program) using PATH.

method findexe ( $p, %opts ) {
    my $try = $p;
    my $found;
    if ( is_msw ) {
	$try .= ".exe";
    }

    if ( fn_is_absolute($p)
	 && ChordPro::Files::fs_test( fx => $p ) ) {
	warn("Paths: findexe $p => ", $self->display($p), "\n")
	  if $self->debug;
	return $p;
    }

    for ( $self->path ) {
	my $e = fn_catfile( $_, $try );
	$found = realpath($e), last if fs_test( fx => $e );
    }
    if ( $self->debug ) {
	warn("Paths: findexe $p => ", $self->display($found), "\n");
    }
    elsif ( !$found && !$opts{silent} ) {
	warn("Could not find $p in ",
	     join( " ", map { qq{"$_"} } $self->path ), "\n");
    }
    return $found;
}

# Locate a config file (prp or json) using respath.

method findcfg ( $p ) {
    my $found;
    my @p;
    if ( $p =~ /\.\w+$/ ) {
	$found = realpath($p) if fs_test( fs => $p );
	@p = ( $p );
    }
    else {
	$p =~ s/:+/\//g;
	@p = ( "$p.prp", "$p.json" );
    }
    unless ( $found ) {
	for ( @$resdirs ) {
	    for my $cfg ( @p ) {
		my $f = fn_catfile( $_, "config", $cfg );
		$found = realpath($f), last if fs_test( fs => $f );
	    }
	}
    }
    warn("Paths: findcfg $p => ", $self->display($found), "\n")
      if $self->debug;
    return $found;
}

# Locate a resource file (optionally classified) using respath.

method findres ( $p, %opts ) {
    my $try = $p;
    my $found;
    if ( fn_is_absolute($p) ) {
	$found = realpath($p);
    }
    else {
	if ( defined $opts{class} ) {
	    $try = fn_catfile( $opts{class}, $try );
	}
	for ( @$resdirs ) {
	    my $f = fn_catfile( $_, $try );
	    $found = realpath($f), last if fs_test( fs => $f );
	}
    }
    warn("Paths: findres", $opts{class} ? " [$opts{class}]" : "",
	 " $p => ", $self->display($found), "\n")
      if $self->debug;
    return $found;
}

# Locate resource directories (optionally classified) using respath.

method findresdirs ( $p, %opts ) {
    my $try = $p;
    my @found;
    if ( defined $opts{class} ) {
	$p = fn_catdir( $opts{class}, $p );
    }
    for ( @$resdirs ) {
	my $d = fn_catdir( $_, $p );
	push( @found, realpath($d) ) if fs_test( d => $d );
    }
    if ( $self->debug ) {
	my $i = 0;
	@found = ( "" ) unless @found;
	warn("Paths: findresdirs[",
	     $opts{class} ? "$opts{class}:" : "",
	     $i++, "]",
	     " $p => ", $self->display($_), "\n") for @found;
    }
    return \@found;
}

# Return the name of a sibling (i.e., same place, different name
# and/or extension).

method sibling ( $orig, %opts ) {
    # Split.
    my ( $v, $d, $f ) = fn_splitpath($orig);
    my $res;
    if ( $opts{name} ) {
	$res = fn_catpath( $v, $d, $opts{name} );
    }
    else {
	# Get base and extension.
	my ( $b, $e ) = $f =~ /^(.*)(?:\.(\w+))$/;
	# Adjust.
	$b = $opts{base} if defined $opts{base};
	$e = $opts{ext}  if defined $opts{ext};
	# New file name.
	$f = $b;
	$f .= $e if defined $e;
	# Join with path.
	$res = fn_catpath( $v, $d, $f );
    }
    warn("Paths: sibling $orig => ", $self->display($res), "\n")
      if $self->debug;
    return $res;
}

# Given a file and a name, try name as a sibling, otherwise look it up.

method siblingres ( $orig, $name, %opts ) {
    return unless defined $orig;
    my $try = $self->sibling( $orig, name => $name );
    my $found = ( $try && fs_test( s => $try ) )
      ? $try
      : $self->findres( $name, class => $opts{class} );
    return $found;
}

method packager_version {
    return unless $packager;
    $ENV{uc($packager)."_PACKAGED"};
}

################ Export ################

# For convenience.

use Exporter 'import';
our @EXPORT;

sub CP() { __PACKAGE__->get }

push( @EXPORT, 'CP' );

1;