File Coverage

blib/lib/Archive/BagIt.pm

Criterion	Covered	Total	%
statement	494	534	92.5
branch	156	204	76.4
condition	17	39	43.5
subroutine	63	70	90.0
pod	18	20	90.0
total	748	867	86.2

package Archive::BagIt;
use strict;
use warnings;
use open ':std', ':encoding(UTF-8)';
use Encode qw( decode );
use File::Spec ();
use Class::Load qw( load_class );
use Carp qw( carp croak confess);
use POSIX qw( strftime );
use Moo;
with "Archive::BagIt::Role::Portability";

our $VERSION = '0.101'; # VERSION

# ABSTRACT: The main module to handle bags.



around 'BUILDARGS' , sub {
    my $orig = shift;
    my $class = shift;
    if (@_ == 1 && !ref $_[0]) {
        return $class->$orig(bag_path=>$_[0]);
    } else {
        return $class->$orig(@_);
    }
};


sub BUILD {
    my ($self, $args) = @_;
    if (!defined $self->use_plugins()) {
        return $self->load_plugins(("Archive::BagIt::Plugin::Manifest::MD5", "Archive::BagIt::Plugin::Manifest::SHA512"));
    }
    return $self->load_plugins($self->use_plugins());
}

###############################################


has 'force_utf8' => (
    is        => 'rw',
    lazy      => 1,
    predicate => 'has_force_utf8',
);

###############################################


has 'bag_path' => (
    is => 'rw',
);

# if the user wants specific plugins!
has 'use_plugins' => (
    is       => 'rw',
    lazy     => 1,
);

###############################################

has 'bag_path_arr' => (
    is => 'ro',
    lazy => 1,
    builder => '_build_bag_path_arr',
);

###############################################


has 'metadata_path' => (
    is=> 'ro',
    lazy => 1,
    builder => '_build_metadata_path',
);

sub _build_metadata_path {
    my ($self) = @_;
    return $self->bag_path;
}

###############################################

has 'metadata_path_arr' => (
    is =>'ro',
    lazy => 1,
    builder => '_build_metadata_path_arr',
);


###############################################

has 'rel_metadata_path' => (
    is => 'ro',
    lazy => 1,
    builder => '_build_rel_metadata_path',
);

###############################################


has 'payload_path' => (
    is => 'ro',
    lazy => 1,
    builder => '_build_payload_path',
);

sub _build_payload_path {
    my ($self) = @_;
    return File::Spec->catdir($self->bag_path, "data");
}

###############################################

has 'payload_path_arr' => (
    is => 'ro',
    lazy => 1,
    builder => '_build_payload_path_arr',
);

###############################################

has 'rel_payload_path' => (
    is => 'ro',
    lazy => 1,
    builder => '_build_rel_payload_path',
);

###############################################


has 'checksum_algos' => (
    is => 'ro',
    lazy => 1,
    builder => '_build_checksum_algos',
);

###############################################


has 'bag_version' => (
    is       => 'ro',
    lazy     => 1,
    builder  => '_build_bag_version',
);

###############################################


has 'bag_encoding' => (
    is      => 'ro',
    lazy    => 1,
    builder => '_build_bag_encoding',
);

###############################################


has 'bag_info' => (
    is        => 'rw',
    lazy      => 1,
    builder   => '_build_bag_info',
    predicate => 'has_bag_info'
);

###############################################


has 'errors' => (
    is      => 'ro',
    lazy    => 1,
    builder => sub { my $self = shift; return [];},
);

###############################################



has 'warnings' => (
    is   => 'ro',
    lazy => 1,
    builder => sub { my $self = shift; return [];},
);

###############################################


has 'digest_callback' => (
    is      => 'ro',
    lazy    => 1,
    builder => sub {
        my $sub = sub {
            my ($digestobj, $filename) = @_;
            if (-f $filename) {
                open(my $fh, '<:raw', $filename) or confess("Cannot open '$filename', $!");
                binmode($fh);
                my $digest = $digestobj->get_hash_string($fh);
                close $fh or confess("could not close file '$filename', $!");
                return $digest;
            } else {
                croak "file $filename is not a real file!";
            }
        };
        return $sub;
    }
);

###############################################


