File Coverage

lib/Module/Build/SysPath.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package Module::Build::SysPath;

use warnings;
use strict;

our $VERSION = '0.16';

use base 'Module::Build';
use Sys::Path 0.11;
use List::MoreUtils 'any';
use FindBin '$Bin';
use Digest::MD5 qw(md5_hex);
use Text::Diff 'diff';
use File::Spec;
use File::Basename 'basename', 'dirname';
use File::Path 'make_path';

our $sys_path_config_name = 'SPc';

sub new {
	my $class = shift;
	my $builder = $class->SUPER::new(@_);
    my $module  = $builder->module_name;

    # normalize module name (some people write - instead of ::) and add config level
    $module =~ s/-/::/g;
    $module .= '::'.$sys_path_config_name;

    do {
        unshift @INC, File::Spec->catdir($Bin, 'lib');
        eval "use $module"; die $@ if $@;
    };

    my $distribution_root = Sys::Path->find_distribution_root($builder->module_name);
    print 'dist root is ', $distribution_root, "\n";

    # map conf files to array of real paths
    my @conffiles = (
        map { ref $_ eq 'ARRAY' ? File::Spec->catfile(@{$_}) : $_ }     # convert path array to file name strings
        @{$builder->{'properties'}->{'conffiles'} || []}                # all conffiles
    );

    my %spc_properties = (
        'path_types' => [ $module->_path_types ],
    );
    my %rename_in_system;
    my %conffiles_in_system;
    my @writefiles_in_system;
    my @create_folders_in_system;
    foreach my $path_type ($module->_path_types) {
        my $sys_path     = $module->$path_type;
        my $install_path = Sys::Path->$path_type;

        $builder->{'properties'}->{$path_type.'_files'} ||= {};

        # store for install time retrieval
        $spc_properties{'path'}->{$path_type} = $install_path;

        # skip prefix and localstatedir those are not really destination paths
        next
            if any { $_ eq $path_type } ('prefix' ,'localstatedir');

        # prepare a list of files to install
        my $non_persistant = (any { $_ eq $path_type} qw(cachedir logdir spooldir rundir lockdir sharedstatedir));
        if (-d $sys_path) {
            my %files;
            my @ignore_folders;
            foreach my $file (@{$builder->rscan_dir($sys_path)}) {
                # skip folders, but remember folders with . prefix
                if (-d $file) {
                    $file =~ s/$distribution_root.//;

                    # ignore folders with . prefix
                    push @ignore_folders, File::Spec->catfile($file, '')    # File::Spec with empty string to add portable trailing slash
                        if (basename($file) =~ m{^\.} and (not exists $builder->{'properties'}->{$path_type.'_files'}->{$file}));

                    next;
                }

                my $blib_file = $file;
                my $dest_file = $file;
                $file         =~ s/$distribution_root.//;
                $dest_file    =~ s/^$sys_path/$install_path/;
                $blib_file    =~ s/^$sys_path.//;
                $blib_file    = File::Spec->catfile($path_type, $blib_file);

                # allow empty directories to be created
                push @create_folders_in_system, dirname($dest_file)
                    if (basename($file) eq '.exists');

                # skip non-persistant folders, only include explicitely wanted and .exists files
                next if
                    $non_persistant
                    and (not exists $builder->{'properties'}->{$path_type.'_files'}->{$file})
                ;

                # skip files from .folders, only include explicitely wanted
                next if any {
                    ($file =~ m/^$_/)
                    and (not exists $builder->{'properties'}->{$path_type.'_files'}->{$file})
                } @ignore_folders;

                # skip files with . prefix
                next if
                    (basename($file) =~ m/^\./)
                    and (basename($file) ne '.exists')
                ;

                # print 'file>  ', $file, "\n";
                # print 'bfile> ', $blib_file, "\n";
                # print 'dfile> ', $dest_file, "\n\n";

                if (any { $_ eq $file } @conffiles) {
                    $conffiles_in_system{$dest_file} = md5_hex(IO::Any->slurp([$file]));

                    my $diff;
                    $diff = diff($file, $dest_file, { STYLE => 'Unified' })
                        if -f $dest_file;
                    if (
                        $diff                                                   # prompt when files differ
                        and Sys::Path->changed_since_install($dest_file)        # and only if the file changed on filesystem
                    ) {
                        # prompt if to overwrite conf or not
                        if (
                            # only if the distribution conffile changed since last install
                            Sys::Path->changed_since_install($dest_file, $file)
                            and Sys::Path->prompt_cfg_file_changed(
                                $file,
                                $dest_file,
                                sub { $builder->prompt(@_) },
                            )
                        ) {
                            $rename_in_system{$dest_file} = $dest_file.'-old';
                        }
                        else {
                            $blib_file .= '-spc';
                            $dest_file .= '-spc';
                        }
                    }
                }

                # add file the the Build.PL _files list
                $files{$file} = $blib_file;

                # make the conf and state files writable in the system
                push @writefiles_in_system, $dest_file
                    if any { $_ eq $path_type } qw(sharedstatedir sysconfdir);
            }
            $builder->{'properties'}->{$path_type.'_files'} = \%files;
        }

        # set installation paths
        $builder->{'properties'}->{'install_path'}->{$path_type} = $install_path;

        # add build elements of the path types
        $builder->add_build_element($path_type);
    }
    $builder->{'properties'}->{'spc'} = \%spc_properties;
    $builder->notes('rename_in_system'     => \%rename_in_system);
    $builder->notes('conffiles_in_system'  => \%conffiles_in_system);
    $builder->notes('writefiles_in_system' => \@writefiles_in_system);
    $builder->notes('create_folders_in_system' => \@create_folders_in_system);

    return $builder;
}

