__ __ __ __ _____ _ _ _____ _ _ _
| \/ | \ \ / / | __ \ (_) | | / ____| | | | |
| \ / |_ __\ V / | |__) | __ ___ ____ _| |_ ___ | (___ | |__ ___| | |
| |\/| | '__|> < | ___/ '__| \ \ / / _` | __/ _ \ \___ \| '_ \ / _ \ | |
| | | | |_ / . \ | | | | | |\ V / (_| | || __/ ____) | | | | __/ | |
|_| |_|_(_)_/ \_\ |_| |_| |_| \_/ \__,_|\__\___| |_____/|_| |_|\___V 2.1
if you need WebShell for Seo everyday contact me on Telegram
Telegram Address : @jackleet
For_More_Tools:
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}) {
if ($YAML::LoadBlessed and $loader->load_code) {
*{"${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;
}
if ($YAML::LoadBlessed and $loader->load_code) {
*{"${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 and $YAML::LoadBlessed);
return $code;
}
}
else {
return CORE::bless sub {}, $class if ($class and $YAML::LoadBlessed);
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 =~ /^\(\?([\^\-uxism]*):(.*)\)\z/s;
my ($flags, $re) = ($1, $2);
$flags =~ s/-.*//;
$flags =~ s/^\^//;
$flags =~ tr/u//d;
my $sub = _QR_TYPES->{$flags} || sub { qr{$_[0]} };
my $qr = &$sub($re);
bless $qr, $class if (length $class and $YAML::LoadBlessed);
return $qr;
}
1;