sub get_baginfo_values_by_key {
    my ($self, $searchkey) = @_;
    my $info = $self->bag_info();
    my @values;
    if (defined $searchkey) {
        my $lc_flag = $self->is_baginfo_key_reserved( $searchkey );
        foreach my $entry (@{ $info }) {
            return unless defined $entry;
            my ($key, $value) = %{ $entry };
            if ( __case_aware_compare_for_baginfo( $key, $searchkey, $lc_flag) ) {
                push @values, $value;
            }
        }
    }
    return @values if (scalar(@values) > 0);
    return;
}

###############################################


sub is_baginfo_key_reserved_as_uniq {
    my ($self, $searchkey) = @_;
    # my $rx = qr{Bag-Count|Bag-Group-Identifier|Bag-Size|Bagging-Date|Payload-Oxum};
    return $searchkey =~ m/^(?:Bag(?:-(?:Group-Identifier|Count|Size)|ging-Date)|Payload-Oxum)$/i;
}

###############################################


sub is_baginfo_key_reserved {
    my ($self, $searchkey) = @_;
    # my $rx = qr/
    #     Bag-Count|
    #     Bag-Group-Identifier|
    #     Bag-Size|
    #     Bagging-Date|
    #     Contact-Email|
    #     Contact-Name|
    #     Contact-Phone|
    #     External-Description|
    #     External-Identifier|
    #     Internal-Sender-Description|
    #     Internal-Sender-Identifier|
    #     Organisation-Adress|
    #     Payload-Oxum|
    #     Source-Organization
    #     /;
    return $searchkey =~ m/^(?:Bag(?:-(?:Group-Identifier|Count|Size)|ging-Date)|Internal-Sender-(?:Description|Identifier)|External-(?:Description|Identifier)|Contact-(?:(?:Phon|Nam)e|Email)|Source-Organization|Organisation-Adress|Payload-Oxum)$/ix;
}

###############################################

sub __case_aware_compare_for_baginfo {
    my ($internal_key, $search_key, $lc_flag) = @_;
    return (defined $internal_key) && (
        ( $lc_flag && ((lc $internal_key) eq (lc $search_key)) ) # for reserved keys use caseinsensitive search
            ||
            ( (!$lc_flag) && ($internal_key eq $search_key) ) # for other keys sensitive search
    )
}

###############################################

sub _find_baginfo_idx {
    my ($self, $searchkey) = @_;
    if (defined $searchkey) {
        if (-1 < index($searchkey, ":")) {croak "key should not contain a colon! (searchkey='$searchkey')";}
        my $info = $self->bag_info();
        my $size = scalar(@{$info});
        my $lc_flag = $self->is_baginfo_key_reserved($searchkey);
        foreach my $idx (reverse 0.. $size-1) { # for multiple entries return the latest addition
            my %entry = %{$info->[$idx]};
            my ($key, $value) = %entry;
            if (__case_aware_compare_for_baginfo($key, $searchkey, $lc_flag)) {
                return $idx;
            }
        }
    }
    return;
}

###############################################

sub _collect_errors {
    my ($self, $res) = @_;
    push @{$self->{errors}}, $res;
    return;
}

###############################################

sub _if_error_push {
    my ($self, $res) = @_;
    if ($res ne "") {
        return $self->_collect_errors($res);
    }
    return 1;
}

###############################################

sub _check_baginfo_keys_generically {
    my ($self, $info) = @_;
    my %keys;
    my $ret=1;
    foreach my $entry (@{$info}) {
        my ($key, $value) = %{$entry};
        my $res = _check_key($key); # check key
        $ret &&= $self->_if_error_push($res);
        $res = _check_value($value); # check value
        $ret &&= $self->_if_error_push($res);
        # code to prepare check of uniqueness
        if ($self->is_baginfo_key_reserved($key)) {
            $keys{ lc $key }++;
        } else {
            $keys{ $key }++
        }
    }
    # check for uniqueness
    foreach my $key (keys %keys) {
        if (
            ($self->is_baginfo_key_reserved_as_uniq($key))
                and ($keys{$key} > 1)
        ) {
            $ret &&=$self->_collect_errors("Baginfo key '$key' exists $keys{$key}, but should be uniq!");
        }
    }
    return $ret;
}

###############################################

