view release on metacpan or  search on metacpan

lib/CTK/Serializer.pm  view on Meta::CPAN

sub stash {
    my $self = shift;
    my %in = @_;
    undef $self->{document};
    $self->{document} = $in{document} // "";
    undef $self->{struct};
    $self->{struct} = $in{struct} // undef;
    $self->{status} = $in{status} || 0;
    $self->{error} = $in{error} // '';
    return 1;
}
sub _serialize { # Structure -> DUMP
    my $self = shift;
    my $struct = shift || {};
    return (
        document=> Dumper($struct),
        struct  => $struct,
        error   => "",
        status  => 1,
    );
}
sub _deserialize { # ??? -> Structure
    my $self = shift;
    my $doc = shift;
    my $attr = shift || {};

    my $frmt;
    my $frmts = $self->{formats};

    foreach my $k (@$frmts) {
        my $match = $self->lookup($k)->{match};
        next unless $match;
        if ($doc =~ $match) {
            $frmt = $k;
            last;
        }
    }
    if ($frmt) {
        $self->{format} = $frmt;
        $self->_set_attrs($frmt);
        my $class = $self->lookup($frmt)->{class};
        return $class->_deserialize($doc, $self->{deserialize_attr} || $attr);
    }
    my $out = CTK::Serializer::BLANK->(__PACKAGE__);
    $out->{document} = $doc;
    my $io = IO::String->new($doc);
    $out->{struct} = [(<$io>)];
    $out->{error} = ""; # Can't detect format of the document";
    $out->{status} = 1;
    $io->close;
    return %$out;
}

1;

package CTK::Serializer::JSON;
use strict;
use utf8;
use JSON;
#use JSON::XS;
use Try::Tiny;

sub _serialize { # Structure -> JSON
    my $self = shift;
    my $struct = shift || {};
    my $attr = shift || {};
    $attr->{utf8} = 0 unless defined $attr->{utf8};
    $attr->{pretty} = 1 unless defined $attr->{pretty};
 # my $coder = JSON::XS->new->pretty($attr->{pretty}); #->allow_blessed(0)->utf8;
 # $coder = $coder->allow_blessed($attr->{allow_blessed}) if $attr->{allow_blessed};
 # $coder = $coder->allow_nonref($attr->{allow_nonref}) if $attr->{allow_nonref};
 # $coder = $coder->utf8 if $attr->{utf8};
    my $doc = "";
    my $err = "";
    my $stt = 1;
    try {
        $doc = to_json($struct, $attr);
    } catch {
        $err = sprintf("Can't serialize JSON structure: %s", $_);
        $stt = 0;
    };
 #   my $doc = $coder->encode($struct);
    return (
        document=> $doc,
        struct  => $struct,
        error   => $err,
        status  => $stt,
    );
}
sub _deserialize { # JSON -> Structure
    my $self = shift;
    my $json = shift;
    my $attr = shift || {};
    my $out = CTK::Serializer::BLANK->(__PACKAGE__);
    $out->{document} = $json;
    return %$out unless $json;
    $attr->{utf8} = 0 unless defined $attr->{utf8};
    my $struct;
 # my $coder = JSON::XS->new;
 # $coder = $coder->allow_nonref($attr->{allow_nonref}) if $attr->{allow_nonref};
 # $coder = $coder->utf8 if $attr->{utf8};
 #chomp($json);
    try {
        my $in = from_json($json, $attr);
 #       my $in = $coder->decode($json);

        if ($in && ((ref($in) eq 'HASH') || ref($in) eq 'ARRAY')) {
            if (ref($in) eq 'ARRAY') {
                #$out->{struct} = shift(@$in) || {}; # Закоментировал т.к. иногда нужен массив!
                $out->{struct} = $in;
            } else { # HASH
                $out->{struct} = $in;
            }
            $out->{error} = "";
            $out->{status} = 1;
        } else {
            $out->{error} = "Bad JSON format";
        }
    } catch {
        $out->{error} = sprintf("Can't load JSON document: %s", $_);
    };
    return %$out;
}

1;

package CTK::Serializer::XML;
use strict;
use utf8;
use XML::Simple;
use Try::Tiny;

sub _serialize { # Structure -> XML
    my $self = shift;
    my $struct = shift || {};
    my $attr = shift || {};
    my $doc = "";
    my $err = "";
    my $stt = 1;
    try {
        $doc = XMLout($struct, %$attr);
    } catch {
        $err = sprintf("Can't serialize XML structure: %s", $_);
        $stt = 0;
    };
    return (
        document=> $doc,
        struct  => $struct,
        error   => $err,
        status  => $stt,
    );
}
sub _deserialize { # XML -> Structure
    my $self = shift;
    my $xml = shift;
    my $attr = shift || {};
    my $out = CTK::Serializer::BLANK->(__PACKAGE__);
    $out->{document} = $xml;
    return %$out unless $xml;
    return %$out unless $xml =~ /^\s*\<(?!htm)(([?]?xml)|\w+)/;
    my $struct;
    try {
        my $in = XMLin($xml, %$attr);
        if ($in && ((ref($in) eq 'HASH') || ref($in) eq 'ARRAY')) {
            if (ref($in) eq 'ARRAY') {
                $out->{struct} = shift(@$in) || {};
            } else { # HASH
                $out->{struct} = $in;
            }
            $out->{error} = "";
            $out->{status} = 1;
        } else {
            $out->{error} = "Bad XML format";
        }
    } catch {
        $out->{error} = sprintf("Can't load XML document: %s", $_);
    };
    return %$out;
}

1;

package CTK::Serializer::YAML;
use strict;
use utf8;
use YAML::XS;
use Try::Tiny;

sub _serialize { # Structure -> YAML
    my $self = shift;
    my $struct = shift || {};
    my $doc = "";
    my $err = "";
    my $stt = 1;
    try {
        $doc = Dump($struct);
    } catch {
        $err = sprintf("Can't serialize YAML structure: %s", $_);
        $stt = 0;
    };
    return (
        document=> $doc,
        struct  => $struct,
        error   => $err,
        status  => $stt,
    );
}
sub _deserialize { # YAML -> Structure
    my $self = shift;
    my $yaml = shift;
    my $out = CTK::Serializer::BLANK->();
    $out->{document} = $yaml;
    return %$out unless $yaml;
    my $struct;
    try {
        my $in = Load($yaml);
        if ($in && ((ref($in) eq 'HASH') || ref($in) eq 'ARRAY')) {
            if (ref($in) eq 'ARRAY') {
                #$out->{struct} = shift(@$in) || {};
                $out->{struct} = $in;
            } else { # HASH
                $out->{struct} = $in;
            }
            $out->{error} = "";
            $out->{status} = 1;
        } else {
            $out->{error} = "Bad YAML format";
        }
    } catch {
        $out->{error} = sprintf("Can't load YAML document: %s", $_);
    };
    return %$out;
}

1;

__END__