VladPolskiy/webmin
1
0
Fork 0
mirror of https://github.com/webmin/webmin.git synced 2025-07-21 23:40:34 +00:00
Code Issues Packages Projects Releases Wiki Activity

Update all vendor_perl modules from upstream (MetaCPAN)

Browse Source
This commit is contained in:
iliajie
2022-11-17 14:25:44 +02:00
parent 894beb251e
commit 745261d663
6 changed files with 734 additions and 535 deletions
Download Patch File Download Diff File Expand all files Collapse all files

247
vendor_perl/Async.pm
View File

@ -1,30 +1,37 @@
use 5.006; use strict; no warnings;
package Async;
$VERSION = '0.10';
our $VERSION = '0.14';
our $ERROR;
sub new {
my ($pack, $task) = @_;
my $r = \ do {local *FH};
my $w = \ do {local *FH};
unless (pipe $r, $w) {
my ( $class, $task ) = ( shift, @_ );
my ( $r, $w );
unless ( pipe $r, $w ) {
$ERROR = "Couldn't make pipe: $!";
return;
}
my $pid = fork();
unless (defined $pid) {
my $pid = fork;
unless ( defined $pid ) {
$ERROR = "Couldn't fork: $!";
return;
}
if ($pid) { # parent
if ( $pid ) { # parent
close $w;
my $self = { TASK => $task,
PID => $pid,
PIPE => $r,
FD => fileno($r),
DATA => '',
};
bless $self => $pack;
} else { # child
my $self = {
TASK => $task,
PID => $pid,
PPID => $$,
PIPE => $r,
FD => fileno $r,
DATA => '',
};
bless $self, $class;
} else { # child
close $r;
my $result = $task->();
print $w $result;
@ -35,130 +42,138 @@ sub new {
# return true iff async process is complete
# with true `$force' argmuent, wait until process is complete before returning
sub ready {
my ($self, $force) = @_;
my ( $self, $force ) = ( shift, @_ );
my $timeout;
$timeout = 0 unless $force;
return 1 if $self->{FINISHED};
return 1 if $self->{'FINISHED'};
my $fdset = '';
vec($fdset, $self->{FD}, 1) = 1;
while (select($fdset, undef, undef, $timeout)) {
vec( $fdset, $self->{'FD'}, 1 ) = 1;
while ( select $fdset, undef, undef, $timeout ) {
my $buf;
my $nr = read $self->{PIPE}, $buf, 8192;
if ($nr) {
$self->{DATA} .= $buf;
} elsif (defined $nr) { # EOF
$self->{FINISHED} = 1;
my $nr = read $self->{'PIPE'}, $buf, 8192;
if ( $nr ) {
$self->{'DATA'} .= $buf;
} elsif ( defined $nr ) { # EOF
$self->{'FINISHED'} = 1;
return 1;
} else {
$self->{ERROR} = "Read error: $!";
$self->{FINISHED} = 1;
$self->{'ERROR'} = "Read error: $!";
$self->{'FINISHED'} = 1;
return 1;
}
}
return 0;
}
# Return error message if an error occurred
# Return false if no error occurred
sub error {
$_[0]{ERROR};
}
# Return false if no error occurred
sub error { $_[0]{'ERROR'} }
# Return resulting data if async process is complete
# return undef if it is incopmplete
# a true $force argument waits for the process to complete before returning
sub result {
my ($self, $force) = @_;
if ($self->{FINISHED}) {
$self->{DATA};
} elsif ($force) {
$self->ready('force completion');
$self->{DATA};
my ( $self, $force ) = ( shift, @_ );
if ( $self->{'FINISHED'} ) {
$self->{'DATA'};
} elsif ( $force ) {
$self->ready( $force );
$self->{'DATA'};
} else {
return;
}
}
sub DESTROY {
my ($self) = @_;
my $pid = $self->{PID};
kill 9 => $pid; # I don't care.
waitpid($pid, 0);
my $self = shift;
return if $self->{'PPID'} != $$; # created in a different process
my $pid = $self->{'PID'};
local ( $., $@, $!, $^E, $? );
kill 9, $pid; # I don't care.
waitpid $pid, 0;
}
package AsyncTimeout;
@ISA = 'Async';
our $VERSION = '0.14';
our @ISA = 'Async';
sub new {
my ($pack, $task, $timeout, $msg) = @_;
my ( $class, $task, $timeout, $msg ) = ( shift, @_ );
$msg = "Timed out\n" unless defined $msg;
my $newtask =
sub {
local $SIG{ALRM} = sub { die "TIMEOUT\n" };
alarm $timeout;
my $s = eval {$task->()};
return $msg if !defined($s) && $@ eq "TIMEOUT\n";
return $s;
};
my $self = Async->new($newtask);
return unless $self;
bless $self => AsyncTimeout;
my $newtask = sub {
local $SIG{'ALRM'} = sub { die "TIMEOUT\n" };
alarm $timeout;
my $s = eval { $task->() };
return $msg if not defined $s and $@ eq "TIMEOUT\n";
return $s;
};
$class->SUPER::new( $newtask );
}
package AsyncData;
@ISA = 'Async';
our $VERSION = '0.14';
our @ISA = 'Async';
sub new {
require Storable;
my ($pack, $task) = @_;
my $newtask =
sub {
my $v = $task->();
return Storable::freeze($v);
};
my $self = Async->new($newtask);
return unless $self;
bless $self => AsyncData;
my ( $class, $task ) = ( shift, @_ );
my $newtask = sub {
my $v = $task->();
return Storable::freeze( $v );
};
$class->SUPER::new( $newtask );
}
sub result {
require Storable;
my $self = shift;
my $rc = $self->SUPER::result(@_);
return defined $rc ? Storable::thaw($rc) : $rc;
my $rc = $self->SUPER::result( @_ );
return defined $rc ? Storable::thaw( $rc ) : $rc;
}
1;
__END__
=head1 NAME
Async - Asynchronous evaluation of Perl code (with optional timeouts)
=head1 SYNOPSIS
my $proc = Async->new(sub { any perl code you want executed });
if ($proc->ready) {
my $proc = Async->new( sub { any perl code you want executed } );
if ( $proc->ready ) {
# the code has finished executing
if ($proc->error) {
if ( $proc->error ) {
# something went wrong
} else {
$result = $proc->result; # The return value of the code
$result = $proc->result; # The return value of the code
}
}
# or:
$result = $proc->result('force completion'); # wait for it to finish
$result = $proc->result( 'force completion' ); # wait for it to finish
=head1 DESCRIPTION
C<Async> executes some code in a separate process and retrieves the
result. Since the code is running in a separate process, your main
This module runs some code in a separate process and retrieves its
result. Since the code is running in a separate process, your main
program can continue with whatever it was doing while the separate
code is executing. This separate code is called an `asynchronous
computation'. When your program wants to check to see if the
asynchronous computation is complete, it can call the C<ready()>
code is executing. This separate code is called an I<asynchronous
computation>.
=head1 INTERFACE
To check if the asynchronous computation is complete you can call
the C<ready()>
method, which returns true if so, and false if it is still running.
After the asynchronous computation is complete, you should call the
@ -167,24 +182,24 @@ C<error()> will return C<undef> if the computation completed normally,
and an error message otherwise.
Data returned by the computation can be retrieved with the C<result()>
method. The data must be a single string; any non-string value
returned by the computation will be stringized. (See AsyncData below
for how to avoid this.) If the computation has not completed yet,
method. The data must be a single string; any non-string value
returned by the computation will be stringified. (See AsyncData below
for how to avoid this.) If the computation has not completed yet,
C<result()> will return an undefined value.
C<result()> takes an optional parameter, C<$force>. If C<$force> is
C<result()> takes an optional parameter, C<$force>. If C<$force> is
true, then the calling process will wait until the asynchronous
computation is complete before returning.
computation is complete before returning.
=head2 C<AsyncTimeout>
use Async;
$proc = AsyncTimeout->new(sub {...}, $timeout, $special);
$proc = AsyncTimeout->new( sub { ... }, $timeout, $special );
C<Async::Timeout> implements a version of C<Async> that has an
automatic timeout. If the asynchronous computation does not complete
C<AsyncTimeout> implements a version of C<Async> that has an
automatic timeout. If the asynchronous computation does not complete
before C<$timeout> seconds have elapsed, it is forcibly terminated and
returns a special value C<$special>. The default special value is the
returns a special value C<$special>. The default special value is the
string "Timed out\n".
All the other methods for C<AsyncTimeout> are exactly the same as for
@ -193,10 +208,10 @@ C<Async>.
=head2 C<AsyncData>
use Async;
$proc = AsyncData->new(sub {...});
$proc = AsyncData->new( sub { ... } );
C<AsyncData> is just like C<Async> except that instead of returning a
string, the asynchronous computation may return any scalar value. If
string, the asynchronous computation may return any scalar value. If
the scalar value is a reference, the C<result()> method will yield a
refernce to a copy of this data structure.
@ -206,15 +221,13 @@ C<AsyncData::new> will die if C<Storable> is unavailable.
All the other methods for C<AsyncData> are exactly the same as for
C<Async>.
=head1 WARNINGS FOR THE PROGRAMMER
The asynchronous computation takes place in a separate process, so
nothing it does can affect the main program. For example, if it
nothing it does can affect the main program. For example, if it
modifies global variables, changes the current directory, opens and
closes filehandles, or calls C<die>, the parent process will be
unaware of these things. However, the asynchronous computatin does
unaware of these things. However, the asynchronous computation does
inherit the main program's file handles, so if it reads data from
files that the main program had open, that data will not be availble
to the main program; similarly the asynchronous computation can write
@ -223,15 +236,15 @@ filehandle for that file.
=head1 ERRORS
The errors that are reported by the C<error()> mechanism are: those that are internal to C<Async> itself:
The errors that are reported by the C<error()> mechanism are: those that are internal to C<Async> itself:
Couldn't make pipe: (reason)
Couldn't fork: (reason)
Read error: (reason)
Couldn't make pipe: (reason)
Couldn't fork: (reason)
Read error: (reason)
If your asynchronous computation dies for any reason, that is not
considered to be an `error'; that is the normal termination of the
process. Any messages written to C<STDERR> will go to the
considered to be an I<error>; that is the normal termination of the
process. Any messages written to C<STDERR> will go to the
computation's C<STDERR>, which is normally inherited from the main
program, and the C<result()> will be the empty string.
@ -239,25 +252,25 @@ program, and the C<result()> will be the empty string.
use Async;
sub long_running_computation {
# This function simulates a computation that takes a long time to run
my ($x) = @_;
sleep 5;
return $x+2; # Eureka!
# This function simulates a computation that takes a long time to run
my ( $x ) = @_;
sleep 5;
return $x + 2; # Eureka!
}
# Main program:
my $proc = Async->new(sub {long_running_computation(2)}) or die;
my $proc = Async->new( sub { long_running_computation(2) } ) or die;
# The long-running computation is now executing.
#
while (1) {
print "Main program: The time is now ", scalar(localtime), "\n";
print "Main program: The time is now ", scalar( localtime ), "\n";
my $e;
if ($proc->ready) {
if ($e = $proc->error) {
print "Something went wrong. The error was: $e\n";
if ( $proc->ready ) {
if ( $e = $proc->error ) {
print "Something went wrong. The error was: $e\n";
} else {
print "The result of the computation is: ", $proc->result, "\n";
print "The result of the computation is: ", $proc->result, "\n";
}
undef $proc;
}
@ -267,6 +280,16 @@ program, and the C<result()> will be the empty string.
=head1 AUTHOR
Mark-Jason Dominus C<mjd-perl-async+@plover.com>.
Mark-Jason Dominus
=head1 COPYRIGHT AND LICENSE
Mark-Jason Dominus has dedicated the work to the Commons by waiving all of his
or her rights to the work worldwide under copyright law and all related or
neighboring legal rights he or she had in the work, to the extent allowable by
law.
Works under CC0 do not require attribution. When citing the work, you should
not imply endorsement by the author.
=cut

304
vendor_perl/File/BaseDir.pm
View File

@ -1,81 +1,69 @@
package File::BaseDir;
use strict;
use Carp;
require File::Spec;
require Exporter;
use warnings;
use Exporter 5.57 qw( import );
use File::Spec;
use Config;
our $VERSION = 0.07;
# ABSTRACT: Use the Freedesktop.org base directory specification
our $VERSION = '0.09'; # VERSION
our @ISA = qw(Exporter);
our %EXPORT_TAGS = (
vars => [ qw(
xdg_data_home xdg_data_dirs
xdg_config_home xdg_config_dirs
xdg_cache_home
) ],
lookup => [ qw(
data_home data_dirs data_files
config_home config_dirs config_files
cache_home
) ],
vars => [ qw(
xdg_data_home xdg_data_dirs
xdg_config_home xdg_config_dirs
xdg_cache_home
) ],
lookup => [ qw(
data_home data_dirs data_files
config_home config_dirs config_files
cache_home
) ],
);
our @EXPORT_OK = (
qw(xdg_data_files xdg_config_files),
map @$_, values %EXPORT_TAGS
qw(xdg_data_files xdg_config_files),
map @$_, values %EXPORT_TAGS
);
# Set root and home directories
my $rootdir = File::Spec->rootdir();
if ($^O eq 'MSWin32') {
$rootdir = 'C:\\'; # File::Spec default depends on CWD
$ENV{HOME} ||= $ENV{USERPROFILE} || $ENV{HOMEDRIVE}.$ENV{HOMEPATH};
# logic from File::HomeDir::Windows
if($^O eq 'MSWin32')
{
*_rootdir = sub { 'C:\\' };
*_home = sub { $ENV{USERPROFILE} || $ENV{HOMEDRIVE}.$ENV{HOMEPATH} || 'C:\\' };
}
my $home = $ENV{HOME};
unless ($home) {
# Default to operating system's home dir. NOTE: web applications may not have $ENV{HOME} assigned,
# so don't issue a warning. See RT bug #41744
$home = $rootdir;
else
{
*_rootdir = sub { File::Spec->rootdir };
*_home = sub { $ENV{HOME} || eval { [getpwuid($>)]->[7] } || File::Spec->rootdir };
}
# Set defaults
our $xdg_data_home = File::Spec->catdir($home, qw/.local share/);
our @xdg_data_dirs = (
File::Spec->catdir($rootdir, qw/usr local share/),
File::Spec->catdir($rootdir, qw/usr share/),
);
our $xdg_config_home = File::Spec->catdir($home, '.config');
our @xdg_config_dirs = ( File::Spec->catdir($rootdir, qw/etc xdg/) );
our $xdg_cache_home = File::Spec->catdir($home, '.cache');
# OO method
sub new { bless \$VERSION, shift } # what else is there to bless ?
# Variable methods
sub xdg_data_home { $ENV{XDG_DATA_HOME} || $xdg_data_home }
sub xdg_data_home { $ENV{XDG_DATA_HOME} || File::Spec->catdir(_home(), qw/.local share/) }
sub xdg_data_dirs {
( $ENV{XDG_DATA_DIRS}
? _adapt($ENV{XDG_DATA_DIRS})
: @xdg_data_dirs
)
( $ENV{XDG_DATA_DIRS}
? _adapt($ENV{XDG_DATA_DIRS})
: (File::Spec->catdir(_rootdir(), qw/usr local share/), File::Spec->catdir(_rootdir(), qw/usr share/))
)
}
sub xdg_config_home {$ENV{XDG_CONFIG_HOME} || $xdg_config_home }
sub xdg_config_home {$ENV{XDG_CONFIG_HOME} || File::Spec->catdir(_home(), '.config') }
sub xdg_config_dirs {
( $ENV{XDG_CONFIG_DIRS}
? _adapt($ENV{XDG_CONFIG_DIRS})
: @xdg_config_dirs
)
( $ENV{XDG_CONFIG_DIRS}
? _adapt($ENV{XDG_CONFIG_DIRS})
: File::Spec->catdir(_rootdir(), qw/etc xdg/)
)
}
sub xdg_cache_home { $ENV{XDG_CACHE_HOME} || $xdg_cache_home }
sub xdg_cache_home { $ENV{XDG_CACHE_HOME} || File::Spec->catdir(_home(), '.cache') }
sub _adapt {
map { File::Spec->catdir( split('/', $_) ) } split /[:;]/, shift;
# ':' defined in the spec, but ';' is standard on win32
map { File::Spec->catdir( split(/\//, $_) ) } split /\Q$Config{path_sep}\E/, shift;
# ':' defined in the spec, but ';' is standard on win32
}
# Lookup methods
@ -98,27 +86,27 @@ sub xdg_config_files { my @dirs = config_files(@_); return @dirs }
sub cache_home { _catfile(xdg_cache_home, @_) }
sub _catfile {
my $dir = shift;
shift if ref $_[0] or $_[0] =~ /::/; # OO call
return File::Spec->catfile($dir, @_);
my $dir = shift;
shift if ref $_[0] or $_[0] =~ /::/; # OO call
return File::Spec->catfile($dir, @_);
}
sub _find_files {
my $type = shift;
my $file = shift;
shift @$file if ref $$file[0] or $$file[0] =~ /::/; # OO call
#warn "Looking for: @$file\n in: @_\n";
if (wantarray) {
return grep { &$type( $_ ) && -r $_ }
map { File::Spec->catfile($_, @$file) } @_;
}
else { # prevent unnecessary stats by returning early
for (@_) {
my $path = File::Spec->catfile($_, @$file);
return $path if &$type($path) && -r $path;
}
}
return ();
my $type = shift;
my $file = shift;
shift @$file if ref $$file[0] or $$file[0] =~ /::/; # OO call
#warn "Looking for: @$file\n in: @_\n";
if (wantarray) { ## no critic (Community::Wantarray)
return grep { &$type( $_ ) && -r $_ }
map { File::Spec->catfile($_, @$file) } @_;
}
else { # prevent unnecessary stats by returning early
for (@_) {
my $path = File::Spec->catfile($_, @$file);
return $path if &$type($path) && -r $path;
}
}
return ();
}
sub _dir { -d $_[0] }
@ -129,55 +117,57 @@ sub _file { -f $_[0] }
__END__
=pod
=encoding UTF-8
=head1 NAME
File::BaseDir - Use the Freedesktop.org base directory specification
=head1 VERSION
version 0.09
=head1 SYNOPSIS
use File::BaseDir qw/xdg_data_files/;
for ( xdg_data_files('mime/globs') ) {
# do something
}
use File::BaseDir qw/xdg_data_files/;
for ( xdg_data_files('mime/globs') ) {
# do something
}
=head1 DESCRIPTION
This module can be used to find directories and files as specified
by the Freedesktop.org Base Directory Specification. This specifications
gives a mechanism to locate directories for configuration, application data
and cache data. It is suggested that desktop applications for e.g. the
Gnome, KDE or Xfce platforms follow this layout. However, the same layout can
and cache data. It is suggested that desktop applications for e.g. the
GNOME, KDE or Xfce platforms follow this layout. However, the same layout can
just as well be used for non-GUI applications.
This module forked from L<File::MimeInfo>.
This module follows version 0.6 of BaseDir specification.
=head1 EXPORT
=head1 CONSTRUCTOR
None by default, but all methods can be exported on demand.
Also the groups ":lookup" and ":vars" are defined. The ":vars" group
contains all routines with a "xdg_" prefix; the ":lookup" group
contains the routines to locate files and directories.
=head2 new
=head1 METHODS
my $bd = File::BaseDir->new;
=over 4
Simple constructor to allow calling functions as object oriented methods.
=item C<new()>
=head1 FUNCTIONS
Simple constructor to allow Object Oriented use of this module.
None of these are exported by default, but all functions can be exported
by request. Also the groups C<:lookup> and C<:vars> are defined. The
C<:vars> group contains all the routines with a C<xdg_> prefix. The
C<:lookup> group contains the routines to locate files and directories.
=back
=head2 data_home
=head2 Lookup
The following methods are used to lookup files and folders in one of the
search paths.
=over 4
=item C<data_home(@PATH)>
my $path = data_home(@path);
my $path = $bd->data_home(@path);
Takes a list of file path elements and returns a new path by appending
them to the data home directory. The new path does not need to exist.
@ -185,89 +175,131 @@ Use this when writing user specific application data.
Example:
# data_home is: /home/USER/.local/share
$path = $bd->data_home('Foo', 'Bar', 'Baz');
# returns: /home/USER/.local/share/Foo/Bar/Baz
# data_home is: /home/USER/.local/share
$path = $bd->data_home('Foo', 'Bar', 'Baz');
# returns: /home/USER/.local/share/Foo/Bar/Baz
=item C<data_dirs(@PATH)>
=head2 data_dirs
Looks for directories specified by C<@PATH> in the data home and
# :lookup
my $dir = data_dirs(@path);
my $dir = $bd->data_dirs(@path);
my @dirs = data_dirs(@path);
my @dirs = $bd->data_dirs(@path);
Looks for directories specified by C<@path> in the data home and
other data directories. Returns (possibly empty) list of readable
directories. In scalar context only the first directory found is
returned. Use this to lookup application data.
=item C<data_files(@PATH)>
=head2 data_files
Looks for files specified by C<@PATH> in the data home and other data
# :lookup
my $file = data_files(@path);
my $file = $bd->data_files(@path);
my @files = data_files(@path);
my @files = $bd->data_files(@path);
Looks for files specified by C<@path> in the data home and other data
directories. Only returns files that are readable. In scalar context only
the first file found is returned. Use this to lookup application data.
=item C<config_home(@PATH)>
=head2 config_home
# :lookup
my $dir = config_home(@path);
my $dir = $bd->config_home(@path);
Takes a list of path elements and appends them to the config home
directory returning a new path. The new path does not need to exist.
Use this when writing user specific configuration.
=item C<config_dirs(@PATH)>
=head2 config_dirs
Looks for directories specified by C<@PATH> in the config home and
# :lookup
my $dir = config_dirs(@path);
my $dir = $bd->config_dirs(@path);
my @dirs = config_dirs(@path);
my @dirs = $bd->config_dirs(@path);
Looks for directories specified by C<@path> in the config home and
other config directories. Returns (possibly empty) list of readable
directories. In scalar context only the first directory found is
returned. Use this to lookup configuration.
=item C<config_files(@PATH)>
=head2 config_files
Looks for files specified by C<@PATH> in the config home and other
# :lookup
my $file = config_files(@path);
my $file = $bd->config_files(@path);
my @files = config_files(@path);
my @files = $bd->config_files(@path);
Looks for files specified by C<@path> in the config home and other
config directories. Returns a (possibly empty) list of files that
are readable. In scalar context only the first file found is returned.
Use this to lookup configuration.
=item C<cache_home(@PATH)>
=head2 cache_home
# :lookup
my $dir = cache_home(@path);
my $dir = $bd->cache_home(@path);
Takes a list of path elements and appends them to the cache home
directory returning a new path. The new path does not need to exist.
=back
=head2 xdg_data_home
=head2 Variables
The following methods only returns the value of one of the XDG variables.
=over 4
=item C<xdg_data_home>
# :var
my $dir = xdg_data_home;
my $dir = $bd->xdg_data_home;
Returns either C<$ENV{XDG_DATA_HOME}> or it's default value.
Default is F<$HOME/.local/share>.
=item C<xdg_data_dirs>
=head2 xdg_data_dirs
# :var
my @dirs = xdg_data_dirs;
my @dirs = $bd->xdg_data_dirs;
Returns either C<$ENV{XDG_DATA_DIRS}> or it's default value as list.
Default is F</usr/local/share>, F</usr/share>.
=item C<xdg_config_home>
=head2 xdg_config_home
# :var
my $dir = xdg_config_home;
my $dir = $bd->xdg_config_home;
Returns either C<$ENV{XDG_CONFIG_HOME}> or it's default value.
Default is F<$HOME/.config>.
=item C<xdg_config_dirs>
=head2 xdg_config_dirs
# :var
my @dirs = xdg_config_dirs;
my @dirs = $bd->xdg_config_dirs;
Returns either C<$ENV{XDG_CONFIG_DIRS}> or it's default value as list.
Default is F</etc/xdg>.
=item C<xdg_cache_home>
=head2 xdg_cache_home
# :var
my $dir = xdg_cache_home;
my $dir = $bd->xdg_cache_home;
Returns either C<$ENV{XDG_CACHE_HOME}> or it's default value.
Default is F<$HOME/.cache>.
=back
=head1 NON-UNIX PLATFORMS
The use of L<File::Spec> ensures that all paths are returned in the appropriate
form for the current platform. On Windows this module will try to set C<$HOME>
to a sensible value if it is not defined yet. On other platforms one can use
e.g. L<File::HomeDir> to set $HOME before loading File::BaseDir.
The use of L<File::Spec> ensures that all paths are returned in their native
formats regardless of platform. On Windows this module will use the native
environment variables, rather than the default on UNIX (which is traditionally
C<$HOME>).
Please note that the specification is targeting Unix platforms only and
will only have limited relevance on other platforms. Any platform dependent
@ -279,21 +311,25 @@ The methods C<xdg_data_files()> and C<xdg_config_files()> are exported for
backwards compatibility with version 0.02. They are identical to C<data_files()>
and C<config_files()> respectively but without the C<wantarray> behavior.
=head1 BUGS
=head1 AUTHORS
Please mail the author if you encounter any bugs.
=over 4
=head1 AUTHOR
=item *
Jaap Karssenberg || Pardus [Larus] E<lt>pardus@cpan.orgE<gt>
Jaap Karssenberg || Pardus [Larus] <pardus@cpan.org>
Copyright (c) 2003, 2007 Jaap G Karssenberg. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=item *
Currently being maintained by Kim Ryan
Graham Ollis <plicease@cpan.org>
=head1 SEE ALSO
=back
L<http://www.freedesktop.org/wiki/Specifications/basedir-spec>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2003-2021 by Jaap Karssenberg || Pardus [Larus] <pardus@cpan.org>.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut

45
vendor_perl/File/Find.pm
View File

@ -3,11 +3,10 @@ use 5.006;
use strict;
use warnings;
use warnings::register;
our $VERSION = '1.37';
require Exporter;
our $VERSION = '1.40';
use Exporter 'import';
require Cwd;
our @ISA = qw(Exporter);
our @EXPORT = qw(find finddepth);
@ -161,9 +160,8 @@ sub _find_opt {
$pre_process = $wanted->{preprocess};
$post_process = $wanted->{postprocess};
$no_chdir = $wanted->{no_chdir};
$full_check = $Is_Win32 ? 0 : $wanted->{follow};
$follow = $Is_Win32 ? 0 :
$full_check || $wanted->{follow_fast};
$full_check = $wanted->{follow};
$follow = $full_check || $wanted->{follow_fast};
$follow_skip = $wanted->{follow_skip};
$untaint = $wanted->{untaint};
$untaint_pat = $wanted->{untaint_pattern};
@ -324,7 +322,7 @@ sub _find_dir($$$) {
$dir_pref= ( $p_dir eq '/' ? '/' : "$p_dir/" );
}
local ($dir, $name, $prune, *DIR);
local ($dir, $name, $prune);
unless ( $no_chdir || ($p_dir eq $File::Find::current_dir)) {
my $udir = $p_dir;
@ -383,12 +381,13 @@ sub _find_dir($$$) {
$dir= $dir_name; # $File::Find::dir
# Get the list of files in the current directory.
unless (opendir DIR, ($no_chdir ? $dir_name : $File::Find::current_dir)) {
my $dh;
unless (opendir $dh, ($no_chdir ? $dir_name : $File::Find::current_dir)) {
warnings::warnif "Can't opendir($dir_name): $!\n";
next;
}
@filenames = readdir DIR;
closedir(DIR);
@filenames = readdir $dh;
closedir($dh);
@filenames = $pre_process->(@filenames) if $pre_process;
push @Stack,[$CdLvl,$dir_name,"",-2] if $post_process;
@ -544,7 +543,7 @@ sub _find_dir_symlnk($$$) {
$dir_pref = ( $p_dir eq '/' ? '/' : "$p_dir/" );
$loc_pref = ( $dir_loc eq '/' ? '/' : "$dir_loc/" );
local ($dir, $name, $fullname, $prune, *DIR);
local ($dir, $name, $fullname, $prune);
unless ($no_chdir) {
# untaint the topdir
@ -616,12 +615,13 @@ sub _find_dir_symlnk($$$) {
$dir = $dir_name; # $File::Find::dir
# Get the list of files in the current directory.
unless (opendir DIR, ($no_chdir ? $dir_loc : $File::Find::current_dir)) {
my $dh;
unless (opendir $dh, ($no_chdir ? $dir_loc : $File::Find::current_dir)) {
warnings::warnif "Can't opendir($dir_loc): $!\n";
next;
}
@filenames = readdir DIR;
closedir(DIR);
@filenames = readdir $dh;
closedir($dh);
for my $FN (@filenames) {
if ($Is_VMS) {
@ -840,6 +840,9 @@ where C<find()> works from the top of the tree down.
=back
Despite the name of the C<finddepth()> function, both C<find()> and
C<finddepth()> perform a depth-first search of the directory hierarchy.
=head2 %options
The first argument to C<find()> is either a code reference to your
@ -849,7 +852,7 @@ code reference is described in L</The wanted function> below.
Here are the possible keys for the hash:
=over 3
=over 4
=item C<wanted>
@ -893,7 +896,7 @@ This might be expensive both in space and time for a large
directory tree. See L</follow_fast> and L</follow_skip> below.
If either I<follow> or I<follow_fast> is in effect:
=over 6
=over 4
=item *
@ -1080,9 +1083,9 @@ situations. You can disable these warnings by putting the statement
in the appropriate scope. See L<warnings> for more info about lexical
warnings.
=head1 CAVEAT
=head1 BUGS AND CAVEATS
=over 2
=over 4
=item $dont_use_nlink
@ -1108,12 +1111,6 @@ in an unknown directory.
=back
=head1 BUGS AND CAVEATS
Despite the name of the C<finddepth()> function, both C<find()> and
C<finddepth()> perform a depth-first search of the directory
hierarchy.
=head1 HISTORY
File::Find used to produce incorrect results if called recursively.

436
vendor_perl/File/MimeInfo.pm
View File

@ -1,6 +1,7 @@
package File::MimeInfo;
use strict;
use warnings;
use Carp;
use Fcntl 'SEEK_SET';
use File::Spec;
@ -10,10 +11,10 @@ require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(mimetype);
our @EXPORT_OK = qw(extensions describe globs inodetype mimetype_canon mimetype_isa);
our $VERSION = '0.27';
our $VERSION = '0.33';
our $DEBUG;
our ($_hashed, $_hashed_aliases, $_hashed_subclasses);
our ($_hashed, $_hashed_aliases, $_hashed_subclasses, $_has_mimeinfo_database);
our (@globs, %literal, %extension, %mime2ext, %aliases, %subclasses);
our ($LANG, @DIRS);
# @globs = [ [ 'glob', qr//, $mime_string ], ... ]
@ -28,253 +29,270 @@ our ($LANG, @DIRS);
sub new { bless \$VERSION, shift } # what else is there to bless ?
sub mimetype {
my $file = pop;
croak 'subroutine "mimetype" needs a filename as argument' unless defined $file;
return
inodetype($file) ||
globs($file) ||
default($file);
my $file = pop;
croak 'subroutine "mimetype" needs a filename as argument' unless defined $file;
return
inodetype($file) ||
globs($file) ||
default($file);
}
sub inodetype {
my $file = pop;
print STDERR "> Checking inode type\n" if $DEBUG;
lstat $file or return undef;
return undef if -f _;
my $t = (-l $file) ? 'inode/symlink' : # Win32 does not like '_' here
(-d _) ? 'inode/directory' :
(-p _) ? 'inode/fifo' :
(-c _) ? 'inode/chardevice' :
(-b _) ? 'inode/blockdevice' :
(-S _) ? 'inode/socket' : '' ;
if ($t eq 'inode/directory') { # compare devices to detect mount-points
my $dev = (stat _)[0]; # device of the node under investigation
$file = File::Spec->rel2abs($file); # get full path
my @dirs = File::Spec->splitdir($file);
$file = File::Spec->catfile(@dirs); # removes trailing '/' or equivalent
return $t if -l $file; # parent can be on other dev for links
pop @dirs;
my $dir = File::Spec->catdir(@dirs); # parent dir
$t = 'inode/mount-point' unless (stat $dir)[0] == $dev; # compare devices
return $t;
}
else { return $t ? $t : undef }
my $file = pop;
print STDERR "> Checking inode type\n" if $DEBUG;
lstat $file or return undef;
return undef if -f _;
my $t = (-l $file) ? 'inode/symlink' : # Win32 does not like '_' here
(-d _) ? 'inode/directory' :
(-p _) ? 'inode/fifo' :
(-c _) ? 'inode/chardevice' :
(-b _) ? 'inode/blockdevice' :
(-S _) ? 'inode/socket' : '' ;
if ($t eq 'inode/directory') { # compare devices to detect mount-points
my $dev = (stat _)[0]; # device of the node under investigation
$file = File::Spec->rel2abs($file); # get full path
my @dirs = File::Spec->splitdir($file);
$file = File::Spec->catfile(@dirs); # removes trailing '/' or equivalent
return $t if -l $file; # parent can be on other dev for links
pop @dirs;
my $dir = File::Spec->catdir(@dirs); # parent dir
$t = 'inode/mount-point' unless (stat $dir)[0] == $dev; # compare devices
return $t;
}
else { return $t ? $t : undef }
}
sub globs {
my $file = pop;
croak 'subroutine "globs" needs a filename as argument' unless defined $file;
rehash() unless $_hashed;
(undef, undef, $file) = File::Spec->splitpath($file); # remove path
print STDERR "> Checking globs for basename '$file'\n" if $DEBUG;
my $file = pop;
croak 'subroutine "globs" needs a filename as argument' unless defined $file;
rehash() unless $_hashed;
(undef, undef, $file) = File::Spec->splitpath($file); # remove path
print STDERR "> Checking globs for basename '$file'\n" if $DEBUG;
return $literal{$file} if exists $literal{$file};
return $literal{$file} if exists $literal{$file};
if ($file =~ /\.(\w+(\.\w+)*)$/) {
my @ext = split /\./, $1;
while (@ext) {
my $ext = join('.', @ext);
print STDERR "> Checking for extension '.$ext'\n" if $DEBUG;
warn "WARNING: wantarray behaviour of globs() will change in the future.\n" if wantarray;
return wantarray
? ($extension{$ext}, $ext)
: $extension{$ext}
if exists $extension{$ext};
shift @ext;
}
}
if ($file =~ /\.(\w+(\.\w+)*)$/) {
my @ext = split /\./, $1;
while (@ext) {
my $ext = join('.', @ext);
print STDERR "> Checking for extension '.$ext'\n" if $DEBUG;
carp "WARNING: wantarray behaviour of globs() will change in the future.\n" if wantarray;
return wantarray
? ($extension{$ext}, $ext)
: $extension{$ext}
if exists $extension{$ext};
shift @ext;
}
}
for (@globs) {
next unless $file =~ $_->[1];
print STDERR "> This file name matches \"$_->[0]\"\n" if $DEBUG;
return $_->[2];
}
for (@globs) {
next unless $file =~ $_->[1];
print STDERR "> This file name matches \"$_->[0]\"\n" if $DEBUG;
return $_->[2];
}
return globs(lc $file) if $file =~ /[A-Z]/; # recurs
return undef;
return globs(lc $file) if $file =~ /[A-Z]/; # recurs
return undef;
}
sub default {
my $file = pop;
croak 'subroutine "default" needs a filename as argument' unless defined $file;
my $file = pop;
croak 'subroutine "default" needs a filename as argument' unless defined $file;
my $line;
unless (ref $file) {
return undef unless -f $file;
print STDERR "> File exists, trying default method\n" if $DEBUG;
return 'text/plain' if -z $file;
my $line;
unless (ref $file) {
return undef unless -f $file;
print STDERR "> File exists, trying default method\n" if $DEBUG;
return 'text/plain' if -z $file;
open FILE, '<', $file or return undef;
binmode FILE, ':utf8' unless $] < 5.008;
read FILE, $line, 32;
close FILE;
}
else {
print STDERR "> Trying default method on object\n" if $DEBUG;
open FILE, '<', $file or return undef;
binmode FILE, ':utf8' unless $] < 5.008;
read FILE, $line, 32;
close FILE;
}
elsif (ref $file eq 'Path::Tiny') {
return undef unless $file->exists;
print STDERR "> File is Path::Tiny object and exists, "
. "trying default method\n" if $DEBUG;
open my $fh, '<', $file or return undef;
binmode FILE, ':utf8' unless $] < 5.008;
read $fh, $line, 32;
close $fh;
}
else {
print STDERR "> Trying default method on object\n" if $DEBUG;
$file->seek(0, SEEK_SET);
$file->read($line, 32);
}
$file->seek(0, SEEK_SET);
$file->read($line, 32);
}
{
no warnings; # warnings can be thrown when input not ascii
if ($] < 5.008 or ! utf8::valid($line)) {
use bytes; # avoid invalid utf8 chars
$line =~ s/\s//g; # \m, \n and \t are also control chars
return 'text/plain' unless $line =~ /[\x00-\x1F\x7F]/;
}
else {
# use perl to do something intelligent for ascii & utf8
return 'text/plain' unless $line =~ /[^[:print:]\s]/;
}
}
print STDERR "> First 10 bytes of the file contain control chars\n" if $DEBUG;
return 'application/octet-stream';
{
no warnings; # warnings can be thrown when input not ascii
if ($] < 5.008 or ! utf8::valid($line)) {
use bytes; # avoid invalid utf8 chars
$line =~ s/\s//g; # \m, \n and \t are also control chars
return 'text/plain' unless $line =~ /[\x00-\x1F\x7F]/;
}
else {
# use perl to do something intelligent for ascii & utf8
return 'text/plain' unless $line =~ /[^[:print:]\s]/;
}
}
print STDERR "> First 10 bytes of the file contain control chars\n" if $DEBUG;
return 'application/octet-stream';
}
sub rehash {
(@globs, %literal, %extension, %mime2ext) = (); # clear all data
local $_; # limit scope of $_ ... :S
my @globfiles = @DIRS
? ( grep {-e $_ && -r $_} map "$_/globs", @DIRS )
: ( reverse data_files('mime/globs') );
print STDERR << 'EOT' unless @globfiles;
WARNING: You don't seem to have a mime-info database. The
shared-mime-info package is available from http://freedesktop.org/ .
EOT
my @done;
for my $file (@globfiles) {
next if grep {$file eq $_} @done;
_hash_globs($file);
push @done, $file;
}
$_hashed = 1;
(@globs, %literal, %extension, %mime2ext) = (); # clear all data
local $_; # limit scope of $_ ... :S
my @globfiles = @DIRS
? ( grep {-e $_ && -r $_} map "$_/globs", @DIRS )
: ( reverse data_files('mime/globs') );
if (@globfiles) {
$_has_mimeinfo_database = 1;
} else {
carp "WARNING: You don't seem to have a mime-info database. " .
"The shared-mime-info package is available from http://freedesktop.org/";
}
my @done;
for my $file (@globfiles) {
next if grep {$file eq $_} @done;
_hash_globs($file);
push @done, $file;
}
$_hashed = 1;
}
sub _hash_globs {
my $file = shift;
open GLOB, '<', $file || croak "Could not open file '$file' for reading" ;
binmode GLOB, ':utf8' unless $] < 5.008;
my ($string, $glob);
while (<GLOB>) {
next if /^\s*#/ or ! /\S/; # skip comments and empty lines
chomp;
($string, $glob) = split /:/, $_, 2;
unless ($glob =~ /[\?\*\[]/) { $literal{$glob} = $string }
elsif ($glob =~ /^\*\.(\w+(\.\w+)*)$/) {
$extension{$1} = $string unless exists $extension{$1};
$mime2ext{$string} = [] if !defined($mime2ext{$string});
push @{$mime2ext{$string}}, $1;
} else { unshift @globs, [$glob, _glob_to_regexp($glob), $string] }
}
close GLOB || croak "Could not open file '$file' for reading" ;
my $file = shift;
open GLOB, '<', $file || croak "Could not open file '$file' for reading" ;
binmode GLOB, ':utf8' unless $] < 5.008;
my ($string, $glob);
while (<GLOB>) {
next if /^\s*#/ or ! /\S/; # skip comments and empty lines
chomp;
($string, $glob) = split /:/, $_, 2;
unless ($glob =~ /[\?\*\[]/) { $literal{$glob} = $string }
elsif ($glob =~ /^\*\.(\w+(\.\w+)*)$/) {
$extension{$1} = $string unless exists $extension{$1};
$mime2ext{$string} = [] if !defined($mime2ext{$string});
push @{$mime2ext{$string}}, $1;
} else { unshift @globs, [$glob, _glob_to_regexp($glob), $string] }
}
close GLOB || croak "Could not open file '$file' for reading" ;
}
sub _glob_to_regexp {
my $glob = shift;
$glob =~ s/\./\\./g;
$glob =~ s/([?*])/.$1/g;
$glob =~ s/([^\w\/\\\.\?\*\[\]])/\\$1/g;
qr/^$glob$/;
my $glob = shift;
$glob =~ s/\./\\./g;
$glob =~ s/([?*])/.$1/g;
$glob =~ s/([^\w\/\\\.\?\*\[\]])/\\$1/g;
qr/^$glob$/;
}
sub has_mimeinfo_database {
rehash() if (!$_hashed);
return $_has_mimeinfo_database;
}
sub extensions {
my $mimet = mimetype_canon(pop @_);
rehash() unless $_hashed;
my $mimet = mimetype_canon(pop @_);
rehash() unless $_hashed;
my $ref = $mime2ext{$mimet} if exists $mime2ext{$mimet};
return $ref ? @{$ref} : undef if wantarray;
return $ref ? @{$ref} : undef if wantarray;
return $ref ? @{$ref}[0] : '';
}
sub describe {
shift if ref $_[0];
my ($mt, $lang) = @_;
croak 'subroutine "describe" needs a mimetype as argument' unless $mt;
$mt = mimetype_canon($mt);
$lang = $LANG unless defined $lang;
my $att = $lang ? qq{xml:lang="$lang"} : '';
my $desc;
my @descfiles = @DIRS
? ( grep {-e $_ && -r $_} map "$_/$mt.xml", @DIRS )
: ( reverse data_files('mime', split '/', "$mt.xml") ) ;
for my $file (@descfiles) {
$desc = ''; # if a file was found, return at least empty string
open XML, '<', $file || croak "Could not open file '$file' for reading";
binmode XML, ':utf8' unless $] < 5.008;
while (<XML>) {
next unless m!<comment\s*$att>(.*?)</comment>!;
$desc = $1;
last;
}
close XML || croak "Could not open file '$file' for reading";
last if $desc;
}
return $desc;
shift if ref $_[0];
my ($mt, $lang) = @_;
croak 'subroutine "describe" needs a mimetype as argument' unless $mt;
$mt = mimetype_canon($mt);
$lang = $LANG unless defined $lang;
my $att = $lang ? qq{xml:lang="$lang"} : '';
my $desc;
my @descfiles = @DIRS
? ( grep {-e $_ && -r $_} map "$_/$mt.xml", @DIRS )
: ( reverse data_files('mime', split '/', "$mt.xml") ) ;
for my $file (@descfiles) {
$desc = ''; # if a file was found, return at least empty string
open XML, '<', $file || croak "Could not open file '$file' for reading";
binmode XML, ':utf8' unless $] < 5.008;
while (<XML>) {
next unless m!<comment\s*$att>(.*?)</comment>!;
$desc = $1;
last;
}
close XML || croak "Could not open file '$file' for reading";
last if $desc;
}
return $desc;
}
sub mimetype_canon {
my $mimet = pop;
croak 'mimetype_canon needs argument' unless defined $mimet;
rehash_aliases() unless $_hashed_aliases;
return exists($aliases{$mimet}) ? $aliases{$mimet} : $mimet;
my $mimet = pop;
croak 'mimetype_canon needs argument' unless defined $mimet;
rehash_aliases() unless $_hashed_aliases;
return exists($aliases{$mimet}) ? $aliases{$mimet} : $mimet;
}
sub rehash_aliases {
%aliases = _read_map_files('aliases');
$_hashed_aliases++;
%aliases = _read_map_files('aliases');
$_hashed_aliases++;
}
sub _read_map_files {
my ($name, $list) = @_;
my @files = @DIRS
? ( grep {-e $_ && -r $_} map "$_/$name", @DIRS )
: ( reverse data_files("mime/$name") );
my (@done, %map);
for my $file (@files) {
next if grep {$_ eq $file} @done;
open MAP, '<', $file || croak "Could not open file '$file' for reading";
binmode MAP, ':utf8' unless $] < 5.008;
while (<MAP>) {
next if /^\s*#/ or ! /\S/; # skip comments and empty lines
chomp;
my ($k, $v) = split /\s+/, $_, 2;
if ($list) {
$map{$k} = [] unless $map{$k};
push @{$map{$k}}, $v;
}
else { $map{$k} = $v }
}
close MAP;
push @done, $file;
}
return %map;
my ($name, $list) = @_;
my @files = @DIRS
? ( grep {-e $_ && -r $_} map "$_/$name", @DIRS )
: ( reverse data_files("mime/$name") );
my (@done, %map);
for my $file (@files) {
next if grep {$_ eq $file} @done;
open MAP, '<', $file || croak "Could not open file '$file' for reading";
binmode MAP, ':utf8' unless $] < 5.008;
while (my $line = <MAP>) {
next unless $line =~ m/\S/; # skip empty lines
next if $line =~ m/^\s*#/; # skip comment lines
chomp $line;
my ($k, $v) = split m/\s+/, $line, 2;
if ($list) {
$map{$k} = [] unless $map{$k};
push @{$map{$k}}, $v;
}
else { $map{$k} = $v }
}
close MAP;
push @done, $file;
}
return %map;
}
sub mimetype_isa {
my $parent = pop || croak 'mimetype_isa needs argument';
my $mimet = pop;
if (ref $mimet or ! defined $mimet) {
$mimet = mimetype_canon($parent);
undef $parent;
}
else {
$mimet = mimetype_canon($mimet);
$parent = mimetype_canon($parent);
}
rehash_subclasses() unless $_hashed_subclasses;
my $parent = pop || croak 'mimetype_isa needs argument';
my $mimet = pop;
if (ref $mimet or ! defined $mimet) {
$mimet = mimetype_canon($parent);
undef $parent;
}
else {
$mimet = mimetype_canon($mimet);
$parent = mimetype_canon($parent);
}
rehash_subclasses() unless $_hashed_subclasses;
my @subc;
push @subc, 'inode/directory' if $mimet eq 'inode/mount-point';
push @subc, @{$subclasses{$mimet}} if exists $subclasses{$mimet};
push @subc, 'text/plain' if $mimet =~ m#^text/#;
push @subc, 'application/octet-stream' unless $mimet =~ m#^inode/#;
my @subc;
push @subc, 'inode/directory' if $mimet eq 'inode/mount-point';
push @subc, @{$subclasses{$mimet}} if exists $subclasses{$mimet};
push @subc, 'text/plain' if $mimet =~ m#^text/#;
push @subc, 'application/octet-stream' unless $mimet =~ m#^inode/#;
return $parent ? scalar(grep {$_ eq $parent} @subc) : @subc;
return $parent ? scalar(grep {$_ eq $parent} @subc) : @subc;
}
sub rehash_subclasses {
%subclasses = _read_map_files('subclasses', 'LIST');
$_hashed_subclasses++;
%subclasses = _read_map_files('subclasses', 'LIST');
$_hashed_subclasses++;
}
1;
@ -283,12 +301,13 @@ __END__
=head1 NAME
File::MimeInfo - Determine file type
File::MimeInfo - Determine file type from the file name
=head1 SYNOPSIS
use File::MimeInfo;
my $mime_type = mimetype($file);
my $mime_type2 = mimetype('test.png');
=head1 DESCRIPTION
@ -398,6 +417,15 @@ the first one.
This method checks the subclasses table and applies a few rules for implicit
subclasses.
=item C<has_mimeinfo_database()>
Check if there are mimeinfo database files available; returns 1 on success.
If you don't have the shared-mime-info package installed or not in the PATH or
C<@File::MimeInfo::DIRS> does not contain database directories, you will not get
the successful reply.
New in version 0.30.
=item C<rehash()>
Rehash the data files. Glob information is preparsed when this method is called.
@ -443,10 +471,18 @@ in a straightforward manner only utf8 is supported (because the spec recommends
This module does not yet check extended attributes for a mimetype.
Patches for this are very welcome.
This module uses the FreeDesktop.org shared mime info database. On your desktop
linux this is typically pre-installed so it's not a problem. On your server
you can install the shared-mime-info package via apt or dnf or apk or whatnot.
To install on macOS, you can install it like this:
brew install shared-mime-info
=head1 AUTHOR
Jaap Karssenberg E<lt>pardus@cpan.orgE<gt>
Maintained by Michiel Beijen E<lt>michiel.beijen@gmail.comE<gt>
Maintained by Michiel Beijen E<lt>mb@x14.nlE<gt>
=head1 COPYRIGHT

234
vendor_perl/JSON/PP.pm
View File

@ -14,7 +14,7 @@ use JSON::PP::Boolean;
use Carp ();
#use Devel::Peek;
$JSON::PP::VERSION = '4.04';
$JSON::PP::VERSION = '4.12';
@JSON::PP::EXPORT = qw(encode_json decode_json from_json to_json);
@ -46,6 +46,18 @@ use constant P_ALLOW_TAGS => 19;
use constant OLD_PERL => $] < 5.008 ? 1 : 0;
use constant USE_B => $ENV{PERL_JSON_PP_USE_B} || 0;
use constant CORE_BOOL => defined &builtin::is_bool;
my $invalid_char_re;
BEGIN {
$invalid_char_re = "[";
for my $i (0 .. 0x01F, 0x22, 0x5c) { # '/' is ok
$invalid_char_re .= quotemeta chr utf8::unicode_to_native($i);
}
$invalid_char_re = qr/$invalid_char_re]/;
}
BEGIN {
if (USE_B) {
@ -201,12 +213,52 @@ sub boolean_values {
my ($false, $true) = @_;
$self->{false} = $false;
$self->{true} = $true;
return ($false, $true);
if (CORE_BOOL) {
BEGIN { CORE_BOOL and warnings->unimport(qw(experimental::builtin)) }
if (builtin::is_bool($true) && builtin::is_bool($false) && $true && !$false) {
$self->{core_bools} = !!1;
}
else {
delete $self->{core_bools};
}
}
} else {
delete $self->{false};
delete $self->{true};
return;
delete $self->{core_bools};
}
return $self;
}
sub core_bools {
my $self = shift;
my $core_bools = defined $_[0] ? $_[0] : 1;
if ($core_bools) {
$self->{true} = !!1;
$self->{false} = !!0;
$self->{core_bools} = !!1;
}
else {
$self->{true} = $JSON::PP::true;
$self->{false} = $JSON::PP::false;
$self->{core_bools} = !!0;
}
return $self;
}
sub get_core_bools {
my $self = shift;
return !!$self->{core_bools};
}
sub unblessed_bool {
my $self = shift;
return $self->core_bools(@_);
}
sub get_unblessed_bool {
my $self = shift;
return $self->get_core_bools(@_);
}
sub get_boolean_values {
@ -327,14 +379,6 @@ sub allow_bigint {
$str .= "\n" if ( $indent ); # JSON::XS 2.26 compatible
unless ($ascii or $latin1 or $utf8) {
utf8::upgrade($str);
}
if ($props->[ P_SHRINK ]) {
utf8::downgrade($str, 1);
}
return $str;
}
@ -477,7 +521,11 @@ sub allow_bigint {
my $type = ref($value);
if (!$type) {
if (_looks_like_number($value)) {
BEGIN { CORE_BOOL and warnings->unimport('experimental::builtin') }
if (CORE_BOOL && builtin::is_bool($value)) {
return $value ? 'true' : 'false';
}
elsif (_looks_like_number($value)) {
return $value;
}
return $self->string_to_json($value);
@ -528,9 +576,11 @@ sub allow_bigint {
sub string_to_json {
my ($self, $arg) = @_;
$arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g;
$arg =~ s/(["\\\n\r\t\f\b])/$esc{$1}/g;
$arg =~ s/\//\\\//g if ($escape_slash);
$arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg;
# On ASCII platforms, matches [\x00-\x08\x0b\x0e-\x1f]
$arg =~ s/([^\n\t\c?[:^cntrl:][:^ascii:]])/'\\u00' . unpack('H2', $1)/eg;
if ($ascii) {
$arg = JSON_PP_encode_ascii($arg);
@ -605,7 +655,7 @@ sub allow_bigint {
sub _encode_ascii {
join('',
map {
$_ <= 127 ?
chr($_) =~ /[[:ascii:]]/ ?
chr($_) :
$_ <= 65535 ?
sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
@ -659,11 +709,11 @@ BEGIN {
{ # PARSE
my %escapes = ( # by Jeremy Muhlich <jmuhlich [at] bitflood.org>
b => "\x8",
t => "\x9",
n => "\xA",
f => "\xC",
r => "\xD",
b => "\b",
t => "\t",
n => "\n",
f => "\f",
r => "\r",
'\\' => '\\',
'"' => '"',
'/' => '/',
@ -737,7 +787,6 @@ BEGIN {
}
}
else {
utf8::upgrade( $text );
utf8::encode( $text );
}
@ -854,7 +903,8 @@ BEGIN {
decode_error("surrogate pair expected");
}
if ( ( my $hex = hex( $u ) ) > 127 ) {
my $hex = hex( $u );
if ( chr $u =~ /[[:^ascii:]]/ ) {
$is_utf8 = 1;
$s .= JSON_PP_decode_unicode($u) || next;
}
@ -874,7 +924,7 @@ BEGIN {
}
else{
if ( ord $ch > 127 ) {
if ( $ch =~ /[[:^ascii:]]/ ) {
unless( $ch = is_valid_utf8($ch) ) {
$at -= 1;
decode_error("malformed UTF-8 character in JSON string");
@ -887,10 +937,12 @@ BEGIN {
}
if (!$loose) {
if ($ch =~ /[\x00-\x1f\x22\x5c]/) { # '/' ok
if ($ch =~ $invalid_char_re) { # '/' ok
if (!$relaxed or $ch ne "\t") {
$at--;
decode_error('invalid character encountered while parsing JSON string');
decode_error(sprintf "invalid character 0x%X"
. " encountered while parsing JSON string",
ord $ch);
}
}
}
@ -1103,7 +1155,7 @@ BEGIN {
sub bareKey { # doesn't strictly follow Standard ECMA-262 3rd Edition
my $key;
while($ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){
while($ch =~ /[\$\w[:^ascii:]]/){
$key .= $ch;
next_chr();
}
@ -1236,31 +1288,55 @@ BEGIN {
return $is_dec ? $v/1.0 : 0+$v;
}
# Compute how many bytes are in the longest legal official Unicode
# character
my $max_unicode_length = do {
BEGIN { $] >= 5.006 and require warnings and warnings->unimport('utf8') }
chr 0x10FFFF;
};
utf8::encode($max_unicode_length);
$max_unicode_length = length $max_unicode_length;
sub is_valid_utf8 {
$utf8_len = $_[0] =~ /[\x00-\x7F]/ ? 1
: $_[0] =~ /[\xC2-\xDF]/ ? 2
: $_[0] =~ /[\xE0-\xEF]/ ? 3
: $_[0] =~ /[\xF0-\xF4]/ ? 4
: 0
;
# Returns undef (setting $utf8_len to 0) unless the next bytes in $text
# comprise a well-formed UTF-8 encoded character, in which case,
# return those bytes, setting $utf8_len to their count.
return unless $utf8_len;
my $start_point = substr($text, $at - 1);
my $is_valid_utf8 = substr($text, $at - 1, $utf8_len);
# Look no further than the maximum number of bytes in a single
# character
my $limit = $max_unicode_length;
$limit = length($start_point) if $limit > length($start_point);
return ( $is_valid_utf8 =~ /^(?:
[\x00-\x7F]
|[\xC2-\xDF][\x80-\xBF]
|[\xE0][\xA0-\xBF][\x80-\xBF]
|[\xE1-\xEC][\x80-\xBF][\x80-\xBF]
|[\xED][\x80-\x9F][\x80-\xBF]
|[\xEE-\xEF][\x80-\xBF][\x80-\xBF]
|[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF]
|[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF]
|[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF]
)$/x ) ? $is_valid_utf8 : '';
# Find the number of bytes comprising the first character in $text
# (without having to know the details of its internal representation).
# This loop will iterate just once on well-formed input.
while ($limit > 0) { # Until we succeed or exhaust the input
my $copy = substr($start_point, 0, $limit);
# decode() will return true if all bytes are valid; false
# if any aren't.
if (utf8::decode($copy)) {
# Is valid: get the first character, convert back to bytes,
# and return those bytes.
$copy = substr($copy, 0, 1);
utf8::encode($copy);
$utf8_len = length $copy;
return substr($start_point, 0, $utf8_len);
}
# If it didn't work, it could be that there is a full legal character
# followed by a partial or malformed one. Narrow the window and
# try again.
$limit--;
}
# Failed to find a legal UTF-8 character.
$utf8_len = 0;
return;
}
@ -1279,14 +1355,14 @@ BEGIN {
}
for my $c ( unpack( $type, $str ) ) { # emulate pv_uni_display() ?
$mess .= $c == 0x07 ? '\a'
: $c == 0x09 ? '\t'
: $c == 0x0a ? '\n'
: $c == 0x0d ? '\r'
: $c == 0x0c ? '\f'
: $c < 0x20 ? sprintf('\x{%x}', $c)
: $c == 0x5c ? '\\\\'
: $c < 0x80 ? chr($c)
my $chr_c = chr($c);
$mess .= $chr_c eq '\\' ? '\\\\'
: $chr_c =~ /[[:print:]]/ ? $chr_c
: $chr_c eq '\a' ? '\a'
: $chr_c eq '\t' ? '\t'
: $chr_c eq '\n' ? '\n'
: $chr_c eq '\r' ? '\r'
: $chr_c eq '\f' ? '\f'
: sprintf('\x{%x}', $c)
;
if ( length $mess >= 20 ) {
@ -1494,7 +1570,20 @@ BEGIN {
$JSON::PP::true = do { bless \(my $dummy = 1), "JSON::PP::Boolean" };
$JSON::PP::false = do { bless \(my $dummy = 0), "JSON::PP::Boolean" };
sub is_bool { blessed $_[0] and ( $_[0]->isa("JSON::PP::Boolean") or $_[0]->isa("Types::Serialiser::BooleanBase") or $_[0]->isa("JSON::XS::Boolean") ); }
sub is_bool {
if (blessed $_[0]) {
return (
$_[0]->isa("JSON::PP::Boolean")
or $_[0]->isa("Types::Serialiser::BooleanBase")
or $_[0]->isa("JSON::XS::Boolean")
);
}
elsif (CORE_BOOL) {
BEGIN { CORE_BOOL and warnings->unimport('experimental::builtin') }
return builtin::is_bool($_[0]);
}
return !!0;
}
sub true { $JSON::PP::true }
sub false { $JSON::PP::false }
@ -1535,10 +1624,6 @@ sub incr_parse {
$self->{incr_text} = '' unless ( defined $self->{incr_text} );
if ( defined $text ) {
if ( utf8::is_utf8( $text ) and !utf8::is_utf8( $self->{incr_text} ) ) {
utf8::upgrade( $self->{incr_text} ) ;
utf8::decode( $self->{incr_text} ) ;
}
$self->{incr_text} .= $text;
}
@ -1564,6 +1649,10 @@ sub incr_parse {
}
}
unless ( $coder->get_utf8 ) {
utf8::decode( $self->{incr_text} );
}
my ($obj, $offset) = $coder->PP_decode_json( $self->{incr_text}, 0x00000001 );
push @ret, $obj;
use bytes;
@ -1601,7 +1690,7 @@ INCR_PARSE:
while ( $len > $p ) {
$s = substr( $text, $p, 1 );
last INCR_PARSE unless defined $s;
if ( ord($s) > 0x20 ) {
if ( ord($s) > ord " " ) {
if ( $s eq '#' ) {
$self->{incr_mode} = INCR_M_C0;
redo INCR_PARSE;
@ -1628,6 +1717,7 @@ INCR_PARSE:
}
next;
} elsif ( $mode == INCR_M_TFN ) {
last INCR_PARSE if $p >= $len && $self->{incr_nest};
while ( $len > $p ) {
$s = substr( $text, $p++, 1 );
next if defined $s and $s =~ /[rueals]/;
@ -1639,6 +1729,7 @@ INCR_PARSE:
last INCR_PARSE unless $self->{incr_nest};
redo INCR_PARSE;
} elsif ( $mode == INCR_M_NUM ) {
last INCR_PARSE if $p >= $len && $self->{incr_nest};
while ( $len > $p ) {
$s = substr( $text, $p++, 1 );
next if defined $s and $s =~ /[0-9eE.+\-]/;
@ -1675,7 +1766,7 @@ INCR_PARSE:
if ( $s eq "\x00" ) {
$p--;
last INCR_PARSE;
} elsif ( $s eq "\x09" or $s eq "\x0a" or $s eq "\x0d" or $s eq "\x20" ) {
} elsif ( $s =~ /^[\t\n\r ]$/) {
if ( !$self->{incr_nest} ) {
$p--; # do not eat the whitespace, let the next round do it
last INCR_PARSE;
@ -1771,10 +1862,6 @@ JSON::PP - JSON::XS compatible pure-Perl module.
use JSON;
=head1 VERSION
4.04
=head1 DESCRIPTION
JSON::PP is a pure perl JSON decoder/encoder, and (almost) compatible to much
@ -1834,6 +1921,9 @@ Returns true if the passed scalar represents either JSON::PP::true or
JSON::PP::false, two constants that act like C<1> and C<0> respectively
and are also used to represent JSON C<true> and C<false> in Perl strings.
On perl 5.36 and above, will also return true when given one of perl's
standard boolean values, such as the result of a comparison.
See L<MAPPING>, below, for more information on how JSON values are mapped to
Perl.
@ -2250,6 +2340,22 @@ to their default values.
C<get_boolean_values> will return both C<$false> and C<$true> values, or
the empty list when they are set to the default.
=head2 core_bools
$json->core_bools([$enable]);
If C<$enable> is true (or missing), then C<decode>, will produce standard
perl boolean values. Equivalent to calling:
$json->boolean_values(!!1, !!0)
C<get_core_bools> will return true if this has been set. On perl 5.36, it will
also return true if the boolean values have been set to perl's core booleans
using the C<boolean_values> method.
The methods C<unblessed_bool> and C<get_unblessed_bool> are provided as aliases
for compatibility with L<Cpanel::JSON::XS>.
=head2 filter_json_object
$json = $json->filter_json_object([$coderef])

3
vendor_perl/JSON/PP/Boolean.pm
View File

@ -3,6 +3,7 @@ package JSON::PP::Boolean;
use strict;
require overload;
local $^W;
overload::unimport('overload', qw(0+ ++ -- fallback));
overload::import('overload',
"0+" => sub { ${$_[0]} },
"++" => sub { $_[0] = ${$_[0]} + 1 },
@ -10,7 +11,7 @@ overload::import('overload',
fallback => 1,
);
$JSON::PP::Boolean::VERSION = '4.04';
$JSON::PP::Boolean::VERSION = '4.12';
1;