sub _verify_baginfo {
    my ($self, $info) = @_;
    my $ret = 1;

    if (!defined $info) {
        if (exists $self->{bag_info_file}) {
            $ret &&= $self->_collect_errors("'bag-info.txt' exists, but is not (partially) parseable!");
        }
    } else {
        $ret &&= $self->_check_baginfo_keys_generically($info);
        # check for payload oxum
        my ($loaded_payloadoxum) = $self->get_baginfo_values_by_key('Payload-Oxum');
        if (!defined $loaded_payloadoxum) {
            push @{$self->{warnings}}, "Payload-Oxum was expected in bag-info.txt, but not found!"; # payload-oxum is recommended, but optional
        } else {
            my ($octets, $streamcount) = $self->calc_payload_oxum();
            if ("$octets.$streamcount" ne $loaded_payloadoxum) {
                $ret &&= $self->_collect_errors( "Payload-Oxum differs, calculated $octets.$streamcount but $loaded_payloadoxum was expected by bag-info.txt");
            }
        }
    }
    return $ret;
}

###############################################

sub verify_baginfo {
    my ($self) = @_;
    my $info = $self->bag_info();
    if (List::Util::any { /the baginfo file .* could not be parsed correctly/ } @{$self->{'errors'}}) {
        return;
    }
    return $self->_verify_baginfo($info);
}

###############################################


sub delete_baginfo_by_key {
    my ($self, $searchkey) = @_;
    my $idx = $self->_find_baginfo_idx($searchkey);
    if (defined $idx) {
        splice @{$self->{bag_info}}, $idx, 1; # delete nth indexed entry
    }
    return 1;
}

###############################################


sub exists_baginfo_key {
    my ($self, $searchkey) =@_;
    return (defined  $self->_find_baginfo_idx($searchkey));
}

###############################################

sub _replace_baginfo_by_first_match {
    my ($self, $searchkey, $newvalue) = @_;
    my $idx = $self->_find_baginfo_idx( $searchkey);
    if (defined $idx) {
        $self->{bag_info}[$idx] = {$searchkey => $newvalue};
        return $idx;
    }
    return;
}

###############################################

sub _check_key {
    my ($key) = @_;
    if (!defined $key) {
        return "key should match '[^\\r\\n:]+', but is not defined";
    }
    if ($key =~ m/[\r\n]/s) {
        return "key should match '[^\\r\\n:]+', but contains newlines (key='$key')";
    }
    if ($key =~ m/:/) {
        return "key should not contain a colon! (key='$key')";
    }
    if ($key =~ m/^$/) {
        return "key should have a length > null (key='')";
    }
    return "";
}

###############################################

sub _check_key_or_croak {
    my ($key) = @_;
    my $res = _check_key($key);
    if ($res eq "") { return 1;}
    croak $res;
}

###############################################

sub _check_value {
    my ($value) = @_;
    if (!defined $value) { return "value should match '[^\\r\\n:]+', but is not defined"; }
    if ($value =~ m/^$/s) { return "value should have a length > null (value='')"; }
    return "";
}

###############################################

sub _check_value_or_croak {
    my ($value) = @_;
    my $res = _check_value($value);
    if ($res eq "") { return 1;}
    croak $res;
}

###############################################

sub append_baginfo_by_key {
    my ($self, $searchkey, $newvalue) = @_;
    if (
        _check_key_or_croak($searchkey)
            and  (defined $newvalue)
    ) {
        if (-1 < index($searchkey, ":")) {croak "key should not contain a colon! (searchkey='$searchkey')";}
        if ($self->is_baginfo_key_reserved_as_uniq($searchkey)) {
            if (defined $self->get_baginfo_values_by_key($searchkey)) {
                # hmm, search key is marked as uniq and still exists
                return;
            }
        }
        push @{$self->{bag_info}}, { $searchkey => $newvalue };
    }
    return 1;
}

###############################################


sub add_or_replace_baginfo_by_key {
    my ($self, $searchkey, $newvalue) = @_;
    if ( _check_key_or_croak($searchkey) ) {
        if (-1 < index($searchkey, ":")) { croak "key should not contain a colon! (searchkey='$searchkey')"; }
        if (defined $self->{bag_info}) {
            my $idx = $self->_replace_baginfo_by_first_match( $searchkey, $newvalue);
            if (defined $idx) { return $idx;}
        }
        $self->append_baginfo_by_key( $searchkey, $newvalue );
        return -1;
    }
}

###############################################


has 'forced_fixity_algorithm' => (
    is        => 'ro',
    lazy      => 1,
    builder   => '_build_forced_fixity_algorithm',
);

sub has_forced_fixity_algorithm {
    my $self = shift;
    return (defined $self->forced_fixity_algorithm() );
} # false if use_plugins used

###############################################


has 'manifest_files' => (
    is => 'ro',
    lazy => 1,
    builder => '_build_manifest_files',
);

