File Coverage

blib/lib/Data/Section/Pluggable.pm

Criterion	Covered	Total	%
statement	182	185	98.3
branch	54	62	87.1
condition	6	8	75.0
subroutine	24	24	100.0
pod	4	6	66.6
total	270	285	94.7

use warnings;
use 5.020;
use true;
use experimental qw( signatures );
use stable qw( postderef );

package Data::Section::Pluggable 0.08 {

    # ABSTRACT: Read structured data from __DATA__


    use Class::Tiny qw( package prefer_filesystem filename _formats _cache );
    use Exporter qw( import );
    use Ref::Util qw( is_ref is_plain_hashref is_coderef is_plain_arrayref is_blessed_ref );
    use MIME::Base64 qw( decode_base64 encode_base64 );
    use Path::Tiny 0.130 ();
    use Carp ();

    our @EXPORT_OK = qw( get_data_section );

    sub BUILDARGS ($class, @args) {
        if(@args == 1) {
            return $args[0] if is_plain_hashref $args[0];
            return { package => $args[0] };
        } else {
            my %args = @args;
            return \%args;
        }
    }

    sub BUILD ($self, $) {
        unless(defined $self->package) {
            my $package = caller 2;
            $self->package($package);
        }
        foreach my $attr (qw( prefer_filesystem filename )) {
            if(defined $self->$attr) {
                unless(is_blessed_ref($self->$attr) && $self->$attr->isa('Path::Tiny')) {
                    $self->$attr(Path::Tiny->new($self->$attr)->absolute);
                }
            }
        }
        $self->_formats({});
    }


    sub get_data_section ($self=undef, $name=undef) {

        # handle being called as a function instead of
        # a method.
        unless(is_ref $self) {
            $name = $self;
            $self = __PACKAGE__->new(scalar caller);
        }

        my $all = $self->_get_all_data_sections;
        return undef unless $all;

        if (defined $name) {
            if(exists $all->{$name}) {
                return $self->_format($name, $all->{$name});
            }
            return undef;
        } else {
            return $self->_format_all($all);
        }
    }

    sub _format_all ($self, $all) {
        my %new;
        foreach my $key (keys %$all) {
            $new{$key} = $self->_format($key, $all->{$key});
        }
        \%new;
    }

    sub _format ($self, $name, $content) {
        $content = $self->_decode($content->@*);
        if($name =~ /\.(.*?)\z/ ) {
            my $ext = $1;
            if($self->_formats->{$ext}) {
                $content = $_->($self, $content) for $self->_formats->{$ext}->@*;
            }
        }
        return $content;
    }

    sub _decode ($self, $content, $encoding) {
        return $content unless $encoding;
        if($encoding ne 'base64') {
            Carp::croak("unknown encoding: $encoding");
        }
        return decode_base64($content);
    }

    sub _get_all_data_sections ($self) {
        return $self->_cache if $self->_cache;

        my $fh;

        if($self->filename) {
            $fh = $self->filename->openr_raw;
        } else {
            $fh = do { no strict 'refs'; \*{$self->package."::DATA"} };
        }

        return undef unless defined fileno $fh;

        # Question: does this handle corner case where perl
        # file is just __DATA__ section?  turns out, yes!
        # added test t/data_section_pluggable__data_only.t
        seek $fh, 0, 0;
        my $content = do { local $/; <$fh> };
        $content =~ s/^.*\n__DATA__\n/\n/s; # for win32
        $content =~ s/\n__END__\n.*$/\n/s;

        my @data = split /^@@\s+(.+?)\s*\r?\n/m, $content;

        # extra at start whitespace, or __DATA_ for data only file
        shift @data;

        my $all = {};
        while (@data) {
            my ($name_encoding, $content) = splice @data, 0, 2;
            my ($name, $encoding);
            if($name_encoding =~ /^(.*)\s+\((.*?)\)$/) {
                $name = $1;
                $encoding = $2;
            } else {
                $name = $name_encoding;
            }
            if($self->prefer_filesystem && -f (my $path = $self->prefer_filesystem->child($name))) {
                $content = $encoding ? encode_base64($path->slurp_raw) : $path->slurp_utf8;
            }
            $all->{$name} = [ $content, $encoding ];
        }

        return $self->_cache($all);
    }


    sub add_format ($self, $ext, $cb) {
        Carp::croak("callback is not a code reference") unless is_coderef $cb;
        push $self->_formats->{$ext}->@*, $cb;
        return $self;
    }


    sub add_plugin ($self, $name, %args) {

        Carp::croak("plugin name must match [a-z][a-z0-9_]+, got $name")
            unless $name =~ /^[a-z][a-z0-9_]+\z/;

        my $class = join '::', 'Data', 'Section', 'Pluggable', 'Plugin', ucfirst($name =~ s/_(.)/uc($1)/egr);
        my $pm    = ($class =~ s!::!/!gr) . ".pm";

        require $pm unless $self->_valid_plugin($class);

        my $plugin;
        if($class->can("new")) {
            $plugin = $class->new(%args);
        } else {
            if(%args) {
                Carp::croak("extra arguments are not allowed for class plugins (hint create constructor)");
            }
            $plugin = $class;
        }

        Carp::croak("$class is not a valid Data::Section::Pluggable plugin")
            unless $self->_valid_plugin($plugin);

        if($plugin->does('Data::Section::Pluggable::Role::ContentProcessorPlugin')) {
            my @extensions = $plugin->extensions;
            @extensions = $extensions[0]->@* if is_plain_arrayref $extensions[0];
            die "extensions method for $class returned no extensions" unless @extensions;

            my $cb = sub ($self, $content) {
                return $plugin->process_content($self, $content);
            };

            $self->add_format($_, $cb) for @extensions;

        };

        return $self;
    }

    sub _valid_plugin ($self, $plugin) {
        $plugin->can('does') && $plugin->does('Data::Section::Pluggable::Role::ContentProcessorPlugin');
    }


    sub extract ($self, $dir=undef) {
        $dir = Path::Tiny->new($dir // '.');

        my $all = $self->_get_all_data_sections;

        foreach my $key (keys %$all) {
            my $path = $dir->child($key);
            $path->parent->mkdir;
            my($content,$encoding) = $all->{$key}->@*;

            if(defined $encoding) {
                if($encoding eq 'base64') {
                    $path->spew_raw(decode_base64($content));
                } else {
                    Carp::croak("unknown encoding: $encoding");
                }
            } else {
                $path->spew_utf8($content);
            }
        }
    }

}

__END__