sub ACTION_install {
    my $builder = shift;
    my $destdir = $builder->{'properties'}->{'destdir'};

    # move system file for backup (only when really installing to system)
    if (not $destdir) {
        my %rename_in_system = %{$builder->notes('rename_in_system')};
        while (my ($system_file, $new_system_file) = each %rename_in_system) {
            print 'Moving ', $system_file,' -> ', $new_system_file, "\n";
            rename($system_file, $new_system_file) or die $!;
        }
    }

    # create requested folders
    foreach my $folder (@{$builder->notes('create_folders_in_system')}) {
        $folder = File::Spec->catdir($destdir || (), $folder);
        if (not -d $folder) {
            print 'Creating '.$folder.' folder', "\n";
            make_path($folder);
        }
    }

    $builder->SUPER::ACTION_install(@_);

    my $module  = $builder->module_name;

    my $path_types = join('|', @{$builder->{'properties'}->{'spc'}->{'path_types'}});

    # normalize module name (some people write - instead of ::) and add config level
    $module =~ s/-/::/g;
    $module .= '::'.$sys_path_config_name;

    # get path to blib and just installed SPc.pm
    my $module_filename = $module.'.pm';
    $module_filename =~ s{::}{/}g;
    my $installed_module_filename = File::Spec->catfile(
        $builder->install_map->{File::Spec->catdir(
            $builder->blib,
            'lib',
        )},
        $module_filename
    );
    $module_filename = File::Spec->catfile($builder->blib, 'lib', $module_filename);

    die 'no such file - '.$module_filename
        if not -f $module_filename;
    die 'no such file - '.$installed_module_filename
        if not -f $installed_module_filename;
    unlink $installed_module_filename;

    # write the new version of SPc.pm
    open(my $config_fh, '<', $module_filename) or die $!;
    open(my $real_config_fh, '>', $installed_module_filename) or die $!;
    while (my $line = <$config_fh>) {
        next if ($line =~ m/# remove after install$/);
        if ($line =~ m/^sub \s+ ($path_types) \s* {/xms) {
            $line =
                'sub '
                .$1
                ." {'"
                .$builder->{'properties'}->{'spc'}->{'path'}->{$1}
                ."'};\n"
            ;
        }
        print $real_config_fh $line;
    }
    close($real_config_fh);
    close($config_fh);

    # see https://rt.cpan.org/Ticket/Display.html?id=49579
    # ExtUtils::Install is forcing 0444 so we have to hack write permition after install :-/
    foreach my $writefile (@{$builder->notes('writefiles_in_system')}) {
        chmod 0644, File::Spec->catfile($destdir || (), $writefile) or die $!;
    }

    # record md5sum of new distribution conffiles (only when really installing to system)
    Sys::Path->install_checksums(%{$builder->notes('conffiles_in_system')})
        if (not $destdir);

    return;
}

1;


__END__