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