view release on metacpan or  search on metacpan

lib/DBD/PO/db.pm  view on Meta::CPAN

            or next HEADER_KEY;
        if ($key eq 'extended') {
            @data % 2
               and croak "$key pairs are not pairwise";
            while (my ($name, $value) = splice @data, 0, 2) {
                push @header, sprintf $format, $name, $value;
            }
        }
        else {
            my $row = sprintf $format, map {defined $_ ? $_ : q{}} @data;
            $row =~ s{\s* <> \z}{}xms; # delete an empty mail address
            push @header, $row;
        }
    }

    return join "\n", @header;
}

sub get_header_msgstr { ## no critic (ArgUnpacking)
    my ($dbh, $hash_ref) = validate_pos(
        @_,
        {isa   => 'DBI::db'},
        {type  => HASHREF},
    );

    my $sth = $dbh->prepare(<<"EOT") or croak $dbh->errstr();
        SELECT msgstr
        FROM $hash_ref->{table}
        WHERE msgid = ''
EOT
    $sth->execute()
        or croak $sth->errstr();
    my ($msgstr) = $sth->fetchrow_array()
        or croak $sth->errstr();
    $sth->finish()
        or croak $sth->errstr();

    return $msgstr;
}

sub split_header_msgstr { ## no critic (ArgUnpacking)
    my ($dbh, $anything) = validate_pos(
        @_,
        {isa   => 'DBI::db'},
        {type  => SCALAR | HASHREF},
    );

    my $msgstr = (ref $anything eq 'HASH')
                 ? $dbh->func($anything, 'get_header_msgstr')
                 : $anything;

    my $po = DBD::PO::Locale::PO->new(
        eol => defined $dbh->FETCH('eol')
               ? $dbh->FETCH('eol')
               : $EOL_DEFAULT,
    );
    my $separator = defined $dbh->FETCH('separator')
                    ? $dbh->FETCH('separator')
                    : $SEPARATOR_DEFAULT;
    my @cols;
    my @lines = split m{\Q$separator\E}xms, $msgstr;
    LINE:
    while (1) {
        my $line = shift @lines;
        defined $line
           or last LINE;
        # run the regex for the selected column
        my $index = 0;
        HEADER_REGEX:
        for my $header_regex (@HEADER_REGEX) {
            if (! $header_regex) {
                ++$index;
                next HEADER_REGEX;
            }
            my @result;
            # more regexes are necessary
            if (ref $header_regex eq 'ARRAY') {
                # run from special to more common regex
                INNER_REGEX:
                for my $inner_regex ( @{$header_regex} ) {
                    @result = $line =~ $inner_regex;
                    last INNER_REGEX if @result;
                }
            }
            # only 1 regex is necessary
            else {
                @result = $line =~ $header_regex;
            }
            # save the result to the selected column
            if (@result) {
                # some columns are multiline
                defined $cols[$index]
                ? (
                    ref $cols[$index] eq 'ARRAY'
                    ? push @{ $cols[$index] }, @result
                    : do {
                        $cols[$index] = [ $cols[$index], @result ];
                    }
                )
                : (
                    $cols[$index] = @result > 1
                                    ? \@result
                                    : $result[0]
                );
                next LINE;
            }
            ++$index;
        }
    }

    return \@cols;
}

sub get_header_msgstr_data { ## no critic (ArgUnpacking)
    my ($dbh, $anything, $key) = validate_pos(
        @_,
        {isa  => 'DBI::db'},
        {type => ARRAYREF | SCALAR | HASHREF},
        {
            type      => SCALAR | ARRAYREF,
            callbacks => {