[Bps-public-commit] rt-authen-token branch, master, updated. bf797b1a701a5f99e2ce9ac35e1960df0d5cd97d
Jim Brandt
jbrandt at bestpractical.com
Wed Sep 6 16:45:41 EDT 2017
The branch, master has been updated
via bf797b1a701a5f99e2ce9ac35e1960df0d5cd97d (commit)
via d26bdddcbc570c48348f06c3eb6d151e99a08052 (commit)
from 69394050cc19d586f0ab40c88a6ee29c87973bb4 (commit)
Summary of changes:
Changes | 5 +
MANIFEST | 2 +-
META.yml | 6 +-
inc/YAML/Tiny.pm | 694 ++++++++++++++++++++++++++++++++-----------------
inc/unicore/Name.pm | 416 -----------------------------
lib/RT/Authen/Token.pm | 2 +-
6 files changed, 468 insertions(+), 657 deletions(-)
create mode 100644 Changes
delete mode 100644 inc/unicore/Name.pm
- Log -----------------------------------------------------------------
commit d26bdddcbc570c48348f06c3eb6d151e99a08052
Author: Jim Brandt <jbrandt at bestpractical.com>
Date: Wed Sep 6 16:41:34 2017 -0400
Update Module::Install
diff --git a/inc/YAML/Tiny.pm b/inc/YAML/Tiny.pm
index 9a4e291..4fd023d 100644
--- a/inc/YAML/Tiny.pm
+++ b/inc/YAML/Tiny.pm
@@ -1,105 +1,217 @@
#line 1
-package YAML::Tiny;
-BEGIN {
- $YAML::Tiny::AUTHORITY = 'cpan:ADAMK';
+use 5.008001; # sane UTF-8 support
+use strict;
+use warnings;
+package YAML::Tiny; # git description: v1.69-8-g2c1e266
+# XXX-INGY is 5.8.1 too old/broken for utf8?
+# XXX-XDG Lancaster consensus was that it was sufficient until
+# proven otherwise
+
+our $VERSION = '1.70';
+
+#####################################################################
+# The YAML::Tiny API.
+#
+# These are the currently documented API functions/methods and
+# exports:
+
+use Exporter;
+our @ISA = qw{ Exporter };
+our @EXPORT = qw{ Load Dump };
+our @EXPORT_OK = qw{ LoadFile DumpFile freeze thaw };
+
+###
+# Functional/Export API:
+
+sub Dump {
+ return YAML::Tiny->new(@_)->_dump_string;
}
-{
- $YAML::Tiny::VERSION = '1.56';
+
+# XXX-INGY Returning last document seems a bad behavior.
+# XXX-XDG I think first would seem more natural, but I don't know
+# that it's worth changing now
+sub Load {
+ my $self = YAML::Tiny->_load_string(@_);
+ if ( wantarray ) {
+ return @$self;
+ } else {
+ # To match YAML.pm, return the last document
+ return $self->[-1];
+ }
}
-# git description: v1.55-3-gc945058
+# XXX-INGY Do we really need freeze and thaw?
+# XXX-XDG I don't think so. I'd support deprecating them.
+BEGIN {
+ *freeze = \&Dump;
+ *thaw = \&Load;
+}
-use strict;
-use warnings;
+sub DumpFile {
+ my $file = shift;
+ return YAML::Tiny->new(@_)->_dump_file($file);
+}
-# UTF Support?
-sub HAVE_UTF8 () { $] >= 5.007003 }
-BEGIN {
- if ( HAVE_UTF8 ) {
- # The string eval helps hide this from Test::MinimumVersion
- eval "require utf8;";
- die "Failed to load UTF-8 support" if $@;
+sub LoadFile {
+ my $file = shift;
+ my $self = YAML::Tiny->_load_file($file);
+ if ( wantarray ) {
+ return @$self;
+ } else {
+ # Return only the last document to match YAML.pm,
+ return $self->[-1];
}
+}
- # Class structure
- require 5.004;
- require Exporter;
- require Carp;
- @YAML::Tiny::ISA = qw{ Exporter };
- @YAML::Tiny::EXPORT = qw{ Load Dump };
- @YAML::Tiny::EXPORT_OK = qw{ LoadFile DumpFile freeze thaw };
- # Error storage
- $YAML::Tiny::errstr = '';
+###
+# Object Oriented API:
+
+# Create an empty YAML::Tiny object
+# XXX-INGY Why do we use ARRAY object?
+# NOTE: I get it now, but I think it's confusing and not needed.
+# Will change it on a branch later, for review.
+#
+# XXX-XDG I don't support changing it yet. It's a very well-documented
+# "API" of YAML::Tiny. I'd support deprecating it, but Adam suggested
+# we not change it until YAML.pm's own OO API is established so that
+# users only have one API change to digest, not two
+sub new {
+ my $class = shift;
+ bless [ @_ ], $class;
+}
+
+# XXX-INGY It probably doesn't matter, and it's probably too late to
+# change, but 'read/write' are the wrong names. Read and Write
+# are actions that take data from storage to memory
+# characters/strings. These take the data to/from storage to native
+# Perl objects, which the terms dump and load are meant. As long as
+# this is a legacy quirk to YAML::Tiny it's ok, but I'd prefer not
+# to add new {read,write}_* methods to this API.
+
+sub read_string {
+ my $self = shift;
+ $self->_load_string(@_);
}
-# The character class of all characters we need to escape
-# NOTE: Inlined, since it's only used once
-# my $RE_ESCAPE = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f\"\n]';
+sub write_string {
+ my $self = shift;
+ $self->_dump_string(@_);
+}
+
+sub read {
+ my $self = shift;
+ $self->_load_file(@_);
+}
+
+sub write {
+ my $self = shift;
+ $self->_dump_file(@_);
+}
+
+
+
+
+#####################################################################
+# Constants
# Printed form of the unprintable characters in the lowest range
# of ASCII characters, listed by ASCII ordinal position.
my @UNPRINTABLE = qw(
- z x01 x02 x03 x04 x05 x06 a
- x08 t n v f r x0e x0f
+ 0 x01 x02 x03 x04 x05 x06 a
+ b t n v f r x0E x0F
x10 x11 x12 x13 x14 x15 x16 x17
- x18 x19 x1a e x1c x1d x1e x1f
+ x18 x19 x1A e x1C x1D x1E x1F
);
# Printable characters for escapes
my %UNESCAPES = (
- z => "\x00", a => "\x07", t => "\x09",
+ 0 => "\x00", z => "\x00", N => "\x85",
+ a => "\x07", b => "\x08", t => "\x09",
n => "\x0a", v => "\x0b", f => "\x0c",
r => "\x0d", e => "\x1b", '\\' => '\\',
);
-# Special magic boolean words
+# XXX-INGY
+# I(ngy) need to decide if these values should be quoted in
+# YAML::Tiny or not. Probably yes.
+
+# These 3 values have special meaning when unquoted and using the
+# default YAML schema. They need quotes if they are strings.
my %QUOTE = map { $_ => 1 } qw{
- null Null NULL
- y Y yes Yes YES n N no No NO
- true True TRUE false False FALSE
- on On ON off Off OFF
+ null true false
};
+# The commented out form is simpler, but overloaded the Perl regex
+# engine due to recursion and backtracking problems on strings
+# larger than 32,000ish characters. Keep it for reference purposes.
+# qr/\"((?:\\.|[^\"])*)\"/
+my $re_capture_double_quoted = qr/\"([^\\"]*(?:\\.[^\\"]*)*)\"/;
+my $re_capture_single_quoted = qr/\'([^\']*(?:\'\'[^\']*)*)\'/;
+# unquoted re gets trailing space that needs to be stripped
+my $re_capture_unquoted_key = qr/([^:]+(?::+\S(?:[^:]*|.*?(?=:)))*)(?=\s*\:(?:\s+|$))/;
+my $re_trailing_comment = qr/(?:\s+\#.*)?/;
+my $re_key_value_separator = qr/\s*:(?:\s+(?:\#.*)?|$)/;
+
#####################################################################
-# Implementation
+# YAML::Tiny Implementation.
+#
+# These are the private methods that do all the work. They may change
+# at any time.
-# Create an empty YAML::Tiny object
-sub new {
- my $class = shift;
- bless [ @_ ], $class;
-}
+
+###
+# Loader functions:
# Create an object from a file
-sub read {
+sub _load_file {
my $class = ref $_[0] ? ref shift : shift;
# Check the file
- my $file = shift or return $class->_error( 'You did not specify a file name' );
- return $class->_error( "File '$file' does not exist" ) unless -e $file;
- return $class->_error( "'$file' is a directory, not a file" ) unless -f _;
- return $class->_error( "Insufficient permissions to read '$file'" ) unless -r _;
-
- # Slurp in the file
- local $/ = undef;
- local *CFG;
- unless ( open(CFG, $file) ) {
- return $class->_error("Failed to open file '$file': $!");
+ my $file = shift or $class->_error( 'You did not specify a file name' );
+ $class->_error( "File '$file' does not exist" )
+ unless -e $file;
+ $class->_error( "'$file' is a directory, not a file" )
+ unless -f _;
+ $class->_error( "Insufficient permissions to read '$file'" )
+ unless -r _;
+
+ # Open unbuffered with strict UTF-8 decoding and no translation layers
+ open( my $fh, "<:unix:encoding(UTF-8)", $file );
+ unless ( $fh ) {
+ $class->_error("Failed to open file '$file': $!");
+ }
+
+ # flock if available (or warn if not possible for OS-specific reasons)
+ if ( _can_flock() ) {
+ flock( $fh, Fcntl::LOCK_SH() )
+ or warn "Couldn't lock '$file' for reading: $!";
+ }
+
+ # slurp the contents
+ my $contents = eval {
+ use warnings FATAL => 'utf8';
+ local $/;
+ <$fh>
+ };
+ if ( my $err = $@ ) {
+ $class->_error("Error reading from file '$file': $err");
}
- my $contents = <CFG>;
- unless ( close(CFG) ) {
- return $class->_error("Failed to close file '$file': $!");
+
+ # close the file (release the lock)
+ unless ( close $fh ) {
+ $class->_error("Failed to close file '$file': $!");
}
- $class->read_string( $contents );
+ $class->_load_string( $contents );
}
# Create an object from a string
-sub read_string {
+sub _load_string {
my $class = ref $_[0] ? ref shift : shift;
my $self = bless [], $class;
my $string = $_[0];
@@ -108,30 +220,23 @@ sub read_string {
die \"Did not provide a string to load";
}
- # Byte order marks
- # NOTE: Keeping this here to educate maintainers
- # my %BOM = (
- # "\357\273\277" => 'UTF-8',
- # "\376\377" => 'UTF-16BE',
- # "\377\376" => 'UTF-16LE',
- # "\377\376\0\0" => 'UTF-32LE'
- # "\0\0\376\377" => 'UTF-32BE',
- # );
- if ( $string =~ /^(?:\376\377|\377\376|\377\376\0\0|\0\0\376\377)/ ) {
- die \"Stream has a non UTF-8 BOM";
- } else {
- # Strip UTF-8 bom if found, we'll just ignore it
- $string =~ s/^\357\273\277//;
+ # Check if Perl has it marked as characters, but it's internally
+ # inconsistent. E.g. maybe latin1 got read on a :utf8 layer
+ if ( utf8::is_utf8($string) && ! utf8::valid($string) ) {
+ die \<<'...';
+Read an invalid UTF-8 string (maybe mixed UTF-8 and 8-bit character set).
+Did you decode with lax ":utf8" instead of strict ":encoding(UTF-8)"?
+...
}
- # Try to decode as utf8
- utf8::decode($string) if HAVE_UTF8;
+ # Ensure Unicode character semantics, even for 0x80-0xff
+ utf8::upgrade($string);
+
+ # Check for and strip any leading UTF-8 BOM
+ $string =~ s/^\x{FEFF}//;
# Check for some special cases
return $self unless length $string;
- unless ( $string =~ /[\012\015]+\z/ ) {
- die \"Stream does not end with newline character";
- }
# Split the file into lines
my @lines = grep { ! /^\s*(?:\#.*)?\z/ }
@@ -141,15 +246,18 @@ sub read_string {
@lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines;
# A nibbling parser
+ my $in_document = 0;
while ( @lines ) {
# Do we have a document header?
if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) {
# Handle scalar documents
shift @lines;
if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) {
- push @$self, $self->_read_scalar( "$1", [ undef ], \@lines );
+ push @$self,
+ $self->_load_scalar( "$1", [ undef ], \@lines );
next;
}
+ $in_document = 1;
}
if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) {
@@ -158,36 +266,65 @@ sub read_string {
while ( @lines and $lines[0] !~ /^---/ ) {
shift @lines;
}
+ $in_document = 0;
- } elsif ( $lines[0] =~ /^\s*\-/ ) {
+ # XXX The final '-+$' is to look for -- which ends up being an
+ # error later.
+ } elsif ( ! $in_document && @$self ) {
+ # only the first document can be explicit
+ die \"YAML::Tiny failed to classify the line '$lines[0]'";
+ } elsif ( $lines[0] =~ /^\s*\-(?:\s|$|-+$)/ ) {
# An array at the root
my $document = [ ];
push @$self, $document;
- $self->_read_array( $document, [ 0 ], \@lines );
+ $self->_load_array( $document, [ 0 ], \@lines );
} elsif ( $lines[0] =~ /^(\s*)\S/ ) {
# A hash at the root
my $document = { };
push @$self, $document;
- $self->_read_hash( $document, [ length($1) ], \@lines );
+ $self->_load_hash( $document, [ length($1) ], \@lines );
} else {
+ # Shouldn't get here. @lines have whitespace-only lines
+ # stripped, and previous match is a line with any
+ # non-whitespace. So this clause should only be reachable via
+ # a perlbug where \s is not symmetric with \S
+
+ # uncoverable statement
die \"YAML::Tiny failed to classify the line '$lines[0]'";
}
}
};
- if ( ref $@ eq 'SCALAR' ) {
- return $self->_error(${$@});
- } elsif ( $@ ) {
- require Carp;
- Carp::croak($@);
+ my $err = $@;
+ if ( ref $err eq 'SCALAR' ) {
+ $self->_error(${$err});
+ } elsif ( $err ) {
+ $self->_error($err);
}
return $self;
}
-# Deparse a scalar string to the actual scalar
-sub _read_scalar {
+sub _unquote_single {
+ my ($self, $string) = @_;
+ return '' unless length $string;
+ $string =~ s/\'\'/\'/g;
+ return $string;
+}
+
+sub _unquote_double {
+ my ($self, $string) = @_;
+ return '' unless length $string;
+ $string =~ s/\\"/"/g;
+ $string =~
+ s{\\([Nnever\\fartz0b]|x([0-9a-fA-F]{2}))}
+ {(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}}gex;
+ return $string;
+}
+
+# Load a YAML scalar string to the actual Perl scalar
+sub _load_scalar {
my ($self, $string, $indent, $lines) = @_;
# Trim trailing whitespace
@@ -197,25 +334,13 @@ sub _read_scalar {
return undef if $string eq '~';
# Single quote
- if ( $string =~ /^\'(.*?)\'(?:\s+\#.*)?\z/ ) {
- return '' unless defined $1;
- $string = $1;
- $string =~ s/\'\'/\'/g;
- return $string;
+ if ( $string =~ /^$re_capture_single_quoted$re_trailing_comment\z/ ) {
+ return $self->_unquote_single($1);
}
# Double quote.
- # The commented out form is simpler, but overloaded the Perl regex
- # engine due to recursion and backtracking problems on strings
- # larger than 32,000ish characters. Keep it for reference purposes.
- # if ( $string =~ /^\"((?:\\.|[^\"])*)\"\z/ ) {
- if ( $string =~ /^\"([^\\"]*(?:\\.[^\\"]*)*)\"(?:\s+\#.*)?\z/ ) {
- # Reusing the variable is a little ugly,
- # but avoids a new variable and a string copy.
- $string = $1;
- $string =~ s/\\"/"/g;
- $string =~ s/\\([never\\fartz]|x([0-9a-fA-F]{2}))/(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}/gex;
- return $string;
+ if ( $string =~ /^$re_capture_double_quoted$re_trailing_comment\z/ ) {
+ return $self->_unquote_double($1);
}
# Special cases
@@ -227,13 +352,9 @@ sub _read_scalar {
# Regular unquoted string
if ( $string !~ /^[>|]/ ) {
- if (
- $string =~ /^(?:-(?:\s|$)|[\@\%\`])/
- or
- $string =~ /:(?:\s|$)/
- ) {
- die \"YAML::Tiny found illegal characters in plain scalar: '$string'";
- }
+ die \"YAML::Tiny found illegal characters in plain scalar: '$string'"
+ if $string =~ /^(?:-(?:\s|$)|[\@\%\`])/ or
+ $string =~ /:(?:\s|$)/;
$string =~ s/\s+#.*\z//;
return $string;
}
@@ -261,8 +382,8 @@ sub _read_scalar {
return join( $j, @multiline ) . $t;
}
-# Parse an array
-sub _read_array {
+# Load an array
+sub _load_array {
my ($self, $array, $indent, $lines) = @_;
while ( @$lines ) {
@@ -287,12 +408,7 @@ sub _read_array {
my $indent2 = length("$1");
$lines->[0] =~ s/-/ /;
push @$array, { };
- $self->_read_hash( $array->[-1], [ @$indent, $indent2 ], $lines );
-
- } elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) {
- # Array entry with a value
- shift @$lines;
- push @$array, $self->_read_scalar( "$2", [ @$indent, undef ], $lines );
+ $self->_load_hash( $array->[-1], [ @$indent, $indent2 ], $lines );
} elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) {
shift @$lines;
@@ -308,17 +424,28 @@ sub _read_array {
} else {
# Naked indenter
push @$array, [ ];
- $self->_read_array( $array->[-1], [ @$indent, $indent2 ], $lines );
+ $self->_load_array(
+ $array->[-1], [ @$indent, $indent2 ], $lines
+ );
}
} elsif ( $lines->[0] =~ /^(\s*)\S/ ) {
push @$array, { };
- $self->_read_hash( $array->[-1], [ @$indent, length("$1") ], $lines );
+ $self->_load_hash(
+ $array->[-1], [ @$indent, length("$1") ], $lines
+ );
} else {
die \"YAML::Tiny failed to classify line '$lines->[0]'";
}
+ } elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) {
+ # Array entry with a value
+ shift @$lines;
+ push @$array, $self->_load_scalar(
+ "$2", [ @$indent, undef ], $lines
+ );
+
} elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) {
# This is probably a structure like the following...
# ---
@@ -337,8 +464,8 @@ sub _read_array {
return 1;
}
-# Parse an array
-sub _read_hash {
+# Load a hash
+sub _load_hash {
my ($self, $hash, $indent, $lines) = @_;
while ( @$lines ) {
@@ -358,19 +485,43 @@ sub _read_hash {
die \"YAML::Tiny found bad indenting in line '$lines->[0]'";
}
- # Get the key
- unless ( $lines->[0] =~ s/^\s*([^\'\" ][^\n]*?)\s*:(\s+(?:\#.*)?|$)// ) {
- if ( $lines->[0] =~ /^\s*[?\'\"]/ ) {
- die \"YAML::Tiny does not support a feature in line '$lines->[0]'";
- }
+ # Find the key
+ my $key;
+
+ # Quoted keys
+ if ( $lines->[0] =~
+ s/^\s*$re_capture_single_quoted$re_key_value_separator//
+ ) {
+ $key = $self->_unquote_single($1);
+ }
+ elsif ( $lines->[0] =~
+ s/^\s*$re_capture_double_quoted$re_key_value_separator//
+ ) {
+ $key = $self->_unquote_double($1);
+ }
+ elsif ( $lines->[0] =~
+ s/^\s*$re_capture_unquoted_key$re_key_value_separator//
+ ) {
+ $key = $1;
+ $key =~ s/\s+$//;
+ }
+ elsif ( $lines->[0] =~ /^\s*\?/ ) {
+ die \"YAML::Tiny does not support a feature in line '$lines->[0]'";
+ }
+ else {
die \"YAML::Tiny failed to classify line '$lines->[0]'";
}
- my $key = $1;
+
+ if ( exists $hash->{$key} ) {
+ warn "YAML::Tiny found a duplicate key '$key' in line '$lines->[0]'";
+ }
# Do we have a value?
if ( length $lines->[0] ) {
# Yes
- $hash->{$key} = $self->_read_scalar( shift(@$lines), [ @$indent, undef ], $lines );
+ $hash->{$key} = $self->_load_scalar(
+ shift(@$lines), [ @$indent, undef ], $lines
+ );
} else {
# An indent
shift @$lines;
@@ -380,7 +531,9 @@ sub _read_hash {
}
if ( $lines->[0] =~ /^(\s*)-/ ) {
$hash->{$key} = [];
- $self->_read_array( $hash->{$key}, [ @$indent, length($1) ], $lines );
+ $self->_load_array(
+ $hash->{$key}, [ @$indent, length($1) ], $lines
+ );
} elsif ( $lines->[0] =~ /^(\s*)./ ) {
my $indent2 = length("$1");
if ( $indent->[-1] >= $indent2 ) {
@@ -388,7 +541,9 @@ sub _read_hash {
$hash->{$key} = undef;
} else {
$hash->{$key} = {};
- $self->_read_hash( $hash->{$key}, [ @$indent, length($1) ], $lines );
+ $self->_load_hash(
+ $hash->{$key}, [ @$indent, length($1) ], $lines
+ );
}
}
}
@@ -397,98 +552,159 @@ sub _read_hash {
return 1;
}
+
+###
+# Dumper functions:
+
# Save an object to a file
-sub write {
+sub _dump_file {
my $self = shift;
- my $file = shift or return $self->_error('No file name provided');
- # Write it to the file
- open( CFG, '>' . $file ) or return $self->_error(
- "Failed to open file '$file' for writing: $!"
- );
- print CFG $self->write_string;
- close CFG;
+ require Fcntl;
+
+ # Check the file
+ my $file = shift or $self->_error( 'You did not specify a file name' );
+
+ my $fh;
+ # flock if available (or warn if not possible for OS-specific reasons)
+ if ( _can_flock() ) {
+ # Open without truncation (truncate comes after lock)
+ my $flags = Fcntl::O_WRONLY()|Fcntl::O_CREAT();
+ sysopen( $fh, $file, $flags )
+ or $self->_error("Failed to open file '$file' for writing: $!");
+
+ # Use no translation and strict UTF-8
+ binmode( $fh, ":raw:encoding(UTF-8)");
+
+ flock( $fh, Fcntl::LOCK_EX() )
+ or warn "Couldn't lock '$file' for reading: $!";
+
+ # truncate and spew contents
+ truncate $fh, 0;
+ seek $fh, 0, 0;
+ }
+ else {
+ open $fh, ">:unix:encoding(UTF-8)", $file;
+ }
+
+ # serialize and spew to the handle
+ print {$fh} $self->_dump_string;
+
+ # close the file (release the lock)
+ unless ( close $fh ) {
+ $self->_error("Failed to close file '$file': $!");
+ }
return 1;
}
# Save an object to a string
-sub write_string {
+sub _dump_string {
my $self = shift;
- return '' unless @$self;
+ return '' unless ref $self && @$self;
# Iterate over the documents
my $indent = 0;
my @lines = ();
- foreach my $cursor ( @$self ) {
- push @lines, '---';
-
- # An empty document
- if ( ! defined $cursor ) {
- # Do nothing
-
- # A scalar document
- } elsif ( ! ref $cursor ) {
- $lines[-1] .= ' ' . $self->_write_scalar( $cursor, $indent );
-
- # A list at the root
- } elsif ( ref $cursor eq 'ARRAY' ) {
- unless ( @$cursor ) {
- $lines[-1] .= ' []';
- next;
- }
- push @lines, $self->_write_array( $cursor, $indent, {} );
- # A hash at the root
- } elsif ( ref $cursor eq 'HASH' ) {
- unless ( %$cursor ) {
- $lines[-1] .= ' {}';
- next;
- }
- push @lines, $self->_write_hash( $cursor, $indent, {} );
+ eval {
+ foreach my $cursor ( @$self ) {
+ push @lines, '---';
- } else {
- Carp::croak("Cannot serialize " . ref($cursor));
+ # An empty document
+ if ( ! defined $cursor ) {
+ # Do nothing
+
+ # A scalar document
+ } elsif ( ! ref $cursor ) {
+ $lines[-1] .= ' ' . $self->_dump_scalar( $cursor );
+
+ # A list at the root
+ } elsif ( ref $cursor eq 'ARRAY' ) {
+ unless ( @$cursor ) {
+ $lines[-1] .= ' []';
+ next;
+ }
+ push @lines, $self->_dump_array( $cursor, $indent, {} );
+
+ # A hash at the root
+ } elsif ( ref $cursor eq 'HASH' ) {
+ unless ( %$cursor ) {
+ $lines[-1] .= ' {}';
+ next;
+ }
+ push @lines, $self->_dump_hash( $cursor, $indent, {} );
+
+ } else {
+ die \("Cannot serialize " . ref($cursor));
+ }
}
+ };
+ if ( ref $@ eq 'SCALAR' ) {
+ $self->_error(${$@});
+ } elsif ( $@ ) {
+ $self->_error($@);
}
join '', map { "$_\n" } @lines;
}
-sub _write_scalar {
+sub _has_internal_string_value {
+ my $value = shift;
+ my $b_obj = B::svref_2object(\$value); # for round trip problem
+ return $b_obj->FLAGS & B::SVf_POK();
+}
+
+sub _dump_scalar {
my $string = $_[1];
+ my $is_key = $_[2];
+ # Check this before checking length or it winds up looking like a string!
+ my $has_string_flag = _has_internal_string_value($string);
return '~' unless defined $string;
return "''" unless length $string;
- if ( $string =~ /[\x00-\x08\x0b-\x0d\x0e-\x1f\"\'\n]/ ) {
+ if (Scalar::Util::looks_like_number($string)) {
+ # keys and values that have been used as strings get quoted
+ if ( $is_key || $has_string_flag ) {
+ return qq['$string'];
+ }
+ else {
+ return $string;
+ }
+ }
+ if ( $string =~ /[\x00-\x09\x0b-\x0d\x0e-\x1f\x7f-\x9f\'\n]/ ) {
$string =~ s/\\/\\\\/g;
$string =~ s/"/\\"/g;
$string =~ s/\n/\\n/g;
+ $string =~ s/[\x85]/\\N/g;
$string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g;
+ $string =~ s/([\x7f-\x9f])/'\x' . sprintf("%X",ord($1))/ge;
return qq|"$string"|;
}
- if ( $string =~ /(?:^\W|\s|:\z)/ or $QUOTE{$string} ) {
+ if ( $string =~ /(?:^[~!@#%&*|>?:,'"`{}\[\]]|^-+$|\s|:\z)/ or
+ $QUOTE{$string}
+ ) {
return "'$string'";
}
return $string;
}
-sub _write_array {
+sub _dump_array {
my ($self, $array, $indent, $seen) = @_;
if ( $seen->{refaddr($array)}++ ) {
- die "YAML::Tiny does not support circular references";
+ die \"YAML::Tiny does not support circular references";
}
my @lines = ();
foreach my $el ( @$array ) {
my $line = (' ' x $indent) . '-';
my $type = ref $el;
if ( ! $type ) {
- $line .= ' ' . $self->_write_scalar( $el, $indent + 1 );
+ $line .= ' ' . $self->_dump_scalar( $el );
push @lines, $line;
} elsif ( $type eq 'ARRAY' ) {
if ( @$el ) {
push @lines, $line;
- push @lines, $self->_write_array( $el, $indent + 1, $seen );
+ push @lines, $self->_dump_array( $el, $indent + 1, $seen );
} else {
$line .= ' []';
push @lines, $line;
@@ -497,38 +713,38 @@ sub _write_array {
} elsif ( $type eq 'HASH' ) {
if ( keys %$el ) {
push @lines, $line;
- push @lines, $self->_write_hash( $el, $indent + 1, $seen );
+ push @lines, $self->_dump_hash( $el, $indent + 1, $seen );
} else {
$line .= ' {}';
push @lines, $line;
}
} else {
- die "YAML::Tiny does not support $type references";
+ die \"YAML::Tiny does not support $type references";
}
}
@lines;
}
-sub _write_hash {
+sub _dump_hash {
my ($self, $hash, $indent, $seen) = @_;
if ( $seen->{refaddr($hash)}++ ) {
- die "YAML::Tiny does not support circular references";
+ die \"YAML::Tiny does not support circular references";
}
my @lines = ();
foreach my $name ( sort keys %$hash ) {
my $el = $hash->{$name};
- my $line = (' ' x $indent) . "$name:";
+ my $line = (' ' x $indent) . $self->_dump_scalar($name, 1) . ":";
my $type = ref $el;
if ( ! $type ) {
- $line .= ' ' . $self->_write_scalar( $el, $indent + 1 );
+ $line .= ' ' . $self->_dump_scalar( $el );
push @lines, $line;
} elsif ( $type eq 'ARRAY' ) {
if ( @$el ) {
push @lines, $line;
- push @lines, $self->_write_array( $el, $indent + 1, $seen );
+ push @lines, $self->_dump_array( $el, $indent + 1, $seen );
} else {
$line .= ' []';
push @lines, $line;
@@ -537,92 +753,87 @@ sub _write_hash {
} elsif ( $type eq 'HASH' ) {
if ( keys %$el ) {
push @lines, $line;
- push @lines, $self->_write_hash( $el, $indent + 1, $seen );
+ push @lines, $self->_dump_hash( $el, $indent + 1, $seen );
} else {
$line .= ' {}';
push @lines, $line;
}
} else {
- die "YAML::Tiny does not support $type references";
+ die \"YAML::Tiny does not support $type references";
}
}
@lines;
}
+
+
+#####################################################################
+# DEPRECATED API methods:
+
+# Error storage (DEPRECATED as of 1.57)
+our $errstr = '';
+
# Set error
sub _error {
- $YAML::Tiny::errstr = $_[1];
- undef;
+ require Carp;
+ $errstr = $_[1];
+ $errstr =~ s/ at \S+ line \d+.*//;
+ Carp::croak( $errstr );
}
# Retrieve error
+my $errstr_warned;
sub errstr {
- $YAML::Tiny::errstr;
+ require Carp;
+ Carp::carp( "YAML::Tiny->errstr and \$YAML::Tiny::errstr is deprecated" )
+ unless $errstr_warned++;
+ $errstr;
}
-
#####################################################################
-# YAML Compatibility
-
-sub Dump {
- YAML::Tiny->new(@_)->write_string;
-}
-
-sub Load {
- my $self = YAML::Tiny->read_string(@_);
- unless ( $self ) {
- Carp::croak("Failed to load YAML document from string");
- }
- if ( wantarray ) {
- return @$self;
- } else {
- # To match YAML.pm, return the last document
- return $self->[-1];
- }
-}
+# Helper functions. Possibly not needed.
-BEGIN {
- *freeze = *Dump;
- *thaw = *Load;
-}
-sub DumpFile {
- my $file = shift;
- YAML::Tiny->new(@_)->write($file);
-}
+# Use to detect nv or iv
+use B;
-sub LoadFile {
- my $self = YAML::Tiny->read($_[0]);
- unless ( $self ) {
- Carp::croak("Failed to load YAML document from '" . ($_[0] || '') . "'");
+# XXX-INGY Is flock YAML::Tiny's responsibility?
+# Some platforms can't flock :-(
+# XXX-XDG I think it is. When reading and writing files, we ought
+# to be locking whenever possible. People (foolishly) use YAML
+# files for things like session storage, which has race issues.
+my $HAS_FLOCK;
+sub _can_flock {
+ if ( defined $HAS_FLOCK ) {
+ return $HAS_FLOCK;
}
- if ( wantarray ) {
- return @$self;
- } else {
- # Return only the last document to match YAML.pm,
- return $self->[-1];
+ else {
+ require Config;
+ my $c = \%Config::Config;
+ $HAS_FLOCK = grep { $c->{$_} } qw/d_flock d_fcntl_can_lock d_lockf/;
+ require Fcntl if $HAS_FLOCK;
+ return $HAS_FLOCK;
}
}
-
-
-
+# XXX-INGY Is this core in 5.8.1? Can we remove this?
+# XXX-XDG Scalar::Util 1.18 didn't land until 5.8.8, so we need this
#####################################################################
# Use Scalar::Util if possible, otherwise emulate it
+use Scalar::Util ();
BEGIN {
local $@;
- eval {
- require Scalar::Util;
- };
- my $v = eval("$Scalar::Util::VERSION") || 0;
- if ( $@ or $v < 1.18 ) {
+ if ( eval { Scalar::Util->VERSION(1.18); } ) {
+ *refaddr = *Scalar::Util::refaddr;
+ }
+ else {
eval <<'END_PERL';
# Scalar::Util failed to load or too old
sub refaddr {
@@ -633,18 +844,29 @@ sub refaddr {
$pkg = undef;
}
"$_[0]" =~ /0x(\w+)/;
- my $i = do { local $^W; hex $1 };
+ my $i = do { no warnings 'portable'; hex $1 };
bless $_[0], $pkg if defined $pkg;
$i;
}
END_PERL
- } else {
- *refaddr = *Scalar::Util::refaddr;
}
}
+delete $YAML::Tiny::{refaddr};
+
1;
+# XXX-INGY Doc notes I'm putting up here. Changing the doc when it's wrong
+# but leaving grey area stuff up here.
+#
+# I would like to change Read/Write to Load/Dump below without
+# changing the actual API names.
+#
+# It might be better to put Load/Dump API in the SYNOPSIS instead of the
+# dubious OO API.
+#
+# null and bool explanations may be outdated.
+
__END__
-#line 1223
+#line 1487
diff --git a/inc/unicore/Name.pm b/inc/unicore/Name.pm
deleted file mode 100644
index 15e729b..0000000
--- a/inc/unicore/Name.pm
+++ /dev/null
@@ -1,416 +0,0 @@
-#line 1
-# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
-# This file is machine-generated by lib/unicore/mktables from the Unicode
-# database, Version 6.2.0. Any changes made here will be lost!
-
-
-# !!!!!!! INTERNAL PERL USE ONLY !!!!!!!
-# This file is for internal use by core Perl only. The format and even the
-# name or existence of this file are subject to change without notice. Don't
-# use it directly.
-
-
-package charnames;
-
-# This module contains machine-generated tables and code for the
-# algorithmically-determinable Unicode character names. The following
-# routines can be used to translate between name and code point and vice versa
-
-{ # Closure
-
- # Matches legal code point. 4-6 hex numbers, If there are 6, the first
- # two must be 10; if there are 5, the first must not be a 0. Written this
- # way to decrease backtracking. The first regex allows the code point to
- # be at the end of a word, but to work properly, the word shouldn't end
- # with a valid hex character. The second one won't match a code point at
- # the end of a word, and doesn't have the run-on issue
- my $run_on_code_point_re = qr/(?^aax: (?: 10[0-9A-F]{4} | [1-9A-F][0-9A-F]{4} | [0-9A-F]{4} ) \b)/;
- my $code_point_re = qr/(?^aa:\b(?^aax: (?: 10[0-9A-F]{4} | [1-9A-F][0-9A-F]{4} | [0-9A-F]{4} ) \b))/;
-
- # In the following hash, the keys are the bases of names which include
- # the code point in the name, like CJK UNIFIED IDEOGRAPH-4E01. The value
- # of each key is another hash which is used to get the low and high ends
- # for each range of code points that apply to the name.
- my %names_ending_in_code_point = (
-'CJK COMPATIBILITY IDEOGRAPH' =>
-{
-'high' =>
-[
-64109,
-64217,
-195101,
-],
-'low' =>
-[
-63744,
-64112,
-194560,
-],
-},
-'CJK UNIFIED IDEOGRAPH' =>
-{
-'high' =>
-[
-19893,
-40908,
-173782,
-177972,
-178205,
-],
-'low' =>
-[
-13312,
-19968,
-131072,
-173824,
-177984,
-],
-},
-
- );
-
- # The following hash is a copy of the previous one, except is for loose
- # matching, so each name has blanks and dashes squeezed out
- my %loose_names_ending_in_code_point = (
-'CJKCOMPATIBILITYIDEOGRAPH' =>
-{
-'high' =>
-[
-64109,
-64217,
-195101,
-],
-'low' =>
-[
-63744,
-64112,
-194560,
-],
-},
-'CJKUNIFIEDIDEOGRAPH' =>
-{
-'high' =>
-[
-19893,
-40908,
-173782,
-177972,
-178205,
-],
-'low' =>
-[
-13312,
-19968,
-131072,
-173824,
-177984,
-],
-},
-
- );
-
- # And the following array gives the inverse mapping from code points to
- # names. Lowest code points are first
- my @code_points_ending_in_code_point = (
-
-{
-'high' => 19893,
-'low' => 13312,
-'name' => 'CJK UNIFIED IDEOGRAPH',
-},
-{
-'high' => 40908,
-'low' => 19968,
-'name' => 'CJK UNIFIED IDEOGRAPH',
-},
-{
-'high' => 64109,
-'low' => 63744,
-'name' => 'CJK COMPATIBILITY IDEOGRAPH',
-},
-{
-'high' => 64217,
-'low' => 64112,
-'name' => 'CJK COMPATIBILITY IDEOGRAPH',
-},
-{
-'high' => 173782,
-'low' => 131072,
-'name' => 'CJK UNIFIED IDEOGRAPH',
-},
-{
-'high' => 177972,
-'low' => 173824,
-'name' => 'CJK UNIFIED IDEOGRAPH',
-},
-{
-'high' => 178205,
-'low' => 177984,
-'name' => 'CJK UNIFIED IDEOGRAPH',
-},
-{
-'high' => 195101,
-'low' => 194560,
-'name' => 'CJK COMPATIBILITY IDEOGRAPH',
-},
-,
-
- );
-
- # Convert from code point to Jamo short name for use in composing Hangul
- # syllable names
- my %Jamo = (
-4352 => 'G',
-4353 => 'GG',
-4354 => 'N',
-4355 => 'D',
-4356 => 'DD',
-4357 => 'R',
-4358 => 'M',
-4359 => 'B',
-4360 => 'BB',
-4361 => 'S',
-4362 => 'SS',
-4363 => '',
-4364 => 'J',
-4365 => 'JJ',
-4366 => 'C',
-4367 => 'K',
-4368 => 'T',
-4369 => 'P',
-4370 => 'H',
-4449 => 'A',
-4450 => 'AE',
-4451 => 'YA',
-4452 => 'YAE',
-4453 => 'EO',
-4454 => 'E',
-4455 => 'YEO',
-4456 => 'YE',
-4457 => 'O',
-4458 => 'WA',
-4459 => 'WAE',
-4460 => 'OE',
-4461 => 'YO',
-4462 => 'U',
-4463 => 'WEO',
-4464 => 'WE',
-4465 => 'WI',
-4466 => 'YU',
-4467 => 'EU',
-4468 => 'YI',
-4469 => 'I',
-4520 => 'G',
-4521 => 'GG',
-4522 => 'GS',
-4523 => 'N',
-4524 => 'NJ',
-4525 => 'NH',
-4526 => 'D',
-4527 => 'L',
-4528 => 'LG',
-4529 => 'LM',
-4530 => 'LB',
-4531 => 'LS',
-4532 => 'LT',
-4533 => 'LP',
-4534 => 'LH',
-4535 => 'M',
-4536 => 'B',
-4537 => 'BS',
-4538 => 'S',
-4539 => 'SS',
-4540 => 'NG',
-4541 => 'J',
-4542 => 'C',
-4543 => 'K',
-4544 => 'T',
-4545 => 'P',
-4546 => 'H',
-
- );
-
- # Leading consonant (can be null)
- my %Jamo_L = (
-'' => 11,
-'B' => 7,
-'BB' => 8,
-'C' => 14,
-'D' => 3,
-'DD' => 4,
-'G' => 0,
-'GG' => 1,
-'H' => 18,
-'J' => 12,
-'JJ' => 13,
-'K' => 15,
-'M' => 6,
-'N' => 2,
-'P' => 17,
-'R' => 5,
-'S' => 9,
-'SS' => 10,
-'T' => 16,
-
- );
-
- # Vowel
- my %Jamo_V = (
-'A' => 0,
-'AE' => 1,
-'E' => 5,
-'EO' => 4,
-'EU' => 18,
-'I' => 20,
-'O' => 8,
-'OE' => 11,
-'U' => 13,
-'WA' => 9,
-'WAE' => 10,
-'WE' => 15,
-'WEO' => 14,
-'WI' => 16,
-'YA' => 2,
-'YAE' => 3,
-'YE' => 7,
-'YEO' => 6,
-'YI' => 19,
-'YO' => 12,
-'YU' => 17,
-
- );
-
- # Optional trailing consonant
- my %Jamo_T = (
-'B' => 17,
-'BS' => 18,
-'C' => 23,
-'D' => 7,
-'G' => 1,
-'GG' => 2,
-'GS' => 3,
-'H' => 27,
-'J' => 22,
-'K' => 24,
-'L' => 8,
-'LB' => 11,
-'LG' => 9,
-'LH' => 15,
-'LM' => 10,
-'LP' => 14,
-'LS' => 12,
-'LT' => 13,
-'M' => 16,
-'N' => 4,
-'NG' => 21,
-'NH' => 6,
-'NJ' => 5,
-'P' => 26,
-'S' => 19,
-'SS' => 20,
-'T' => 25,
-
- );
-
- # Computed re that splits up a Hangul name into LVT or LV syllables
- my $syllable_re = qr/(|B|BB|C|D|DD|G|GG|H|J|JJ|K|M|N|P|R|S|SS|T)(A|AE|E|EO|EU|I|O|OE|U|WA|WAE|WE|WEO|WI|YA|YAE|YE|YEO|YI|YO|YU)(B|BS|C|D|G|GG|GS|H|J|K|L|LB|LG|LH|LM|LP|LS|LT|M|N|NG|NH|NJ|P|S|SS|T)?/;
-
- my $HANGUL_SYLLABLE = "HANGUL SYLLABLE ";
- my $loose_HANGUL_SYLLABLE = "HANGULSYLLABLE";
-
- # These constants names and values were taken from the Unicode standard,
- # version 5.1, section 3.12. They are used in conjunction with Hangul
- # syllables
- my $SBase = 0xAC00;
- my $LBase = 0x1100;
- my $VBase = 0x1161;
- my $TBase = 0x11A7;
- my $SCount = 11172;
- my $LCount = 19;
- my $VCount = 21;
- my $TCount = 28;
- my $NCount = $VCount * $TCount;
-
- sub name_to_code_point_special {
- my ($name, $loose) = @_;
-
- # Returns undef if not one of the specially handled names; otherwise
- # returns the code point equivalent to the input name
- # $loose is non-zero if to use loose matching, 'name' in that case
- # must be input as upper case with all blanks and dashes squeezed out.
-
- if ((! $loose && $name =~ s/$HANGUL_SYLLABLE//)
- || ($loose && $name =~ s/$loose_HANGUL_SYLLABLE//))
- {
- return if $name !~ qr/^$syllable_re$/;
- my $L = $Jamo_L{$1};
- my $V = $Jamo_V{$2};
- my $T = (defined $3) ? $Jamo_T{$3} : 0;
- return ($L * $VCount + $V) * $TCount + $T + $SBase;
- }
-
- # Name must end in 'code_point' for this to handle.
- return if (($loose && $name !~ /^ (.*?) ($run_on_code_point_re) $/x)
- || (! $loose && $name !~ /^ (.*) ($code_point_re) $/x));
-
- my $base = $1;
- my $code_point = CORE::hex $2;
- my $names_ref;
-
- if ($loose) {
- $names_ref = \%loose_names_ending_in_code_point;
- }
- else {
- return if $base !~ s/-$//;
- $names_ref = \%names_ending_in_code_point;
- }
-
- # Name must be one of the ones which has the code point in it.
- return if ! $names_ref->{$base};
-
- # Look through the list of ranges that apply to this name to see if
- # the code point is in one of them.
- for (my $i = 0; $i < scalar @{$names_ref->{$base}{'low'}}; $i++) {
- return if $names_ref->{$base}{'low'}->[$i] > $code_point;
- next if $names_ref->{$base}{'high'}->[$i] < $code_point;
-
- # Here, the code point is in the range.
- return $code_point;
- }
-
- # Here, looked like the name had a code point number in it, but
- # did not match one of the valid ones.
- return;
- }
-
- sub code_point_to_name_special {
- my $code_point = shift;
-
- # Returns the name of a code point if algorithmically determinable;
- # undef if not
-
- # If in the Hangul range, calculate the name based on Unicode's
- # algorithm
- if ($code_point >= $SBase && $code_point <= $SBase + $SCount -1) {
- use integer;
- my $SIndex = $code_point - $SBase;
- my $L = $LBase + $SIndex / $NCount;
- my $V = $VBase + ($SIndex % $NCount) / $TCount;
- my $T = $TBase + $SIndex % $TCount;
- $name = "$HANGUL_SYLLABLE$Jamo{$L}$Jamo{$V}";
- $name .= $Jamo{$T} if $T != $TBase;
- return $name;
- }
-
- # Look through list of these code points for one in range.
- foreach my $hash (@code_points_ending_in_code_point) {
- return if $code_point < $hash->{'low'};
- if ($code_point <= $hash->{'high'}) {
- return sprintf("%s-%04X", $hash->{'name'}, $code_point);
- }
- }
- return; # None found
- }
-} # End closure
-
-1;
commit bf797b1a701a5f99e2ce9ac35e1960df0d5cd97d
Author: Jim Brandt <jbrandt at bestpractical.com>
Date: Wed Sep 6 16:42:55 2017 -0400
Prep for 0.03 release
diff --git a/Changes b/Changes
new file mode 100644
index 0000000..3893a55
--- /dev/null
+++ b/Changes
@@ -0,0 +1,5 @@
+Revision history for RT-Authen-Token
+
+0.03 2017-09-06
+ - Don't require a password for token creation when RT is configured
+ with External Authentication.
diff --git a/MANIFEST b/MANIFEST
index 817132b..810ad0e 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -1,3 +1,4 @@
+Changes
etc/acl.mysql
etc/acl.Oracle
etc/acl.Pg
@@ -30,7 +31,6 @@ inc/Module/Install/RTx.pm
inc/Module/Install/RTx/Runtime.pm
inc/Module/Install/Win32.pm
inc/Module/Install/WriteAll.pm
-inc/unicore/Name.pm
inc/YAML/Tiny.pm
lib/RT/Authen/Token.pm
lib/RT/AuthToken.pm
diff --git a/META.yml b/META.yml
index 0c43df8..4c30f9a 100644
--- a/META.yml
+++ b/META.yml
@@ -24,7 +24,7 @@ requires:
perl: 5.10.1
resources:
license: http://opensource.org/licenses/gpl-license.php
-version: 0.02
-x_module_install_rtx_version: 0.39
+version: '0.03'
+x_module_install_rtx_version: '0.39'
x_requires_rt: 4.2.5
-x_rt_too_new: 4.6
+x_rt_too_new: '4.6'
diff --git a/lib/RT/Authen/Token.pm b/lib/RT/Authen/Token.pm
index a3aafe6..bac8d4d 100644
--- a/lib/RT/Authen/Token.pm
+++ b/lib/RT/Authen/Token.pm
@@ -2,7 +2,7 @@ package RT::Authen::Token;
use strict;
use warnings;
-our $VERSION = '0.02';
+our $VERSION = '0.03';
RT::System->AddRight(Staff => ManageAuthTokens => 'Manage authentication tokens');
-----------------------------------------------------------------------
More information about the Bps-public-commit
mailing list