ingydotnet / yaml-old-pm / 23

pending completion

Build # 23

Build Type

push

travis-ci

Committed by

ingydotnet

Commit Message

<a href="https://github.com/ingydotnet/yaml-old-pm/commit/<a class=hub.com/ingydotnet/yaml-old-pm/commit/c8e071fc87d98d2a92929b86616a82cd36001610">c8e071fc8<a href="https://github.com/ingydotnet/yaml-old-pm/commit/c8e071fc87d98d2a92929b86616a82cd36001610">&quot;&gt;This starting commit is from yaml-pm tag 1.23.

The sha1 for that point is </a><a class="double-link" href="https://github.com/ingydotnet/yaml-old-pm/commit/<a class="double-link" href="https://github.com/ingydotnet/yaml-old-pm/commit/a8d33fd7ffcd4c523671604380f8426188964b8e">a8d33fd7f</a>">a8d33fd7f</a><a href="https://github.com/ingydotnet/yaml-old-pm/commit/c8e071fc87d98d2a92929b86616a82cd36001610">.

That sha1 is tagged yaml-pm-1.23 in this repository.

Run Details

1719 of 1719 new or added lines in 61 files covered. (100.0%)

1665 of 1772 relevant lines covered (93.96%)

1934.14 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

75.0

/lib/YAML/Types.pm

package YAML::Types;

use YAML::Mo;
use YAML::Node;

# XXX These classes and their APIs could still use some refactoring,
# but at least they work for now.
#-------------------------------------------------------------------------------
package YAML::Type::blessed;

use YAML::Mo; # XXX

sub yaml_dump {
    my $self = shift;
    my ($value) = @_;
    my ($class, $type) = YAML::Mo::Object->node_info($value);
    no strict 'refs';
    my $kind = lc($type) . ':';
    my $tag = ${$class . '::ClassTag'} ||
              "!perl/$kind$class";
    if ($type eq 'REF') {
        YAML::Node->new(
            {(&YAML::VALUE, ${$_[0]})}, $tag
        );
    }
    elsif ($type eq 'SCALAR') {
        $_[1] = $$value;
        YAML::Node->new($_[1], $tag);
    }
    elsif ($type eq 'GLOB') {
        # blessed glob support is minimal, and will not round-trip
        # initial aim: to not cause an error
        return YAML::Type::glob->yaml_dump($value, $tag);
    } else {
        YAML::Node->new($value, $tag);
    }
}

#-------------------------------------------------------------------------------
package YAML::Type::undef;

sub yaml_dump {
    my $self = shift;
}

sub yaml_load {
    my $self = shift;
}

#-------------------------------------------------------------------------------
package YAML::Type::glob;

sub yaml_dump {
    my $self = shift;
    # $_[0] remains as the glob
    my $tag = pop @_ if 2==@_;

    $tag = '!perl/glob:' unless defined $tag;
    my $ynode = YAML::Node->new({}, $tag);
    for my $type (qw(PACKAGE NAME SCALAR ARRAY HASH CODE IO)) {
        my $value = *{$_[0]}{$type};
        $value = $$value if $type eq 'SCALAR';
        if (defined $value) {
            if ($type eq 'IO') {
                my @stats = qw(device inode mode links uid gid rdev size
                               atime mtime ctime blksize blocks);
                undef $value;
                $value->{stat} = YAML::Node->new({});
                if ($value->{fileno} = fileno(*{$_[0]})) {
                    local $^W;
                    map {$value->{stat}{shift @stats} = $_} stat(*{$_[0]});
                    $value->{tell} = tell(*{$_[0]});
                }
            }
            $ynode->{$type} = $value;
        }
    }
    return $ynode;
}

sub yaml_load {
    my $self = shift;
    my ($node, $class, $loader) = @_;
    my ($name, $package);
    if (defined $node->{NAME}) {
        $name = $node->{NAME};
        delete $node->{NAME};
    }
    else {
        $loader->warn('YAML_LOAD_WARN_GLOB_NAME');
        return undef;
    }
    if (defined $node->{PACKAGE}) {
        $package = $node->{PACKAGE};
        delete $node->{PACKAGE};
    }
    else {
        $package = 'main';
    }
    no strict 'refs';
    if (exists $node->{SCALAR}) {
        *{"${package}::$name"} = \$node->{SCALAR};
        delete $node->{SCALAR};
    }
    for my $elem (qw(ARRAY HASH CODE IO)) {
        if (exists $node->{$elem}) {
            if ($elem eq 'IO') {
                $loader->warn('YAML_LOAD_WARN_GLOB_IO');
                delete $node->{IO};
                next;
            }
            *{"${package}::$name"} = $node->{$elem};
            delete $node->{$elem};
        }
    }
    for my $elem (sort keys %$node) {
        $loader->warn('YAML_LOAD_WARN_BAD_GLOB_ELEM', $elem);
    }
    return *{"${package}::$name"};
}

