view release on metacpan or  search on metacpan

lib/File/KDBX/Loader/XML.pm  view on Meta::CPAN

    } : ref $args eq 'ARRAY' ? sub {
        my ($key, $val) = @_;
        push @$args, $val;
    } : sub {};

    my $pattern = XML::LibXML::Pattern->new("${path}|${path}/*");
    while ($reader->nextPatternMatch($pattern) == 1) {
        last if $reader->nodePath eq $path && $reader->nodeType == XML_READER_TYPE_END_ELEMENT;
        next if $reader->nodeType != XML_READER_TYPE_ELEMENT;

        my $name = $reader->localName;
        my $key  = snakify($name);
        my $type = $spec{$name};
        ($key, $type) = @$type if ref $type eq 'ARRAY';

        if (!defined $type) {
            exists $spec{$name} or alert "Ignoring unknown element: $name",
                node => $reader->nodePath,
                line => $reader->lineNumber;
            next;
        }

        if (ref $type eq 'CODE') {
            my @result = $self->$type($args, $reader->nodePath);
            if (@result == 2) {
                $store->(@result);
            }
            elsif (@result == 1) {
                $store->($key, @result);
            }
        }
        else {
            $store->($key, $self->_read_xml_content($type));
        }
    }

    return $args;
}

sub _read_xml_attribute {
    my $self = shift;
    my $name = shift;
    my $type = shift // 'text';
    my $default = shift;
    my $reader = $self->_reader;

    return $default if !$reader->hasAttributes;

    my $value = trim($reader->getAttribute($name));
    if (!defined $value) {
        # try again after reading in all the attributes
        $reader->moveToFirstAttribute;
        while ($self->_reader->readAttributeValue == 1) {}
        $reader->moveToElement;

        $value = trim($reader->getAttribute($name));
    }

    return $default if !defined $value;

    my $decoded = eval { _decode_primitive($value, $type) };
    if (my $err = $@) {
        ref $err and $err->details(attribute => $name, node => $reader->nodePath, line => $reader->lineNumber);
        throw $err
    }

    return $decoded;
}

sub _read_xml_content {
    my $self = shift;
    my $type = shift;
    my $reader = $self->_reader;

    $reader->read if !$reader->isEmptyElement;  # step into element
    return '' if !$reader->hasValue;

    my $content = trim($reader->value);

    my $decoded = eval { _decode_primitive($content, $type) };
    if (my $err = $@) {
        ref $err and $err->details(node => $reader->nodePath, line => $reader->lineNumber);
        throw $err;
    }

    return $decoded;
}

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

sub _decode_primitive { goto &{__PACKAGE__."::_decode_$_[1]"} }

sub _decode_binary {
    local $_ = shift;
    return '' if !defined || (ref && !defined $$_);
    $_ = eval { decode_b64(ref $_ ? $$_ : $_) };
    my $err = $@;
    my $cleanup = erase_scoped $_;
    $err and throw 'Failed to parse binary', error => $err;
    return $_;
}

sub _decode_bool {
    local $_ = shift;
    return true  if /^True$/i;
    return false if /^False$/i;
    return false if length($_) == 0;
    throw 'Expected boolean', text => $_;
}

sub _decode_datetime {
    local $_ = shift;

    if (/^[A-Za-z0-9\+\/\=]+$/) {
        my $binary = eval { decode_b64($_) };
        if (my $err = $@) {
            throw 'Failed to parse binary datetime', text => $_, error => $err;
        }
        throw $@ if $@;
        $binary .= \0 x (8 - length($binary)) if length($binary) < 8;
        my ($seconds_since_ad1) = unpack_Ql($binary);
        my $epoch = $seconds_since_ad1 - TIME_SECONDS_AD1_TO_UNIX_EPOCH;
        return gmtime($epoch);
    }

    my $dt = eval { Time::Piece->strptime($_, '%Y-%m-%dT%H:%M:%SZ') };
    if (my $err = $@) {
        throw 'Failed to parse datetime', text => $_, error => $err;
    }
    return $dt;
}

sub _decode_tristate {
    local $_ = shift;
    return undef if /^null$/i;
    my $tristate = eval { _decode_bool($_) };
    $@ and throw 'Expected tristate', text => $_, error => $@;
    return $tristate;
}

sub _decode_number {
    local $_ = shift;
    $_ = _decode_text($_);
    looks_like_number($_) or throw 'Expected number', text => $_;
    return $_+0;
}