File Coverage

blib/lib/YAML/LoadBundle.pm

Criterion	Covered	Total	%
statement	195	220	88.6
branch	87	122	71.3
condition	7	12	58.3
subroutine	24	24	100.0
pod	4	4	100.0
total	317	382	82.9

package YAML::LoadBundle;
# ABSTRACT: Load a directory of YAML files as a bundle
use version;
our $VERSION = 'v0.4.3'; # VERSION

use base qw(Exporter);
use warnings;
use strict;

use Carp;
use Cwd                 qw( abs_path );
use Digest::SHA1        qw( sha1_hex sha1 );
use File::Find          qw( find );
use Hash::Merge::Simple ();
use Scalar::Util        qw( reftype refaddr );
use Storable            qw( freeze dclone );
use YAML::XS            qw(Load);

our @EXPORT_OK = qw(
    load_yaml
    load_yaml_bundle
    add_yaml_observer
    remove_yaml_observer
);
our %EXPORT_TAGS = ( all => [@EXPORT_OK] );

our $CacheDir;
$CacheDir = $ENV{YAML_LOADBUNDLE_CACHEDIR} unless defined $CacheDir;

my @load_yaml_observers;

sub add_yaml_observer {
    my $observer = shift;
    die "Observer must be a code ref." unless ref($observer) eq 'CODE';
    push @load_yaml_observers, $observer;
}

sub _notify_yaml_observers {
    my $file = shift;
    for my $observer (@load_yaml_observers) {
        $observer->($file);
    }
}

sub remove_yaml_observer {
    my $observer = shift;
    die "Observer must be a code ref." unless ref($observer) eq 'CODE';
    my $obref = refaddr $observer;

    @load_yaml_observers = grep {
        refaddr($_) != $obref
    } @load_yaml_observers;
}

our %seen;

sub load_yaml {
    my ($arg, $dont_cache) = @_;
    my @yaml;
    my $cache_mtime;
    my %params;

    # We clone references that appear more than once in the data
    # structure. (For compatibility with Data::Visitor.)
    local %seen = ();

    if (ref $arg) {
        @yaml = <$arg>;
    }
    elsif ($arg =~ /\n/) {
        my $digest      = sha1($arg);
           $cache_mtime = 1;
        my $perl        = _yaml_cache_peek($digest, $cache_mtime);
        return $perl if defined $perl;
        open my $fh, '<', \$arg;
        @yaml = <$fh>;
        $arg  = $digest;
        $params{no_disk_cache} = 1;
    }
    elsif (-f $arg and -s _) {
        # $arg is a file path.
        _notify_yaml_observers($arg);

        my $mtime = (stat _)[9];
        my $perl = _yaml_cache_peek($arg, $mtime);
        return $perl if defined $perl;

        open my $fh, $arg
            or croak "Can't open YAML file $arg: $!";
        @yaml = <$fh>;
        $cache_mtime = $mtime;
    }
    else {
        croak "Can't load empty/missing YAML file: $arg.";
    }

    my $perl;
    eval { $perl = Load(join '', @yaml) };

    die "$@\nYAML File: $arg\n" if $@;

    # Can't cache/flatten empty YAML
    return unless $perl;

    # TODO: this is a temporary fix. previous functionaly skipped caching if a
    # second arg was passed into load_yaml. a recent refactor introduced a bug
    # that caused the code to never cache. as a temporary workaround we will
    # just set $cache_mtime to 0 if there's a second arg to this method. this
    # will tell _unravel_and_cache to skip the caching step.
    $cache_mtime = 0 if $dont_cache;
    $perl = _unravel_and_cache($arg, $perl, $cache_mtime, %params);

    return $perl;
}

my $shallow_merge = sub {
    my ($left, $right) = @_;
    if (reftype($left) eq 'ARRAY') {
        $left = { map %$_, @$left };
    }
    return (
        (map { %$_ } (reftype($left) eq 'ARRAY' ? @$left : $left)),
        %$right
    );
};
my $deep_merge = sub {
    my ($left, $right) = @_;
    return %{ Hash::Merge::Simple->merge(
        (reftype($left) eq 'ARRAY' ? @$left : $left),
        $right,
    ) };
};

my $clone_merge = sub {

    my ($left, $right) = @_;

    if (reftype($left) eq 'HASH' && reftype($right) eq 'HASH')
    {
        my %seen;

        foreach my $key (keys %$left)
        {
            my $clone = $left->{$key};

            die "-clone of $key is not a hash\n"
                unless reftype($clone) eq "HASH";

            my $list = delete $clone->{$key};

            die "-clone of $key is missing a list of keys under the same key\n"
                unless $list && reftype($list) eq 'ARRAY';

            foreach my $cloned_key (@$list)
            {
                die "-clone key $cloned_key must appear only once.\n"
                    if $seen{$cloned_key}++;

                $right->{$cloned_key} = $clone;
            }
        }

        return %$right;
    }

    die "-clone must appear in a hash, and contain a hash.\n";
};

