1use strict; use warnings;
2
3package YAML::XS;
4our $VERSION = '0.83';
5
6use base 'Exporter';
7
8@YAML::XS::EXPORT = qw(Load Dump);
9@YAML::XS::EXPORT_OK = qw(LoadFile DumpFile);
10%YAML::XS::EXPORT_TAGS = (
11    all => [qw(Dump Load LoadFile DumpFile)],
12);
13our ($UseCode, $DumpCode, $LoadCode, $Boolean, $LoadBlessed, $Indent);
14# $YAML::XS::UseCode = 0;
15# $YAML::XS::DumpCode = 0;
16# $YAML::XS::LoadCode = 0;
17
18$YAML::XS::QuoteNumericStrings = 1;
19
20use YAML::XS::LibYAML qw(Load Dump);
21use Scalar::Util qw/ openhandle /;
22
23sub DumpFile {
24    my $OUT;
25    my $filename = shift;
26    if (openhandle $filename) {
27        $OUT = $filename;
28    }
29    else {
30        my $mode = '>';
31        if ($filename =~ /^\s*(>{1,2})\s*(.*)$/) {
32            ($mode, $filename) = ($1, $2);
33        }
34        open $OUT, $mode, $filename
35          or die "Can't open '$filename' for output:\n$!";
36    }
37    local $/ = "\n"; # reset special to "sane"
38    print $OUT YAML::XS::LibYAML::Dump(@_);
39}
40
41sub LoadFile {
42    my $IN;
43    my $filename = shift;
44    if (openhandle $filename) {
45        $IN = $filename;
46    }
47    else {
48        open $IN, $filename
49          or die "Can't open '$filename' for input:\n$!";
50    }
51    return YAML::XS::LibYAML::Load(do { local $/; local $_ = <$IN> });
52}
53
54
55# XXX The following code should be moved from Perl to C.
56$YAML::XS::coderef2text = sub {
57    my $coderef = shift;
58    require B::Deparse;
59    my $deparse = B::Deparse->new();
60    my $text;
61    eval {
62        local $^W = 0;
63        $text = $deparse->coderef2text($coderef);
64    };
65    if ($@) {
66        warn "YAML::XS failed to dump code ref:\n$@";
67        return;
68    }
69    $text =~ s[BEGIN \{\$\{\^WARNING_BITS\} = "UUUUUUUUUUUU\\001"\}]
70              [use warnings;]g;
71
72    return $text;
73};
74
75$YAML::XS::glob2hash = sub {
76    my $hash = {};
77    for my $type (qw(PACKAGE NAME SCALAR ARRAY HASH CODE IO)) {
78        my $value = *{$_[0]}{$type};
79        $value = $$value if $type eq 'SCALAR';
80        if (defined $value) {
81            if ($type eq 'IO') {
82                my @stats = qw(device inode mode links uid gid rdev size
83                               atime mtime ctime blksize blocks);
84                undef $value;
85                $value->{stat} = {};
86                map {$value->{stat}{shift @stats} = $_} stat(*{$_[0]});
87                $value->{fileno} = fileno(*{$_[0]});
88                {
89                    local $^W;
90                    $value->{tell} = tell(*{$_[0]});
91                }
92            }
93            $hash->{$type} = $value;
94        }
95    }
96    return $hash;
97};
98
99use constant _QR_MAP => {
100    '' => sub { qr{$_[0]} },
101    x => sub { qr{$_[0]}x },
102    i => sub { qr{$_[0]}i },
103    s => sub { qr{$_[0]}s },
104    m => sub { qr{$_[0]}m },
105    ix => sub { qr{$_[0]}ix },
106    sx => sub { qr{$_[0]}sx },
107    mx => sub { qr{$_[0]}mx },
108    si => sub { qr{$_[0]}si },
109    mi => sub { qr{$_[0]}mi },
110    ms => sub { qr{$_[0]}sm },
111    six => sub { qr{$_[0]}six },
112    mix => sub { qr{$_[0]}mix },
113    msx => sub { qr{$_[0]}msx },
114    msi => sub { qr{$_[0]}msi },
115    msix => sub { qr{$_[0]}msix },
116};
117
118sub __qr_loader {
119    if ($_[0] =~ /\A  \(\?  ([\^uixsm]*)  (?:-  (?:[ixsm]*))?  : (.*) \)  \z/x) {
120        my ($flags, $re) = ($1, $2);
121        $flags =~ s/^\^//;
122        $flags =~ tr/u//d;
123        my $sub = _QR_MAP->{$flags} || _QR_MAP->{''};
124        my $qr = &$sub($re);
125        return $qr;
126    }
127    return qr/$_[0]/;
128}
129
130sub __code_loader {
131    my ($string) = @_;
132    my $sub = eval "sub $string";
133    if ($@) {
134        warn "YAML::XS failed to load sub: $@";
135        return sub {};
136    }
137    return $sub;
138}
139
1401;
141