#-------------------------------------------------------------------------------
package YAML::Type::code;

my $dummy_warned = 0;
my $default = '{ "DUMMY" }';

sub yaml_dump {
    my $self = shift;
    my $code;
    my ($dumpflag, $value) = @_;
    my ($class, $type) = YAML::Mo::Object->node_info($value);
    my $tag = "!perl/code";
    $tag .= ":$class" if defined $class;
    if (not $dumpflag) {
        $code = $default;
    }
    else {
        bless $value, "CODE" if $class;
        eval { require B::Deparse };
        return if $@;
        my $deparse = B::Deparse->new();
        eval {
            local $^W = 0;
            $code = $deparse->coderef2text($value);
        };
        if ($@) {
            warn YAML::YAML_DUMP_WARN_DEPARSE_FAILED() if $^W;
            $code = $default;
        }
        bless $value, $class if $class;
        chomp $code;
        $code .= "\n";
    }
    $_[2] = $code;
    YAML::Node->new($_[2], $tag);
}

sub yaml_load {
    my $self = shift;
    my ($node, $class, $loader) = @_;
    if ($loader->load_code) {
        my $code = eval "package main; sub $node";
        if ($@) {
            $loader->warn('YAML_LOAD_WARN_PARSE_CODE', $@);
            return sub {};
        }
        else {
            CORE::bless $code, $class if $class;
            return $code;
        }
    }
    else {
        return CORE::bless sub {}, $class if $class;
        return sub {};
    }
}

#-------------------------------------------------------------------------------
package YAML::Type::ref;

sub yaml_dump {
    my $self = shift;
    YAML::Node->new({(&YAML::VALUE, ${$_[0]})}, '!perl/ref')
}

sub yaml_load {
    my $self = shift;
    my ($node, $class, $loader) = @_;
    $loader->die('YAML_LOAD_ERR_NO_DEFAULT_VALUE', 'ptr')
      unless exists $node->{&YAML::VALUE};
    return \$node->{&YAML::VALUE};
}

#-------------------------------------------------------------------------------
package YAML::Type::regexp;

# XXX Be sure to handle blessed regexps (if possible)
sub yaml_dump {
    die "YAML::Type::regexp::yaml_dump not currently implemented";
}

use constant _QR_TYPES => {
    '' => sub { qr{$_[0]} },
    x => sub { qr{$_[0]}x },
    i => sub { qr{$_[0]}i },
    s => sub { qr{$_[0]}s },
    m => sub { qr{$_[0]}m },
    ix => sub { qr{$_[0]}ix },
    sx => sub { qr{$_[0]}sx },
    mx => sub { qr{$_[0]}mx },
    si => sub { qr{$_[0]}si },
    mi => sub { qr{$_[0]}mi },
    ms => sub { qr{$_[0]}sm },
    six => sub { qr{$_[0]}six },
    mix => sub { qr{$_[0]}mix },
    msx => sub { qr{$_[0]}msx },
    msi => sub { qr{$_[0]}msi },
    msix => sub { qr{$_[0]}msix },
};

sub yaml_load {
    my $self = shift;
    my ($node, $class) = @_;
    return qr{$node} unless $node =~ /^\(\?([\^\-xism]*):(.*)\)\z/s;
    my ($flags, $re) = ($1, $2);
    $flags =~ s/-.*//;
    $flags =~ s/^\^//;
    my $sub = _QR_TYPES->{$flags} || sub { qr{$_[0]} };
    my $qr = &$sub($re);
    bless $qr, $class if length $class;
    return $qr;
}

1;