# in order of priority:
my @SPECIAL = qw(
    -merge
    export
    -export
    import
    -import
    -clone
);
my %SPECIAL = (
    -import => $shallow_merge,
    import  => $shallow_merge,
    -export => $shallow_merge,
    export  => $shallow_merge,
    -merge  => $deep_merge,
    -clone  => $clone_merge,
);

# Note: This used to add a (heavy) dependency on Data::Visitor
# to do these simple transformations. I *think* this is exactly
# equivalent to what it used to do.

sub _unravel {
    my $data = shift;

    if (ref $data) {
        $data = dclone($data) if $seen{$data}++;

        if (reftype $data eq 'HASH') {
            return _unravel_hash($data);
        }
        elsif (reftype $data eq 'ARRAY') {
            for my $elt (@$data) {
                $elt = _unravel($elt);
            }
            return $data;
        }
    }

    return $data;
}

# Note: this modifies the argument in place. But sometimes it returns
# a different reference, in order to replace itself in the enclosing
# data structure. (If it encounters a "-flatten" entry.)

sub _unravel_hash {
    my $data = shift;

    while (my @keys = grep { exists $data->{$_} } @SPECIAL) {
        # Make sure that deeper -merges and such will be handled first
        for my $key ( grep { ! $SPECIAL{ $_ } } keys %$data ) {
            # False values can be skipped for performance
            next unless $data->{$key};
            $data->{$key} = _unravel($data->{$key})
        }

        for my $key (@keys) {
            my $handler = $SPECIAL{$key};
            my $val = delete $data->{$key};
            next unless $val;
            %$data = $handler->(_unravel($val), $data);
        }
    }

    if (keys %$data == 1) {
        if (my $arrs = $data->{-flatten}) {
            _unravel($arrs);
            return [ map @$_, @$arrs ];
        }
        elsif (my $hrefs = $data->{-flattenhash}) {
            _unravel($hrefs);
            return { map %$_, @$hrefs };
        }
    }

    for my $elt (values %$data) {
        $elt = _unravel($elt) if ref($elt);
    }

    $data = dclone($data) if $seen{$data}++;
    return $data;
}


{
my %YAML_cache;
sub _unravel_and_cache {
    my ($path, $perl, $cache_mtime, %params) = @_;

    _unravel($perl);

    # TODO: need a better way to explicitly not cache here
    if ($cache_mtime) {
        my $frozen = Storable::freeze($perl);
        $YAML_cache{$path} = [ $cache_mtime, $frozen ];
        if ($CacheDir and not $params{no_disk_cache}) {
            my $cache_file = join "/", $CacheDir, sha1_hex($path);

            eval { mkdir $CacheDir };
            if ($@) {
                warn "Can't write yaml cache: $@";
            }
            else {
                open my $fh, '>', $cache_file or die "Cannot open $cache_file for writing $!";
                print $fh $frozen;
            }
        }
    }

    return $perl;
}

sub _yaml_cache_peek {
    my ($path, $mtime) = @_;

    my $cache = $YAML_cache{$path};
    if ($cache) {
        my ($oldtime, $oldyaml) = @$cache;
        return Storable::thaw($oldyaml) if $oldtime == $mtime;
    }
    elsif ($CacheDir) {
        my $cache_file = join "/", $CacheDir, sha1_hex($path);
        if (-f $cache_file) {
            my $cache_time = (stat $cache_file)[9];
            if ($cache_time >= $mtime) {
                open my $fh, "<$cache_file";
                my $file_contents = do { local $/; <$fh> };
                my $thawed = Storable::thaw($file_contents);
                $YAML_cache{$path} = [ $mtime, $file_contents ];
                return $thawed if $cache_time >= $mtime;
            }
            else {
                unlink $cache_file;
            }
        }
    }

    return;
}
}

