view release on metacpan or  search on metacpan

lib/Archive/Par.pm  view on Meta::CPAN

  ! $self->file_ok($fn)

=item ARGUMENTS

=over 4

=item fn

=back

=item RETURNS

Whether the file may be regenerated somehow

=back

=cut

sub file_recoverable {
  my $self = shift;
  my ($fn) = @_;

  return $self->file_moved($fn) || $self->file_restorable($fn);
}

# -------------------------------------

=head2 recoverable

=over 4

=item PRECONDITIONS

  $self->checked

  ! $self->ok

=item ARGUMENTS

I<None>

=item RETURNS

=over 4

=item recoverable

true if the files can be recovered, false if not

=back

=back

=cut

sub recoverable {
  my $self = shift;

  croak sprintf("PRECONDITION on %s:%s: failed; not checked\n",
                (caller(0))[0,3])
    unless $self->checked;
  croak sprintf("PRECONDITION on %s:%s: failed; par ok\n",
                (caller(0))[0,3])
    if $self->ok;

  grep(! ($self->file_ok($_) || $self->file_recoverable($_)),
       $self->status_keys) == 0
}

# -------------------------------------

=head2 dump_file_status

Convenience method for returning status of files in par.

=cut

sub dump_file_status {
  my $self = shift;

  for my $fn ($self->status_keys) {
    my $status = $self->status($fn);
    my @flags;
    for my $flag (sort grep(substr($_, 0, 5) eq 'FILE_',
                            keys %{*Archive::Par::})) {
      no strict 'refs';
      my $val = &$flag();
      push @flags, substr($flag, 5)
        if $status & $val;
    }
    printf STDERR "FILE:%-20s: (S%2d); %s\n", $fn, $status, join ' ', @flags;
    if ( $self->_file_name_exists($fn) ) {
      printf STDERR "  (found as %s)\n", $self->_file_name($fn);
    }
  }
}

# -------------------------------------

=head2 checked

=over 4

=item ARGUMENTS

I<None>

=item RETURNS

=over 4

=item checked

Whether the status flags for this instance are meaningful.

=back

=back

=cut

sub checked { $_[0]->_checked }

lib/Archive/Par.pm  view on Meta::CPAN

sub check {
  my $self = shift; my $class = ref $self;

  my $out;
  # OK, there is (possibly) some arguments.  A filename forces that file to be
  # used for the unrar command. A filehandle argument reads from that
  # filehandle to parse, rather than invoking unrar.  If the filehandle isn't
  # a ref, it's treated purely as a text string.  This is for testing.

  my ($fn, $fh) = @_;
  if ( defined $fh ) {
    if ( ref $fh ) {
      local $/ = undef;
      $out = <$fh>;
    } else {
      $out = $fh;
    }
  } else {
    $fn = $self->fn
      unless defined $fn;
    run([par => 'check', $fn], '&>', \$out);
  }

  my ($status, $file_name) = $class->_parse_par_output($out, $fn);
  $self->status_clear;
  $self->_file_name_clear;
  $self->status($status);
  $self->_file_name($file_name);
  $self->_checked(1);
}

# -------------------------------------

=head2 restore

=over 4

=item PRECONDITIONS

  $self->recoverable

=item ARGUMENTS

=over 4

=item remove_old_files

I<Optional> If true, remove (corrupt) old files created by the restore.

=back

=back

=cut

sub restore {
  my $self = shift; my $class = ref $self;
  my ($remove_old_files) = @_;

  croak sprintf("PRECONDITION on %s:%s: failed; not recoverable\n",
                (caller(0))[0,3])
    unless $self->recoverable;

  my $fn = $self->fn;
  my $out;
  run([qw( par -m -f restore), $fn], '&>', \$out);

  my ($status, $file_name, $old_files) = $class->_parse_par_output($out, $fn);
  $self->status_clear;
  $self->_file_name_clear;
  $self->status($status);
  $self->_file_name($file_name);
  if ( $remove_old_files ) {
    for  ( @$old_files ) {
      my $target = catfile(dirname($self->fn), $_);
      unlink $target
        or croak "Failed to remove corrupt old file: $target: $!\n";
    }
  }
  $self->_checked(1);
}

# ----------------------------------------------------------------------------

=head1 EXAMPLES

Z<>

=head1 BUGS

Z<>

=head1 REPORTING BUGS

Email the author.

=head1 AUTHOR

Martyn J. Pearce C<fluffy@cpan.org>

=head1 COPYRIGHT

Copyright (c) 2002 Martyn J. Pearce.  This program is free software; you can
redistribute it and/or modify it under the same terms as Perl itself.

=head1 SEE ALSO

Z<>

=cut

1; # keep require happy.

__END__