File Coverage

blib/lib/Data/Section/Writer.pm

Criterion	Covered	Total	%
statement	148	151	98.0
branch	35	50	70.0
condition	13	17	76.4
subroutine	22	22	100.0
pod	6	7	85.7
total	224	247	90.6

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

package Data::Section::Writer 0.05 {

  # ABSTRACT: Write __DATA__ section files for Data::Section, Data::Section::Simple or Mojo::Loader::data_section


  use Path::Tiny ();
  use Carp ();
  use Class::Tiny qw( perl_filename _files _same _formats );
  use Ref::Util qw( is_coderef is_blessed_ref is_plain_arrayref );
  use MIME::Base64 qw(encode_base64);
  use File::Temp ();

  sub BUILD ($self, $) {

    # use the callers filename if not provided.
    unless(defined $self->perl_filename) {
      my(undef, $fn) = caller 2;
      $self->perl_filename($fn);
    }

    # upgrade to Path::Tiny if it is not already
    unless(is_blessed_ref $self->perl_filename && $self->isa('Path::Tiny')) {
      $self->perl_filename(Path::Tiny->new($self->perl_filename));
    }

    $self->_files({});
    $self->_formats({});

  }


  sub add_file ($self, $filename, $content, $encoding=undef) {
    Carp::croak("Unknown encoding $encoding") if defined $encoding && $encoding ne 'base64';
    $self->_files->{"$filename"} = [ $content, $encoding ];
    return $self;
  }

  sub _render_file ($self, $filename, $data) {
    my $text = "@@ $filename";
    $text .= " (" . $data->[1] . ")" if defined $data->[1];
    $text .= "\n";

    my $content = $data->[0];

    if($filename =~ /\.(.*?)\z/ && ($self->_formats->{$1} // [])->@*) {
        my $ext = $1;
        $content = $_->($self, $content) for $self->_formats->{$ext}->@*;
    }

    if(defined $data->[1] && $data->[1] eq 'base64') {
        $text .= encode_base64($data->[0]);
    } else {
        $text .= $content;
    }
    chomp $text;
    return $text;
  }


  sub render_section ($self) {
    my $files = $self->_files;
    return "__DATA__\n" unless %$files;
    return join("\n",
      "__DATA__",
      (map { $self->_render_file($_, $files->{$_}) } sort keys $files->%*),
      ''
    );
  }


  sub update_file ($self) {
    my $perl;
    my $orig;

    if(-f $self->perl_filename) {
      $orig = $perl = $self->perl_filename->slurp_utf8;

      if($perl =~ /^__DATA__/) {
        $perl = '';
      } else {
        # read the file in, removing __DATA__ and everything after that
        # if there is no __DATA__ section then leave unchanged.
        $perl =~ s/(?<=\n)__DATA__.*//s;

        # Add a new line at the end if it doesn't already exist.
        $perl .= "\n" unless $perl =~ /\n\z/s;
      }

    } else {
      $perl = '';
    }

    $perl .= $self->render_section;

    if(defined $orig && $orig eq $perl) {
      $self->_same(1);
      return $self;
    } else {
      $self->_same(0);
    }

    if(-f $self->perl_filename) {
      use autodie qw( truncate close );
      # re-write the perl to the file, using the existing inode
      my $backup = Path::Tiny->new(File::Temp::tempnam($self->perl_filename->parent, $self->perl_filename->basename));
      $self->perl_filename->copy($backup) if -f $self->perl_filename;
      my $fh = $self->perl_filename->openrw_utf8;
      truncate $fh, 0;
      print $fh $perl or die "unable to write to @{[ $self->perl_filename ]} $!";
      close $fh;
      $backup->remove if -f $backup;
    } else {
      $self->perl_filename->spew_utf8($perl);
    }

    return $self;
  }


  sub unchanged ($self) {
      return $self->_same;
  }


    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::FormatContentPlugin')) {

            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->format_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::FormatContentPlugin');
    }
}

__END__