1	package YAML::Types;
2
3	use YAML::Mo;	344✔
4	use YAML::Node;	344✔
5
6	# XXX These classes and their APIs could still use some refactoring,
7	# but at least they work for now.
8	#-------------------------------------------------------------------------------
9	package YAML::Type::blessed;
10
11	use YAML::Mo; # XXX	344✔
12
13	sub yaml_dump {
14	my $self = shift;	232✔
15	my ($value) = @_;	232✔
16	my ($class, $type) = YAML::Mo::Object->node_info($value);	232✔
17	no strict 'refs';	344✔
18	my $kind = lc($type) . ':';	232✔
19	my $tag = ${$class . '::ClassTag'} \|\|	232✔
20	"!perl/$kind$class";
21	if ($type eq 'REF') {	232✔
22	YAML::Node->new(	6 all except 23.2 and 23.1 ✔
23	{(&YAML::VALUE, ${$_[0]})}, $tag	8✔
24	);
25	}
26	elsif ($type eq 'SCALAR') {
27	$_[1] = $$value;	56✔
28	YAML::Node->new($_[1], $tag);	56✔
29	}
30	elsif ($type eq 'GLOB') {
31	# blessed glob support is minimal, and will not round-trip
32	# initial aim: to not cause an error
33	return YAML::Type::glob->yaml_dump($value, $tag);	16✔
34	} else {
35	YAML::Node->new($value, $tag);	152✔
36	}
37	}
38
39	#-------------------------------------------------------------------------------
40	package YAML::Type::undef;
41
42	sub yaml_dump {
43	my $self = shift;	×
44	}
45
46	sub yaml_load {
47	my $self = shift;	×
48	}
49
50	#-------------------------------------------------------------------------------
51	package YAML::Type::glob;
52
53	sub yaml_dump {
54	my $self = shift;	64✔
55	# $_[0] remains as the glob
56	my $tag = pop @_ if 2==@_;	64✔
57
58	$tag = '!perl/glob:' unless defined $tag;	64✔
59	my $ynode = YAML::Node->new({}, $tag);	64✔
60	for my $type (qw(PACKAGE NAME SCALAR ARRAY HASH CODE IO)) {	64✔
61	my $value = *{$_[0]}{$type};	448✔
62	$value = $$value if $type eq 'SCALAR';	448✔
63	if (defined $value) {	448✔
64	if ($type eq 'IO') {	224✔
65	my @stats = qw(device inode mode links uid gid rdev size	8✔
66	atime mtime ctime blksize blocks);
67	undef $value;	8✔
68	$value->{stat} = YAML::Node->new({});	8✔
69	if ($value->{fileno} = fileno(*{$_[0]})) {	8✔
70	local $^W;	8✔
71	map {$value->{stat}{shift @stats} = $_} stat(*{$_[0]});	8✔
72	$value->{tell} = tell(*{$_[0]});	8✔
73	}
74	}
75	$ynode->{$type} = $value;	224✔
76	}
77	}
78	return $ynode;	64✔
79	}
80
81	sub yaml_load {
82	my $self = shift;	32✔
83	my ($node, $class, $loader) = @_;	32✔
84	my ($name, $package);	32✔
85	if (defined $node->{NAME}) {	32✔
86	$name = $node->{NAME};	24✔
87	delete $node->{NAME};	24✔
88	}
89	else {
90	$loader->warn('YAML_LOAD_WARN_GLOB_NAME');	8✔
91	return undef;	8✔
92	}
93	if (defined $node->{PACKAGE}) {	24✔
94	$package = $node->{PACKAGE};	16✔
95	delete $node->{PACKAGE};	16✔
96	}
97	else {
98	$package = 'main';	8✔
99	}
100	no strict 'refs';	344✔
101	if (exists $node->{SCALAR}) {	24✔
102	*{"${package}::$name"} = \$node->{SCALAR};	16✔
103	delete $node->{SCALAR};	16✔
104	}
105	for my $elem (qw(ARRAY HASH CODE IO)) {	24✔
106	if (exists $node->{$elem}) {	96✔
107	if ($elem eq 'IO') {	16✔
108	$loader->warn('YAML_LOAD_WARN_GLOB_IO');	×
109	delete $node->{IO};	×
110	next;	×
111	}
112	*{"${package}::$name"} = $node->{$elem};	16✔
113	delete $node->{$elem};	16✔
114	}
115	}
116	for my $elem (sort keys %$node) {	24✔
117	$loader->warn('YAML_LOAD_WARN_BAD_GLOB_ELEM', $elem);	8✔
118	}
119	return *{"${package}::$name"};	24✔
120	}
121
122	#-------------------------------------------------------------------------------
123	package YAML::Type::code;
124
125	my $dummy_warned = 0;
126	my $default = '{ "DUMMY" }';
127
128	sub yaml_dump {
129	my $self = shift;	56✔
130	my $code;	56✔
131	my ($dumpflag, $value) = @_;	56✔
132	my ($class, $type) = YAML::Mo::Object->node_info($value);	56✔
133	my $tag = "!perl/code";	56✔
134	$tag .= ":$class" if defined $class;	56✔
135	if (not $dumpflag) {	56✔
136	$code = $default;	16✔
137	}
138	else {
139	bless $value, "CODE" if $class;	40✔
140	eval { require B::Deparse };	40✔
141	return if $@;	40✔
142	my $deparse = B::Deparse->new();	40✔
143	eval {	40✔
144	local $^W = 0;	40✔
145	$code = $deparse->coderef2text($value);	40✔
146	};
147	if ($@) {	40✔
148	warn YAML::YAML_DUMP_WARN_DEPARSE_FAILED() if $^W;	×
149	$code = $default;	×
150	}
151	bless $value, $class if $class;	40✔
152	chomp $code;	40✔
153	$code .= "\n";	40✔
154	}
155	$_[2] = $code;	56✔
156	YAML::Node->new($_[2], $tag);	56✔
157	}
158
159	sub yaml_load {
160	my $self = shift;	32✔
161	my ($node, $class, $loader) = @_;	32✔
162	if ($loader->load_code) {	32✔
163	my $code = eval "package main; sub $node";	×
164	if ($@) {	×
165	$loader->warn('YAML_LOAD_WARN_PARSE_CODE', $@);	×
166	return sub {};	×
167	}
168	else {
169	CORE::bless $code, $class if $class;	×
170	return $code;	×
171	}
172	}
173	else {
174	return CORE::bless sub {}, $class if $class;	32✔
175	return sub {};	32✔
176	}
177	}
178
179	#-------------------------------------------------------------------------------
180	package YAML::Type::ref;
181
182	sub yaml_dump {
183	my $self = shift;	264✔
184	YAML::Node->new({(&YAML::VALUE, ${$_[0]})}, '!perl/ref')	264✔
185	}
186
187	sub yaml_load {
188	my $self = shift;	×
189	my ($node, $class, $loader) = @_;	×
190	$loader->die('YAML_LOAD_ERR_NO_DEFAULT_VALUE', 'ptr')	×
191	unless exists $node->{&YAML::VALUE};	×
192	return \$node->{&YAML::VALUE};	×
193	}
194
195	#-------------------------------------------------------------------------------
196	package YAML::Type::regexp;
197
198	# XXX Be sure to handle blessed regexps (if possible)
199	sub yaml_dump {
200	die "YAML::Type::regexp::yaml_dump not currently implemented";	×
201	}
202
203	use constant _QR_TYPES => {
204	'' => sub { qr{$_[0]} },	16✔
205	x => sub { qr{$_[0]}x },	×
206	i => sub { qr{$_[0]}i },	×
207	s => sub { qr{$_[0]}s },	×
208	m => sub { qr{$_[0]}m },	32✔
209	ix => sub { qr{$_[0]}ix },	×
210	sx => sub { qr{$_[0]}sx },	×
211	mx => sub { qr{$_[0]}mx },	×
212	si => sub { qr{$_[0]}si },	×
213	mi => sub { qr{$_[0]}mi },	×
214	ms => sub { qr{$_[0]}sm },	×
215	six => sub { qr{$_[0]}six },	×
216	mix => sub { qr{$_[0]}mix },	×
217	msx => sub { qr{$_[0]}msx },	×
218	msi => sub { qr{$_[0]}msi },	×
219	msix => sub { qr{$_[0]}msix },	×
220	};	344✔
221
222	sub yaml_load {
223	my $self = shift;	48✔
224	my ($node, $class) = @_;	48✔
225	return qr{$node} unless $node =~ /^\(\?([\^\-xism]):(.)\)\z/s;	48✔
226	my ($flags, $re) = ($1, $2);	48✔
227	$flags =~ s/-.*//;	48✔
228	$flags =~ s/^\^//;	48✔
229	my $sub = _QR_TYPES->{$flags} \|\| sub { qr{$_[0]} };	48✔
230	my $qr = &$sub($re);	48✔
231	bless $qr, $class if length $class;	48✔
232	return $qr;	48✔
233	}
234
235	1;

ingydotnet / yaml-old-pm / 23

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous