view release on metacpan or  search on metacpan

lib/Archive/Libarchive/Compress.pm  view on Meta::CPAN

        if defined($options{filename}) && defined($options{memory});

      if(defined $options{memory} && !(is_plain_scalarref $options{memory} && defined $options{memory}->$* && !is_ref $options{memory}->$*)) {
        Carp::croak("Option memory must be a scalar reference to a plain non-reference scalar");
      }

      Carp::croak("Entry is not a code reference")
        if defined $options{entry} && !is_plain_coderef $options{entry};

      my $self = bless {
        filename   => delete $options{filename},
        entry      => delete($options{entry}) // sub ($e) { return 1 },
        memory     => delete $options{memory},
        prep       => delete($options{prep}) // sub ($ar) { $ar->set_format_pax_restricted },
      }, $class;

      Carp::croak("Illegal options: @{[ sort keys %options ]}")
        if %options;

      return $self;
  }


  sub filename   ($self) { return $self->{filename}       }
  sub from       ($self) { return $self->{from}           }

  sub _archive ($self) {
    my $w = Archive::Libarchive::ArchiveWrite->new;
    my $e = Archive::Libarchive::Entry->new;

    $self->{prep}->($w);

    my $ret;

    if($self->filename) {
      $ret = $w->open_filename($self->filename);
    } else {
      $ret = $w->open_memory($self->{memory});
    }

    if($ret == ARCHIVE_WARN) {
      Carp::carp($w->error_string);
    } elsif($ret < ARCHIVE_WARN) {
      Carp::croak($w->error_string);
    }

    return($w,$e);
  }

  sub _iterate ($self, $w, $e, $path) {

    if(-d $path) {
      foreach my $child (sort { $a->basename cmp $b->basename } $path->children) {
        $self->_iterate($w, $e, $child);
      }
    } elsif(-f $path) {
      $e->clear;
      $e->set_pathname("$path");
      $e->set_filetype('reg');
      my $stat = FFI::C::Stat->new("$path");
      $e->copy_stat($stat);

      if($self->{entry}->($e)) {
        my $ret = $w->write_header($e);

        if($ret == ARCHIVE_WARN) {
          Carp::carp($w->error_string);
        } elsif($ret < ARCHIVE_WARN) {
          Carp::croak($w->error_string);
        }

        $ret = $w->write_data(\$path->slurp_raw);

        if($ret == ARCHIVE_WARN) {
          Carp::carp($w->error_string);
        } elsif($ret < ARCHIVE_WARN) {
          Carp::croak($w->error_string);
        }
      }
    }
  }


  sub compress ($self, %options) {
    Carp::croak("Already compressed") if defined $self->from;

    my $from = Path::Tiny->new($options{from} // $CWD);

    my($w, $e) = $self->_archive;

    local $CWD = $from;

    $self->_iterate($w, $e, Path::Tiny->new("."));

    $w->close;

  }
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Archive::Libarchive::Compress - Recursively archive a directory (using libarchive)

=head1 VERSION

version 0.01

=head1 SYNOPSIS

 use Archive::Libarchive::Compress;

 my $w = Archive::Libarchive::Compress->new( filename => 'foo.tar' );
 $w->compress( from => '.' );