From 745261d663bc43bb8a3c9d0a113d694ad9195cd6 Mon Sep 17 00:00:00 2001 From: iliajie Date: Thu, 17 Nov 2022 14:25:44 +0200 Subject: [PATCH] Update all `vendor_perl` modules from upstream (MetaCPAN) --- vendor_perl/Async.pm | 247 ++++++++++--------- vendor_perl/File/BaseDir.pm | 304 +++++++++++++---------- vendor_perl/File/Find.pm | 45 ++-- vendor_perl/File/MimeInfo.pm | 436 ++++++++++++++++++--------------- vendor_perl/JSON/PP.pm | 234 +++++++++++++----- vendor_perl/JSON/PP/Boolean.pm | 3 +- 6 files changed, 734 insertions(+), 535 deletions(-) diff --git a/vendor_perl/Async.pm b/vendor_perl/Async.pm index e5508edad..529a80bf6 100644 --- a/vendor_perl/Async.pm +++ b/vendor_perl/Async.pm @@ -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 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 +code is executing. This separate code is called an I. + +=head1 INTERFACE + +To check if the asynchronous computation is complete you can call +the C 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 will return C if the computation completed normally, and an error message otherwise. Data returned by the computation can be retrieved with the C -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 will return an undefined value. -C takes an optional parameter, C<$force>. If C<$force> is +C 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 use Async; - $proc = AsyncTimeout->new(sub {...}, $timeout, $special); + $proc = AsyncTimeout->new( sub { ... }, $timeout, $special ); -C implements a version of C that has an -automatic timeout. If the asynchronous computation does not complete +C implements a version of C 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 are exactly the same as for @@ -193,10 +208,10 @@ C. =head2 C use Async; - $proc = AsyncData->new(sub {...}); + $proc = AsyncData->new( sub { ... } ); C is just like C 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 method will yield a refernce to a copy of this data structure. @@ -206,15 +221,13 @@ C will die if C is unavailable. All the other methods for C are exactly the same as for C. - - =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, 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 mechanism are: those that are internal to C itself: +The errors that are reported by the C mechanism are: those that are internal to C 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 will go to the +considered to be an I; that is the normal termination of the +process. Any messages written to C will go to the computation's C, which is normally inherited from the main program, and the C will be the empty string. @@ -239,25 +252,25 @@ program, and the C 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 will be the empty string. =head1 AUTHOR -Mark-Jason Dominus C. +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 diff --git a/vendor_perl/File/BaseDir.pm b/vendor_perl/File/BaseDir.pm index e225fa596..75e4a440e 100644 --- a/vendor_perl/File/BaseDir.pm +++ b/vendor_perl/File/BaseDir.pm @@ -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. 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 +=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 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 + 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 +=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 +=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 +=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 +=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 +=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 +=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 + # :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 +=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, F. -=item C +=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 +=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. -=item C +=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 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 to set $HOME before loading File::BaseDir. +The use of L 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 and C are exported for backwards compatibility with version 0.02. They are identical to C and C respectively but without the C behavior. -=head1 BUGS +=head1 AUTHORS -Please mail the author if you encounter any bugs. +=over 4 -=head1 AUTHOR +=item * -Jaap Karssenberg || Pardus [Larus] Epardus@cpan.orgE +Jaap Karssenberg || Pardus [Larus] -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 -=head1 SEE ALSO +=back -L +=head1 COPYRIGHT AND LICENSE +This software is copyright (c) 2003-2021 by Jaap Karssenberg || Pardus [Larus] . + +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 diff --git a/vendor_perl/File/Find.pm b/vendor_perl/File/Find.pm index 4c67e882a..ae58d00b7 100644 --- a/vendor_perl/File/Find.pm +++ b/vendor_perl/File/Find.pm @@ -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 works from the top of the tree down. =back +Despite the name of the C function, both C and +C perform a depth-first search of the directory hierarchy. + =head2 %options The first argument to C is either a code reference to your @@ -849,7 +852,7 @@ code reference is described in L below. Here are the possible keys for the hash: -=over 3 +=over 4 =item C @@ -893,7 +896,7 @@ This might be expensive both in space and time for a large directory tree. See L and L below. If either I or I 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 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 function, both C and -C perform a depth-first search of the directory -hierarchy. - =head1 HISTORY File::Find used to produce incorrect results if called recursively. diff --git a/vendor_perl/File/MimeInfo.pm b/vendor_perl/File/MimeInfo.pm index 506fe07e7..214d1b733 100644 --- a/vendor_perl/File/MimeInfo.pm +++ b/vendor_perl/File/MimeInfo.pm @@ -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 () { - 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 () { + 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 () { - next unless m!(.*?)!; - $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 () { + next unless m!(.*?)!; + $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 () { - 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 = ) { + 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 + +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 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 Epardus@cpan.orgE -Maintained by Michiel Beijen Emichiel.beijen@gmail.comE +Maintained by Michiel Beijen Emb@x14.nlE =head1 COPYRIGHT diff --git a/vendor_perl/JSON/PP.pm b/vendor_perl/JSON/PP.pm index 9f0835428..732c5339d 100644 --- a/vendor_perl/JSON/PP.pm +++ b/vendor_perl/JSON/PP.pm @@ -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 - 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 and C 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, below, for more information on how JSON values are mapped to Perl. @@ -2250,6 +2340,22 @@ to their default values. C 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, will produce standard +perl boolean values. Equivalent to calling: + + $json->boolean_values(!!1, !!0) + +C 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 method. + +The methods C and C are provided as aliases +for compatibility with L. + =head2 filter_json_object $json = $json->filter_json_object([$coderef]) diff --git a/vendor_perl/JSON/PP/Boolean.pm b/vendor_perl/JSON/PP/Boolean.pm index 8ef6949da..66f7e516f 100644 --- a/vendor_perl/JSON/PP/Boolean.pm +++ b/vendor_perl/JSON/PP/Boolean.pm @@ -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;