{
my %default_options = (
    follow_symlinks_when => 'bundled',
    follow_symlinks_fail => 'error',
    conf_suffixes => [ 'conf', 'yml' ],
    max_depth => 20,
);

my %symlink_skipper = (
    error  => sub { croak "Symlink $_[1] was skipped.\nYAML Bundle: $_[0]\n" },
    warn   => sub { carp  "Symlink $_[1] was skipped.\nYAML Bundle: $_[0]\n" },
    ignore => sub { },
);

sub _merge_bundle {
    my ($current, $nested) = @_;

    if (ref($nested) eq 'ARRAY') {
        $current = [] unless defined $current;
        return +{ $deep_merge->($current, $nested) };
    }
    else {
        $current = {} unless defined $current;
        return +{ $deep_merge->($current, $nested) };
    }
}

sub load_yaml_bundle {
    my ($path, $given_options) = @_;
    my $cache_mtime;

    # Setup the default configuration
    my %options = (
        %{ $given_options || {} },
        %default_options,
    );

    # Add _vars to the options to allow recursive calls to share state.
    $options{_match_suffix} = join "|", map { quotemeta } @{ $options{conf_suffixes} }
        unless defined $options{_match_suffix};
    $options{max_depth}--;

    # Calculate the absolute base path to start from
    unless (defined $options{_original_path}) {
        $options{_original_path} = abs_path($path);
        $options{_original_path_length} = length $options{_original_path};

        # This is the top call, so check the cache
        my $this_mtime;
        $cache_mtime = 0;
        find({
            follow_fast => 1,
            wanted      => sub {
                if (/^.*\.(?:$options{_match_suffix})\z/s) {
                    $this_mtime = (lstat _)[9];
                    $cache_mtime = $this_mtime if $this_mtime > $cache_mtime;
                }
            },
        },
            $options{_original_path},
            grep { -f $_ }
                map { "$options{_original_path}.$_" }
                @{ $options{conf_suffixes} }
        );
        my $perl = _yaml_cache_peek($path, $cache_mtime);

        return $perl if defined $perl;
    }

    my $symlink_skipper = $symlink_skipper{ $options{follow_symlinks_fail} };

    # Stop, we've gone too far.
    if ($options{max_depth} < 0) {
        carp "Reached maximum path search depth while at $path.\nYAML Bundle: $options{_original_path}\n";
        return;
    }

    my $perl;

    # Do we have a top level .conf/.yml/.whatever in the bundle?
    for my $suffix (@{ $options{conf_suffixes} }) {
        my $file = $path . '.' . $suffix;
        if (-f $file and -s _) {

            # If $perl is already defined, we have a case where multiple
            # configuration files are present, which is not a defined case.
            carp "Multiple configuration files match $path. This will lead to unexpected results.\nYAML Bundle: $options{_original_path}\n"
                if defined $perl;

            # We don't use load_yml because we don't want the intermediate
            # pieces cached and it does a lot of work we'd repeat anyway.

            open my $fh, $file
                or croak "Can't open YAML file $file: $!";
            my $yaml = do { local $/; <$fh> };

            $perl = eval { Load($yaml) };
            if ($@) {
                croak "Eror in file $file: $@\nYAML Bundle: $options{_original_path}\n";
            }
        }
    }

    # if no file found, we have to start somewhere
    $perl = {} unless defined $perl;

    # If this is a directory, let's suck in all the nested configs
    if (-d $path) {
        opendir my $dir_fh, $path or croak "Cannot opendir $path: $!";

        # Saves us from duplicating work while recursing...
        my %closed_list;

        ENTRY: while (my $entry = readdir $dir_fh) {

            # Ignore all dot files
            next if $entry =~ m{^[.]};

            my $nested_path = abs_path("$path/$entry");

            if (not defined $nested_path) {
                croak "Broken symlink or other problem while locating $path/$entry.\nYAML Bundle: $options{_original_path}\n";
            }

            # If bundled, make sure this abs path is in the root bas path
            if ($options{follow_symlinks_when} eq 'bundled') {
                unless (substr($nested_path, 0, $options{_original_path_length}) eq $options{_original_path}) {
                    $symlink_skipper->($options{_original_path}, "$path/$entry");
                    next ENTRY;
                }
            }

            # If never, skip any symlink
            elsif ($options{follow_symlinks_when} eq 'never') {
                if (-l "$path/$entry") {
                    $symlink_skipper->($options{_original_path}, "$path/$entry");
                    next ENTRY;
                }
            }

            # Is this a directory? If so, load that as a bundle.
            if (-d $nested_path) {
                next ENTRY if $closed_list{$nested_path};

                # We don't follow symlinks to directories. This is a naive way
                # to prevent infinite recursion.
                if (-l "$path/$entry") {
                    croak "Symlink to directory $path/$entry is not permitted.\nYAML Bundle: $options{_original_path}\n";
                }

                # Load the nested bundle and merge.
                $closed_list{$nested_path}++;
                $perl->{ $entry } = _merge_bundle(
                    $perl->{ $entry },
                    load_yaml_bundle($nested_path, \%options)
                );
            }

            # Is this a file with the right suffix?
            elsif (-f $nested_path and $entry =~ s/[.](?:$options{_match_suffix})$//) {
                my $nested_path_minus_suffix = $nested_path;
                $nested_path_minus_suffix =~ s/[.](?:$options{_match_suffix})$//;
                next ENTRY if $closed_list{$nested_path_minus_suffix};

                # Load the nested bundle and merge.
                $closed_list{$nested_path_minus_suffix}++;
                $perl->{ $entry } = _merge_bundle(
                    $perl->{ $entry },
                    load_yaml_bundle($nested_path_minus_suffix, \%options)
                );
            }

            # What the hey? Carp about this...
            else {
                carp "Ignoring unexpected path $nested_path of unknown type.\nYAML Bundle: $options{_original_path}\n";
            }
        }
    }

    # Only unravel our format layer and cache the top
    # $cache_mtime is only set in the call _original_path is set
    if ($cache_mtime) {
        $perl = _unravel_and_cache($options{_original_path}, $perl, $cache_mtime);
    }

    return $perl;
}
}

1;

__END__