###############################################


has 'tagmanifest_files' => (
    is => 'ro',
    lazy => 1,
    builder => '_build_tagmanifest_files',
);

###############################################


has 'payload_files' => ( # relatively to bagit base
    is => 'ro',
    lazy => 1,
    builder => '_build_payload_files',
);

###############################################


has 'non_payload_files' => (
    is=>'ro',
    lazy => 1,
    builder => '_build_non_payload_files',
);

###############################################


has 'plugins' => (
    is=>'rw',
    #isa=>'HashRef',
);

###############################################



has 'manifests' => (
    is      => 'rw',
    lazy    => 1,
    builder => '_build_manifests'
    #isa=>'HashRef',
);

###############################################



has 'algos' => (
    is=>'rw',
    #isa=>'HashRef',
);

###############################################

sub _build_bag_path_arr {
    my ($self) = @_;
    my @split_path = File::Spec->splitdir($self->bag_path);
    return @split_path;
}

sub _build_payload_path_arr {
    my ($self) = @_;
    my @split_path = File::Spec->splitdir($self->payload_path);
    return @split_path;
}

sub _build_rel_payload_path {
    my ($self) = @_;
    my $rel_path = File::Spec->abs2rel( $self->payload_path, $self->bag_path ) ;
    return $rel_path;
}

sub _build_metadata_path_arr {
    my ($self) = @_;
    my @split_path = File::Spec->splitdir($self->metadata_path);
    return @split_path;
}

sub _build_rel_metadata_path {
    my ($self) = @_;
    my $rel_path = File::Spec->abs2rel( $self->metadata_path, $self->bag_path ) ;
    return $rel_path;
}

sub _build_checksum_algos {
    my($self) = @_;
    my @checksums = keys %{ $self->manifests() };
    return \@checksums;
}

sub _build_manifest_files {
    my($self) = @_;
    my @manifest_files;
    foreach my $algo (@{$self->checksum_algos}) {
        my $manifest_file = File::Spec->catfile($self->metadata_path, "manifest-$algo.txt");
        if (-f $manifest_file) {
            push @manifest_files, $manifest_file;
        }
    }
    return \@manifest_files;
}

sub _build_tagmanifest_files {
    my ($self) = @_;
    my @tagmanifest_files;
    foreach my $algo (@{$self->checksum_algos}) {
        my $tagmanifest_file = File::Spec->catfile($self->metadata_path,"tagmanifest-$algo.txt");
        if (-f $tagmanifest_file) {
            push @tagmanifest_files, $tagmanifest_file;
        }
    }
    return \@tagmanifest_files;
}

