1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
|
use strict; use warnings;
package YAML::XS;
our $VERSION = '0.63';
use base 'Exporter';
@YAML::XS::EXPORT = qw(Load Dump);
@YAML::XS::EXPORT_OK = qw(LoadFile DumpFile);
%YAML::XS::EXPORT_TAGS = (
all => [qw(Dump Load LoadFile DumpFile)],
);
# $YAML::XS::UseCode = 0;
# $YAML::XS::DumpCode = 0;
# $YAML::XS::LoadCode = 0;
$YAML::XS::QuoteNumericStrings = 1;
use YAML::XS::LibYAML qw(Load Dump);
use Scalar::Util qw/ openhandle /;
sub DumpFile {
my $OUT;
my $filename = shift;
if (openhandle $filename) {
$OUT = $filename;
}
else {
my $mode = '>';
if ($filename =~ /^\s*(>{1,2})\s*(.*)$/) {
($mode, $filename) = ($1, $2);
}
open $OUT, $mode, $filename
or die "Can't open '$filename' for output:\n$!";
}
local $/ = "\n"; # reset special to "sane"
print $OUT YAML::XS::LibYAML::Dump(@_);
}
sub LoadFile {
my $IN;
my $filename = shift;
if (openhandle $filename) {
$IN = $filename;
}
else {
open $IN, $filename
or die "Can't open '$filename' for input:\n$!";
}
return YAML::XS::LibYAML::Load(do { local $/; local $_ = <$IN> });
}
# XXX The following code should be moved from Perl to C.
$YAML::XS::coderef2text = sub {
my $coderef = shift;
require B::Deparse;
my $deparse = B::Deparse->new();
my $text;
eval {
local $^W = 0;
$text = $deparse->coderef2text($coderef);
};
if ($@) {
warn "YAML::XS failed to dump code ref:\n$@";
return;
}
$text =~ s[BEGIN \{\$\{\^WARNING_BITS\} = "UUUUUUUUUUUU\\001"\}]
[use warnings;]g;
return $text;
};
$YAML::XS::glob2hash = sub {
my $hash = {};
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} = {};
map {$value->{stat}{shift @stats} = $_} stat(*{$_[0]});
$value->{fileno} = fileno(*{$_[0]});
{
local $^W;
$value->{tell} = tell(*{$_[0]});
}
}
$hash->{$type} = $value;
}
}
return $hash;
};
use constant _QR_MAP => {
'' => 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 __qr_loader {
if ($_[0] =~ /\A \(\? ([ixsm]*) (?:- (?:[ixsm]*))? : (.*) \) \z/x) {
my $sub = _QR_MAP->{$1} || _QR_MAP->{''};
&$sub($2);
}
else {
qr/$_[0]/;
}
}
1;
|