sub __handle_nonportable_local_entry {
    my $self = shift;
    my $local_entry = shift;
    my $dir = shift;
    if ($local_entry !~ m/^[a-zA-Z0-9._-]+$/) {
        my $local_entry_utf8 = decode("UTF-8", $local_entry);
        if ((!$self->has_force_utf8)) {
            my $hexdump = "0x" . unpack('H*', $local_entry);
            $local_entry =~m/[^a-zA-Z0-9._-]/; # to find PREMATCH, needed nextline
            ## no critic (Variables::ProhibitMatchVars)
            # the slowdown using prematch is accepatable, because only triggered in failure path
            my $prematch_position = $`;
            carp "possible non portable pathname detected in $dir,\n",
                "got path (hexdump)='$hexdump'(hex),\n",
                "decoded path='$local_entry_utf8'\n",
                "              "." "x length($prematch_position)."^"."------- first non portable char\n";
        }
        $local_entry = $local_entry_utf8;
    }
    return $local_entry;
}


# own implementation, because File::Find has problems with UTF8 encoded Paths under MSWin32
# finds recursively all files in given directory.
# if $excludedir is defined, the content will be excluded
sub __file_find { ## no critic (CognitiveComplexity::ProhibitExcessCognitiveComplexity)
    my ($self,$dir, $excludedir) = @_;
    if (defined $excludedir) {
        $excludedir = File::Spec->rel2abs( $excludedir);
    }
    my @file_paths;
    my $finder;
    $finder = sub {
        my ($current_dir) = @_; #absolute path
        my @todo;
        my @tmp_file_paths;
        opendir( my $dh, $current_dir);
        my @paths = File::Spec->no_upwards ( readdir $dh );
        closedir $dh;
        foreach my $local_entry (@paths) {
            my $path_entry = File::Spec->catdir($current_dir, $self->__handle_nonportable_local_entry($local_entry, $dir));
            if ((defined $excludedir) && ($path_entry eq $excludedir)) {
                # ignore it, because excluded
            } elsif (-f $path_entry) {
                push @tmp_file_paths, $path_entry;
            } elsif (-d $path_entry) {
                push @todo, $path_entry;
            } else {
                croak "not a file nor a dir found '$path_entry'";
            }
        }
        push @file_paths, sort @tmp_file_paths;
        foreach my $subdir (sort @todo) {
            &$finder($subdir);
        }
    };
    my $absolute = File::Spec->rel2abs( $dir );
    &$finder($absolute);
    @file_paths = map { File::Spec->abs2rel( $_, $dir)} @file_paths;
    return @file_paths;
}

sub _build_payload_files{
    my ($self) = @_;
    my $payload_dir = $self->payload_path;
    my $reldir = File::Spec->abs2rel($payload_dir, $self->bag_path());
    $reldir =~ s/^\.$//;
    my @payload = map {
        $reldir eq "" ? $_ : File::Spec->catfile($reldir, $_)
    } $self->__file_find($payload_dir, File::Spec->rel2abs($self->metadata_path));
    return wantarray ? @payload : \@payload;
}


sub __build_read_bagit_txt {
    my($self) = @_;
    my $bagit = $self->metadata_path;
    my $file = File::Spec->catfile($bagit, "bagit.txt");
    open(my $BAGIT, "<:encoding(UTF-8)", $file) or croak("Cannot read '$file': $!");
    my $version_string = <$BAGIT>;
    my $encoding_string = <$BAGIT>;
    close($BAGIT);
    if (defined $version_string) {
        $version_string =~ s/[\r\n]//;
    }
    if (defined $encoding_string) {
        $encoding_string =~s/[\r\n]//;
    }
    return ($version_string, $encoding_string, $file);
}

sub _build_bag_version {
    my($self) = @_;
    my ($version_string, $encoding_string, $file) = $self->__build_read_bagit_txt();
    croak "Version line missed in '$file" unless defined $version_string;
    if ($version_string =~ /^BagIt-Version: ([01]\.[0-9]+)$/) {
        return $1;
    } else {
        $version_string =~ s/\r//;
        $version_string =~ s/^\N{U+FEFF}//;
        croak "Version string '$version_string' of '$file' is incorrect";
    };
}

sub _build_bag_encoding {
    my($self) = @_;
    my ($version_string, $encoding_string, $file) = $self->__build_read_bagit_txt();
    croak "Encoding line missed in '$file" unless defined $encoding_string;
    croak "Encoding '$encoding_string' of '$file' not supported by current Archive::BagIt module!" unless ($encoding_string ne "UTF-8");
    return $encoding_string;
}

sub __sort_bag_info {
    my @sorted = sort {
        my %tmpa = %{$a};
        my %tmpb = %{$b};
        my ($ka, $va) = each %tmpa;
        my ($kb, $vb) = each %tmpb;
        my $kres = $ka cmp $kb;
        if ($kres != 0) {
            return $kres;
        } else {
            return $va cmp $vb;
        }
    } @_;
    return @sorted;
}


sub _extract_key_from_textblob {
    my ($self, $textblob) = @_;
    if (!defined $textblob) {
        push @{$self->{errors}}, "the baginfo file '" . $self->{bag_info_file} . "' could not be parsed correctly, because textblob for key extraction is undefined";
        return (undef, undef);
    }
    my $key;
    my $rx_word = qr{[^: \t\r\n]+};# Hint: this word definition for bag-info.txt-keys differs from word definition of bag-info.txt-values!
    my $rx_spc = qr{\s}; #qr{[\t ]};
    if ($textblob =~ s/\A($rx_word)$rx_spc*:[\t ]*//m) {
        # label if starts with chars not colon or whitespace followed by zero or more spaces, a colon, zero or more spaces
        if ($textblob eq "") {
            push @{$self->{errors}}, "the baginfo file '" . $self->{bag_info_file} . "' could not be parsed correctly, because following text blob not fullfill the match requirements for values: '$textblob', empty value detected";
            return ($1, undef);
        }
        $key = $1;
    } else {
        push @{$self->{errors}}, "the baginfo file '".$self->{bag_info_file}."' could not be parsed correctly, because following text blob not fullfill the match requirements for keys: '$textblob'";
    }
    return ($key, $textblob);
}

sub _extract_value_from_textblob {
    my ($self, $textblob) = @_;
    if (!defined $textblob) {
        push @{$self->{errors}}, "the baginfo file '" . $self->{bag_info_file} . "' could not be parsed correctly, because textblob for value extraction is undefined";
        return (undef, undef);
    }
    if ($textblob eq "") {
        push @{$self->{errors}}, "the baginfo file '" . $self->{bag_info_file} . "' could not be parsed correctly, because textblob for value extraction is empty";
        return (undef, "");
    }
    my $value;
    # Ex1:
    # |bar
    # | baz   --> one value: bar\n  baz\n  tss
    # | tss
    # Ex2:
    # |bar    --> one value: bar
    # |baz
    # Ex3:
    # |bar:baz -> one value: bar:baz
    my $rx_word = qr{[^ \t\r\n]+}; # Hint: this word definition for bag-info.txt-values differs from word definition of bag-info.txt-keys!
    my $rx_spc = qr{[\t ]+};
    my $rx_word_spc_word = qr{($rx_word($rx_spc$rx_word)*)};
    if ($textblob =~ s/\A($rx_word_spc_word([\r\n]$rx_spc$rx_word_spc_word)+)[\r\n]*//ms) {
        $value = $1;
    } elsif ($textblob =~ s/\A($rx_word_spc_word)[\r\n]*//s) {
        $value = $1;
    } else {
        push @{$self->{errors}}, "the baginfo file '".$self->{bag_info_file}."' could not be parsed correctly, because following text blob not fullfill the match requirements for values: '$textblob'";
    }
    return ($value, $textblob);
}

# parses a bag-info textblob
sub _parse_bag_info { ## no critic (CognitiveComplexity::ProhibitExcessCognitiveComplexity)
    my ($self, $textblob) = @_;
    #    metadata elements are OPTIONAL and MAY be repeated.  Because "bag-
    #    info.txt" is intended for human reading and editing, ordering MAY be
    #    significant and the ordering of metadata elements MUST be preserved.
    #
    #    A metadata element MUST consist of a label, a colon ":", a single
    #    linear whitespace character (space or tab), and a value that is
    #    terminated with an LF, a CR, or a CRLF.
    #
    #    The label MUST NOT contain a colon (:), LF, or CR.  The label MAY
    #    contain linear whitespace characters but MUST NOT start or end with
    #    whitespace.
    #
    #    It is RECOMMENDED that lines not exceed 79 characters in length.
    #    Long values MAY be continued onto the next line by inserting a LF,
    #    CR, or CRLF, and then indenting the next line with one or more linear
    #    white space characters (spaces or tabs).  Except for linebreaks, such
    #    padding does not form part of the value.
    #
    #    Implementations wishing to support previous BagIt versions MUST
    #    accept multiple linear whitespace characters before and after the
    #    colon when the bag version is earlier than 1.0; such whitespace does
    #    not form part of the label or value.
    # find all labels
    my @labels;
    croak "_parse_baginfo() called with undef value!" unless (defined $textblob);
    while (1) {
        last if ($textblob eq "");
        my ($key, $value);
        ($key, $textblob) = $self->_extract_key_from_textblob($textblob);
        last unless (defined $key);
        last unless (defined $textblob );
        ($value, $textblob) = $self->_extract_value_from_textblob($textblob);
        last unless (defined $value);
        if (defined $key) {
            my $entry = { $key => $value };
            push @labels, $entry;
        }
    }
    # The RFC does not allow reordering:
    #my @sorted = __sort_bag_info(@labels);
    #return \@sorted;
    return \@labels;
}

sub _build_bag_info {
    my ($self) = @_;
    my $bagit = $self->metadata_path;
    my $file = File::Spec->catfile($bagit, "bag-info.txt");
    if (-e $file) {
        open(my $BAGINFO, "<:encoding(UTF-8)", $file) or croak("Cannot read $file: $!");
        my @lines;
        while ( my $line = <$BAGINFO>) {
            push @lines, $line;
        }
        close($BAGINFO);
        my $lines = join("", @lines);
        $self->{bag_info_file}=$file;
        return $self->_parse_bag_info($lines);
    }
    # bag-info.txt is optional
    return;
}

sub _build_non_payload_files {
    my ($self) = @_;
    my $non_payload_dir = $self->metadata_path();
    my $reldir = File::Spec->abs2rel($non_payload_dir, $self->bag_path());
    $reldir =~ s/^\.$//;
    my @non_payload = map {
        $reldir eq "" ? $_ : File::Spec->catfile($reldir, $_)
    } $self->__file_find($non_payload_dir, File::Spec->rel2abs($self->payload_path));
    return wantarray ? @non_payload : \@non_payload;
}

sub _build_forced_fixity_algorithm {
    my ($self) = @_;
    if ($self->use_plugins()) {
        return;
    } else {
        if ($self->bag_version() >= 1.0) {
            return Archive::BagIt::Plugin::Algorithm::SHA512->new(bagit => $self);
        }
        else {
            return Archive::BagIt::Plugin::Algorithm::MD5->new(bagit => $self);
        }
    }
}

###############################################


sub load_plugins {
    my ($self, @plugins) = @_;
    my $loaded_plugins = $self->plugins;
    if (defined $loaded_plugins) {
        @plugins = grep {not exists $loaded_plugins->{$_}} @plugins;
    }
    return if @plugins == 0;
    if (exists $ENV{TEST_ACTIVE}) {
        use Cwd;
        my $dir = getcwd();
        my @dirs = File::Spec->splitdir($dir);
        if ($dirs[-1] eq 't') {
            push @INC, "../lib";
        }
    }
    foreach my $plugin (@plugins) {
        load_class ($plugin) or croak ("Can't load $plugin");
        $plugin->new({bagit => $self});
    }

    return 1;
}

###############################################


sub load {
    my ($self) = @_;
    # call trigger
    $self->bag_path;
    $self->bag_version;
    $self->bag_encoding;
    $self->bag_info;
    $self->payload_path;
    $self->manifest_files;
    $self->checksum_algos;
    $self->tagmanifest_files;
    return 1;
}

###############################################


sub verify_bag {
    my ($self,$opts) = @_;
    #removed the ability to pass in a bag in the parameters, but might want options
    #like $return all errors rather than dying on first one
    my $bagit = $self->bag_path;
    my $version = $self->bag_version(); # to call trigger
    my $encoding = $self->bag_encoding(); # to call trigger
    my $baginfo = $self->verify_baginfo(); #to call trigger

    my $fetch_file = File::Spec->catfile($self->metadata_path, "fetch.txt");
    my $payload_dir   = $self->payload_path;
    my $return_all_errors = $opts->{return_all_errors};

    if (-f $fetch_file) {
        croak("Fetching via file '$fetch_file' is not supported by current Archive::BagIt implementation")
    }
    # check forced fixity
    if ($self->has_forced_fixity_algorithm()) {
        my $forced_fixity_alg = $self->forced_fixity_algorithm()->name();
        my $manifest_file = File::Spec->catfile($self->metadata_path, "manifest-$forced_fixity_alg.txt");
        croak("Manifest '$manifest_file' is not a regular file or does not exist for given bagit version '$version'") unless -f ($manifest_file);
    }
    croak("Payload-directory '$payload_dir' is not a directory or does not exist") unless -d ($payload_dir);

    unless ($version > .95) {
        croak ("Bag Version $version is unsupported");
    }

    my @errors;


    # check for manifests
    foreach my $algorithm ( keys %{ $self->manifests }) {
        my $res = $self->manifests->{$algorithm}->verify_manifest($self->payload_files, $return_all_errors);
        if ((defined $res) && ($res ne "1")) { push @errors, $res; }
    }
    #check for tagmanifests
    foreach my $algorithm ( keys %{ $self->manifests }) {
        my $res = $self->manifests->{$algorithm}->verify_tagmanifest($self->non_payload_files, $return_all_errors);
        if ((defined $res) && ($res ne "1")) { push @errors, $res; }
    }
    push @{$self->{errors}}, @errors;
    my $err = $self->errors();
    my @err =  @{ $err };
    if (scalar( @err ) > 0) {
        croak join("\n","bag verify for bagit version '$version' failed with invalid files.", @err);
    }
    return 1;
}


sub calc_payload_oxum {
    my($self) = @_;
    my @payload = @{$self->payload_files};
    my $octets=0;
    my $streamcount = scalar @payload;
    foreach my $local_name (@payload) {# local_name is relative to bagit base
        my $file = File::Spec->catfile($self->bag_path(), $local_name);
        if (-e $file) {
            my $filesize = 0;
            $filesize = -s $file or carp "empty file $file detected";
            $octets += $filesize;
        } else { croak "file $file does not exist, $!"; }
    }
    return ($octets, $streamcount);
}


sub calc_bagsize {
    my($self) = @_;
    my ($octets,$streamcount) = $self->calc_payload_oxum();
    if ($octets < 1024) { return "$octets B"; }
    elsif ($octets < 1024*1024) {return sprintf("%0.1f kB", $octets/1024); }
    elsif ($octets < 1024*1024*1024) {return sprintf "%0.1f MB", $octets/(1024*1024); }
    elsif ($octets < 1024*1024*1024*1024) {return sprintf "%0.1f GB", $octets/(1024*1024*1024); }
    else { return sprintf "%0.2f TB", $octets/(1024*1024*1024*1024); }
}


sub create_bagit {
    my($self) = @_;
    my $metadata_path = $self->metadata_path();
    my $bagit_path = File::Spec->catfile( $metadata_path, "bagit.txt");
    open(my $BAGIT, ">:encoding(UTF-8)", $bagit_path) or croak("Can't open $bagit_path for writing: $!");
    print($BAGIT "BagIt-Version: 1.0\nTag-File-Character-Encoding: UTF-8");
    close($BAGIT);
    return 1;
}


sub create_baginfo {
    my($self) = @_; # because bag-info.txt allows multiple key-value-entries, hash is replaced
    $self->add_or_replace_baginfo_by_key('Bagging-Date', POSIX::strftime("%Y-%m-%d", gmtime(time)));
    $self->add_or_replace_baginfo_by_key('Bag-Software-Agent', 'Archive::BagIt ');
    my ($octets, $streams) = $self->calc_payload_oxum();
    $self->add_or_replace_baginfo_by_key('Payload-Oxum', "$octets.$streams");
    $self->add_or_replace_baginfo_by_key('Bag-Size', $self->calc_bagsize());
    # The RFC does not allow reordering:
    my $metadata_path = $self->metadata_path();
    my $bag_info_path = File::Spec->catfile( $metadata_path, "bag-info.txt");
    if (
            (exists $self->{errors})
            and ((scalar @{$self->{errors}}) > 0)
    ) {
        croak "Could not create baginfo, because current file $bag_info_path has parsing errors!";
    }
    open(my $BAGINFO, ">:encoding(UTF-8)", $bag_info_path) or croak("Can't open $bag_info_path for writing: $!");
    foreach my $entry (@{ $self->bag_info() }) {
        my %tmp = %{ $entry };
        my ($key, $value) = %tmp;
        _check_key_or_croak($key);
        _check_value_or_croak($value);
        if (-1 < index($key,":")) { carp "key should not contain a colon! (searchkey='$key')"; }
        print($BAGINFO "$key: $value\n");
    }
    close($BAGINFO);
    return 1;
}


sub store {
    my($self) = @_;
    # it is important to create all manifest files first, because tagmanifest should include all manifest-xxx.txt
    foreach my $algorithm ( keys %{ $self->manifests }) {
        $self->manifests->{$algorithm}->create_manifest();
    }
    $self->create_bagit();
    $self->create_baginfo();
    foreach my $algorithm ( keys %{ $self->manifests }) {
        $self->manifests->{$algorithm}->create_tagmanifest();
    }
    # retrigger builds
    $self->{checksum_algos} = $self->_build_checksum_algos();
    $self->{tagmanifest_files} = $self->_build_tagmanifest_files();
    $self->{manifest_files} = $self->_build_manifest_files();
    return 1;
}


sub init_metadata {
    my ($class, $bag_path, $options) = @_;
    $bag_path =~ s#/$##; # replace trailing slash
    unless ( -d $bag_path) { croak ( "source bag directory '$bag_path' doesn't exist"); }
    my $self = $class->new(bag_path=>$bag_path, %$options);
    carp "no payload path" if ! -d $self->payload_path;
    unless ( -d $self->payload_path) {
        rename ($bag_path, $bag_path.".tmp");
        mkdir  ($bag_path);
        rename ($bag_path.".tmp", $self->payload_path);
    }
    unless ( -d $self->metadata_path) {
        #metadata path is not the root path for some reason
        mkdir ($self->metadata_path);
    }
    $self->store();
    return $self;
}


sub make_bag {
    my ($class, $bag_path, $options) = @_;
    my $isa = ref $class;
    if ($isa eq "Archive::BagIt") { # not a class, but an object!
        croak "make_bag() only a class subroutine, not useable with objects. Try store() instead!\n";
    }
    my $self = $class->init_metadata($bag_path, $options);
    return $self;
}





__PACKAGE__->meta->make_immutable;

1;

__END__