[Bps-public-commit] rt-extension-resetpassword branch, master, updated. 1.00
Alex Vandiver
alexmv at bestpractical.com
Wed Sep 3 15:54:08 EDT 2014
The branch, master has been updated
via ff33b866e5036c28f5ad534dd83e6dfdb4006361 (commit)
via 45ec00f856717560f92fdd30bdba393058cc0f01 (commit)
from 249bd0e36275bed3479a8073761a26cef64ce81a (commit)
Summary of changes:
Changes | 26 +-
MANIFEST.SKIP | 98 ----
META.yml | 16 +-
Makefile.PL | 3 -
README | 46 +-
html/NoAuth/ResetPassword/Request.html | 7 +
inc/Module/Install.pm | 2 +-
inc/Module/Install/Base.pm | 2 +-
inc/Module/Install/Can.pm | 2 +-
inc/Module/Install/Fetch.pm | 2 +-
inc/Module/Install/Include.pm | 34 ++
inc/Module/Install/Makefile.pm | 2 +-
inc/Module/Install/ManifestSkip.pm | 48 --
inc/Module/Install/Metadata.pm | 2 +-
inc/Module/Install/RTx.pm | 198 +++++---
inc/Module/Install/RTx/Factory.pm | 53 --
inc/Module/Install/RTx/Runtime.pm | 79 +++
inc/Module/Install/Win32.pm | 2 +-
inc/Module/Install/WriteAll.pm | 2 +-
inc/YAML/Tiny.pm | 873 +++++++++++++++++++++++++++++++++
inc/unicore/Name.pm | 417 ++++++++++++++++
lib/RT/Extension/ResetPassword.pm | 31 +-
22 files changed, 1613 insertions(+), 332 deletions(-)
delete mode 100644 MANIFEST.SKIP
create mode 100644 inc/Module/Install/Include.pm
delete mode 100644 inc/Module/Install/ManifestSkip.pm
delete mode 100644 inc/Module/Install/RTx/Factory.pm
create mode 100644 inc/Module/Install/RTx/Runtime.pm
create mode 100644 inc/YAML/Tiny.pm
create mode 100644 inc/unicore/Name.pm
- Log -----------------------------------------------------------------
commit 45ec00f856717560f92fdd30bdba393058cc0f01
Author: Richard Poole <rp at guests.deus.net>
Date: Wed Sep 3 15:46:20 2014 +0100
optionally hide failures to request password resets
Set HidePasswordResetErrors in RT config to make all password reset
requests look to the requestor as though they have successfully sent an
email. Thus an unauthorised visitor can't find out whether a given user
account exists or is disabled.
diff --git a/html/NoAuth/ResetPassword/Request.html b/html/NoAuth/ResetPassword/Request.html
index 65832b9..9eecb72 100644
--- a/html/NoAuth/ResetPassword/Request.html
+++ b/html/NoAuth/ResetPassword/Request.html
@@ -91,10 +91,17 @@ if ($ARGS{'Email'}) {
}
} elsif ($u->id and $u->Disabled) {
push @actions, loc("You can't reset your password because your user is disabled.");
+ RT->Logger->warning("Disabled user " . $u->Name . " attempted to reset password");
} elsif ($u->id) {
push @actions, loc("You can't reset your password as you don't already have one.");
+ RT->Logger->warning("User " . $u->Name . " with no password attempted a password reset")
} else {
push @actions, loc("RT couldn't find a user with that email address. Give it another try?");
+ RT->Logger->warning("Password reset attempted for non-existent user " . $u->EmailAddress);
+ }
+ if(RT->Config->Get("HidePasswordResetErrors") == 1) {
+ pop @actions;
+ push @actions, loc("RT has sent you an email message with instructions about how to reset your password");
}
}
</%INIT>
diff --git a/lib/RT/Extension/ResetPassword.pm b/lib/RT/Extension/ResetPassword.pm
index e607ac3..cf2fde3 100644
--- a/lib/RT/Extension/ResetPassword.pm
+++ b/lib/RT/Extension/ResetPassword.pm
@@ -73,6 +73,13 @@ The contents of the email sent to users can be found in the global
PasswordReset template (do not confuse this with the core PasswordChange
template).
+If you want to prevent unauthorised visitors from determining what user
+accounts exist and whether they are disabled, set HidePasswordResetErrors
+to 1 in your RT configuration; then any password reset request will
+appear to the requestor to have resulted in an email being sent, thus
+not revealing the reasons for any failure. All failures will still be
+logged with an appropriate diagnostic message.
+
=head1 AUTHOR
Jesse Vincent <jesse at bestpractical.com>
commit ff33b866e5036c28f5ad534dd83e6dfdb4006361
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Wed Sep 3 15:53:38 2014 -0400
Version 1.00 releng
diff --git a/Changes b/Changes
index 3f90f53..e92e426 100644
--- a/Changes
+++ b/Changes
@@ -1,21 +1,25 @@
Revision history for Perl module RT::Extension::ResetPassword
+1.00 2014-09-03
+ - Add a configuration parameter, HidePasswordResetErrors, to not leak
+ if the email address is in use/
+ - Updated packaging.
+
0.06 2014-03-10
- - Switch to using a ResetPassword Template rather than a hardcoded message
- Contributed by Christian Loos
- - Added pod abstract (which MetaCPAN, search.cpan.org, etc expect to find)
- - Added Changes file, populated from git log comments
+ - Switch to using a ResetPassword Template rather than a hardcoded message
+ Contributed by Christian Loos
+ - Added pod abstract (which MetaCPAN, search.cpan.org, etc expect to find)
+ - Added Changes file, populated from git log comments
0.05 2012-02-07
- - password reset only for user with password
- - don't allow requests for disabled users
+ - password reset only for user with password
+ - don't allow requests for disabled users
0.04 2011-09-19
- - Add a gitignore and move README into lib
- - Update MI::RTx
- This avoids needing RTHOME or a prompt to install on RT4
- - mention RT4
+ - Add a gitignore and move README into lib
+ - Update MI::RTx This avoids needing RTHOME or a prompt to install on RT4
+ - mention RT4
0.03 2009-06-24
- - First release to CPAN
+ - First release to CPAN
diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP
deleted file mode 100644
index 9dd42b9..0000000
--- a/MANIFEST.SKIP
+++ /dev/null
@@ -1,98 +0,0 @@
-
-# Begin standard Module::Manifest::Skip list:
-
-# ExtUtils::MakeMaker
-^blib/
-^blibdirs$
-^blibdirs\.ts$
-^bpm_to_blib\.ts$
-^Makefile$
-^Makefile\.old$
-^MakeMaker-\d
-^MANIFEST\.bak$
-^MANIFEST\.SKIP$
-^MYMETA\.
-^pm_to_blib$
-^pod2htm.*
-
-# Module::Build
-^Build$
-^_build/
-^Build.bat$
-^Build.COM$
-^BUILD.COM$
-^build.com$
-
-# Revision Control
-\bCVS\b
-\b.cvsignore\b
-\b_darcs\b
-\B\.git\b
-\B\.gitignore\b
-\B\.gitmodules\b
-\B\.hg\b
-\B\.hgignore\b
-\B\.hgtags\b
-\bRCS\b
-\bSCCS\b
-\B\.svn\b
-,v$
-,B$
-,D$
-\baegis.log$
-
-# Author Extras
-^inc/.*\.pod$
-^pkg/
-^xt/
-^dist.ini$
-
-# Editors
-~$
-\#$
-\b\.#
-\.kpf$
-\.sw[pmno]$
-^\.vimrc$
-
-# OS X
-\.DS_Store$
-^\.Trash/
-\B\._
-
-# VMS
-\bDescrip.MMS$
-\bDESCRIP.MMS$
-\bdescrip.mms$
-
-# Development
-^benchmarks/
-^core$
-^cover_db\b
-^covered\b
-^debian/
-^devel\.
-^.devel-local$
-^out$
-^tmon.out$
-^old/
-^Old/
-
-# Author Notes
-^notes
-^todo
-^ToDo$
-
-# Common Junk Files
-\.bak$
-\.diff$
-^foo\b.*
-\.old$
-\.orig$
-\.patch$
-\.rej$
-\.tdy$
-\.tmp$
-^\w$
-\.ttc$
-\.pmc$
diff --git a/META.yml b/META.yml
index afd93d3..2bc4faf 100644
--- a/META.yml
+++ b/META.yml
@@ -1,14 +1,14 @@
---
-abstract: "add \"forgot your password?\" link to RT instance"
+abstract: 'add "forgot your password?" link to RT instance'
author:
- - 'Jesse Vincent <jesse at bestpractical.com>'
+ - 'Best Practical Solutions, LLC <modules at bestpractical.com>'
build_requires:
- ExtUtils::MakeMaker: 6.36
+ ExtUtils::MakeMaker: 6.59
configure_requires:
- ExtUtils::MakeMaker: 6.36
+ ExtUtils::MakeMaker: 6.59
distribution_type: module
dynamic_config: 1
-generated_by: 'Module::Install version 1.06'
+generated_by: 'Module::Install version 1.08'
license: gpl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
@@ -19,6 +19,10 @@ no_index:
- etc
- html
- inc
+requires:
+ perl: 5.8.3
resources:
license: http://opensource.org/licenses/gpl-license.php
-version: 0.06
+version: '1.00'
+x_module_install_rtx_version: '0.36'
+x_requires_rt: 4.0.0
diff --git a/Makefile.PL b/Makefile.PL
index dc2905f..6c7c309 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -1,8 +1,5 @@
use inc::Module::Install;
RTx('RT-Extension-ResetPassword');
-readme_from('lib/RT/Extension/ResetPassword.pm');
-all_from('lib/RT/Extension/ResetPassword.pm');
-manifest_skip;
sign;
&WriteAll;
diff --git a/README b/README
index 001b5d1..faf157d 100644
--- a/README
+++ b/README
@@ -12,12 +12,12 @@ DESCRIPTION
to reset their passwords.
INSTALLATION
- "perl Makefile.PL"
- "make"
- "make install"
+ perl Makefile.PL
+ make
+ make install
May need root permissions
- "make initdb"
+ make initdb
Only run this the first time you install this module.
If you run this twice, you may end up with duplicate data in your
@@ -31,12 +31,11 @@ INSTALLATION
Plugin('RT::Extension::ResetPassword');
- For RT 3.8 and 4.0, add this line:
+ For RT 4.0, add this line:
Set(@Plugins, qw(RT::Extension::ResetPassword));
- or add "RT::Extension::ResetPassword" to your existing @Plugins
- line.
+ or add RT::Extension::ResetPassword to your existing @Plugins line.
Clear your mason cache
rm -rf /opt/rt4/var/mason_data/obj
@@ -44,24 +43,39 @@ INSTALLATION
Restart your webserver
UPGRADING
- If you are upgrading from version 0.05, you will need to run "make
- initdb" as documented in INSTALLATION to install the Template used by
- this Extension.
+ If you are upgrading from version 0.05, you will need to run make initdb
+ as documented in INSTALLATION to install the Template used by this
+ Extension.
CONFIGURATION
The contents of the email sent to users can be found in the global
PasswordReset template (do not confuse this with the core PasswordChange
template).
+ If you want to prevent unauthorised visitors from determining what user
+ accounts exist and whether they are disabled, set
+ HidePasswordResetErrors to 1 in your RT configuration; then any password
+ reset request will appear to the requestor to have resulted in an email
+ being sent, thus not revealing the reasons for any failure. All failures
+ will still be logged with an appropriate diagnostic message.
+
AUTHOR
- Jesse Vincent <jesse at bestpractical.com>
+ Best Practical Solutions, LLC <modules at bestpractical.com>
+
+BUGS
+ All bugs should be reported via email to
+
+ L<bug-RT-Extension-ResetPassword at rt.cpan.org|mailto:bug-RT-Extension-ResetPassword at rt.cpan.org>
+
+ or via the web at
+
+ L<rt.cpan.org|http://rt.cpan.org/Public/Dist/Display.html?Name=RT-Extension-ResetPassword>.
LICENSE AND COPYRIGHT
- Copyright 2006-2014 Best Practical Solutions, LLC.
+ This software is Copyright (c) 2012-2014 by Best Practical Solutions,
+ LLC
- This program is free software; you can redistribute it and/or modify it
- under the terms of either: the GNU General Public License as published
- by the Free Software Foundation; or the Artistic License.
+ This is free software, licensed under:
- See http://dev.perl.org/licenses/ for more information.
+ The GNU General Public License, Version 2, June 1991
diff --git a/inc/Module/Install.pm b/inc/Module/Install.pm
index 4ecf46b..7680c84 100644
--- a/inc/Module/Install.pm
+++ b/inc/Module/Install.pm
@@ -31,7 +31,7 @@ BEGIN {
# This is not enforced yet, but will be some time in the next few
# releases once we can make sure it won't clash with custom
# Module::Install extensions.
- $VERSION = '1.06';
+ $VERSION = '1.08';
# Storage for the pseudo-singleton
$MAIN = undef;
diff --git a/inc/Module/Install/Base.pm b/inc/Module/Install/Base.pm
index 802844a..3e63345 100644
--- a/inc/Module/Install/Base.pm
+++ b/inc/Module/Install/Base.pm
@@ -4,7 +4,7 @@ package Module::Install::Base;
use strict 'vars';
use vars qw{$VERSION};
BEGIN {
- $VERSION = '1.06';
+ $VERSION = '1.08';
}
# Suspend handler for "redefined" warnings
diff --git a/inc/Module/Install/Can.pm b/inc/Module/Install/Can.pm
index 22167b8..93f248d 100644
--- a/inc/Module/Install/Can.pm
+++ b/inc/Module/Install/Can.pm
@@ -8,7 +8,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.06';
+ $VERSION = '1.08';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
diff --git a/inc/Module/Install/Fetch.pm b/inc/Module/Install/Fetch.pm
index bee0c4f..ecc0d53 100644
--- a/inc/Module/Install/Fetch.pm
+++ b/inc/Module/Install/Fetch.pm
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.06';
+ $VERSION = '1.08';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
diff --git a/inc/Module/Install/Include.pm b/inc/Module/Install/Include.pm
new file mode 100644
index 0000000..fc86e23
--- /dev/null
+++ b/inc/Module/Install/Include.pm
@@ -0,0 +1,34 @@
+#line 1
+package Module::Install::Include;
+
+use strict;
+use Module::Install::Base ();
+
+use vars qw{$VERSION @ISA $ISCORE};
+BEGIN {
+ $VERSION = '1.08';
+ @ISA = 'Module::Install::Base';
+ $ISCORE = 1;
+}
+
+sub include {
+ shift()->admin->include(@_);
+}
+
+sub include_deps {
+ shift()->admin->include_deps(@_);
+}
+
+sub auto_include {
+ shift()->admin->auto_include(@_);
+}
+
+sub auto_include_deps {
+ shift()->admin->auto_include_deps(@_);
+}
+
+sub auto_include_dependent_dists {
+ shift()->admin->auto_include_dependent_dists(@_);
+}
+
+1;
diff --git a/inc/Module/Install/Makefile.pm b/inc/Module/Install/Makefile.pm
index 7052f36..c0978a4 100644
--- a/inc/Module/Install/Makefile.pm
+++ b/inc/Module/Install/Makefile.pm
@@ -8,7 +8,7 @@ use Fcntl qw/:flock :seek/;
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.06';
+ $VERSION = '1.08';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
diff --git a/inc/Module/Install/ManifestSkip.pm b/inc/Module/Install/ManifestSkip.pm
deleted file mode 100644
index 739379f..0000000
--- a/inc/Module/Install/ManifestSkip.pm
+++ /dev/null
@@ -1,48 +0,0 @@
-#line 1
-##
-# name: Module::Install::ManifestSkip
-# abstract: Generate a MANIFEST.SKIP file
-# author: Ingy döt Net <ingy at cpan.org>
-# license: perl
-# copyright: 2010, 2011
-# see:
-# - Module::Manifest::Skip
-
-package Module::Install::ManifestSkip;
-use 5.008001;
-use strict;
-use warnings;
-
-use base 'Module::Install::Base';
-
-my $requires = "
-use Module::Manifest::Skip 0.10 ();
-";
-
-our $VERSION = '0.20';
-our $AUTHOR_ONLY = 1;
-
-my $skip_file = "MANIFEST.SKIP";
-
-sub manifest_skip {
- my $self = shift;
- return unless $self->is_admin;
-
- eval $requires; die $@ if $@;
-
- print "Writing $skip_file\n";
-
- open OUT, '>', $skip_file
- or die "Can't open $skip_file for output: $!";;
-
- print OUT Module::Manifest::Skip->new->text;
-
- close OUT;
-
- $self->clean_files('MANIFEST');
- $self->clean_files($skip_file)
- if grep /^clean$/, @_;
-}
-
-1;
-
diff --git a/inc/Module/Install/Metadata.pm b/inc/Module/Install/Metadata.pm
index 58430f3..e4112f8 100644
--- a/inc/Module/Install/Metadata.pm
+++ b/inc/Module/Install/Metadata.pm
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.06';
+ $VERSION = '1.08';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
diff --git a/inc/Module/Install/RTx.pm b/inc/Module/Install/RTx.pm
index 469eb42..1b55bfa 100644
--- a/inc/Module/Install/RTx.pm
+++ b/inc/Module/Install/RTx.pm
@@ -8,7 +8,7 @@ no warnings 'once';
use Module::Install::Base;
use base 'Module::Install::Base';
-our $VERSION = '0.32_02';
+our $VERSION = '0.36';
use FindBin;
use File::Glob ();
@@ -18,95 +18,79 @@ my @DIRS = qw(etc lib html static bin sbin po var);
my @INDEX_DIRS = qw(lib bin sbin);
sub RTx {
- my ( $self, $name ) = @_;
+ my ( $self, $name, $extra_args ) = @_;
+ $extra_args ||= {};
- my $original_name = $name;
- my $RTx = 'RTx';
- $RTx = $1 if $name =~ s/^(\w+)-//;
+ # Set up names
my $fname = $name;
$fname =~ s!-!/!g;
- $self->name("$RTx-$name")
+ $self->name( $name )
unless $self->name;
- $self->all_from( -e "$name.pm" ? "$name.pm" : "lib/$RTx/$fname.pm" )
+ $self->all_from( "lib/$fname.pm" )
unless $self->version;
- $self->abstract("RT $name Extension")
+ $self->abstract("$name Extension")
unless $self->abstract;
-
- my @prefixes = (qw(/opt /usr/local /home /usr /sw ));
- my $prefix = $ENV{PREFIX};
- @ARGV = grep { /PREFIX=(.*)/ ? ( ( $prefix = $1 ), 0 ) : 1 } @ARGV;
-
- if ($prefix) {
- $RT::LocalPath = $prefix;
- $INC{'RT.pm'} = "$RT::LocalPath/lib/RT.pm";
- } else {
- local @INC = (
- $ENV{RTHOME} ? ( $ENV{RTHOME}, "$ENV{RTHOME}/lib" ) : (),
- @INC,
- map { ( "$_/rt4/lib", "$_/lib/rt4", "$_/rt3/lib", "$_/lib/rt3", "$_/lib" )
- } grep $_, @prefixes
- );
- until ( eval { require RT; $RT::LocalPath } ) {
- warn
- "Cannot find the location of RT.pm that defines \$RT::LocalPath in: @INC\n";
- $_ = $self->prompt("Path to directory containing your RT.pm:") or exit;
- $_ =~ s/\/RT\.pm$//;
- push @INC, $_, "$_/rt3/lib", "$_/lib/rt3", "$_/lib";
- }
+ unless ( $extra_args->{no_readme_generation} ) {
+ $self->readme_from( "lib/$fname.pm",
+ { options => [ quotes => "none" ] } );
+ }
+ $self->add_metadata("x_module_install_rtx_version", $VERSION );
+
+ # Try to find RT.pm
+ my @prefixes = qw( /opt /usr/local /home /usr /sw /usr/share/request-tracker4);
+ $ENV{RTHOME} =~ s{/RT\.pm$}{} if defined $ENV{RTHOME};
+ $ENV{RTHOME} =~ s{/lib/?$}{} if defined $ENV{RTHOME};
+ my @try = $ENV{RTHOME} ? ($ENV{RTHOME}, "$ENV{RTHOME}/lib") : ();
+ while (1) {
+ my @look = @INC;
+ unshift @look, grep {defined and -d $_} @try;
+ push @look, grep {defined and -d $_}
+ map { ( "$_/rt4/lib", "$_/lib/rt4", "$_/lib" ) } @prefixes;
+ last if eval {local @INC = @look; require RT; $RT::LocalLibPath};
+
+ warn
+ "Cannot find the location of RT.pm that defines \$RT::LocalPath in: @look\n";
+ my $given = $self->prompt("Path to directory containing your RT.pm:") or exit;
+ $given =~ s{/RT\.pm$}{};
+ $given =~ s{/lib/?$}{};
+ @try = ($given, "$given/lib");
}
- my $lib_path = File::Basename::dirname( $INC{'RT.pm'} );
- my $local_lib_path = "$RT::LocalPath/lib";
print "Using RT configuration from $INC{'RT.pm'}:\n";
- unshift @INC, "$RT::LocalPath/lib" if $RT::LocalPath;
- unshift @INC, $lib_path;
-
- $RT::LocalVarPath ||= $RT::VarPath;
- $RT::LocalPoPath ||= $RT::LocalLexiconPath;
- $RT::LocalHtmlPath ||= $RT::MasonComponentRoot;
- $RT::LocalStaticPath ||= $RT::StaticPath;
- $RT::LocalLibPath ||= "$RT::LocalPath/lib";
- my $with_subdirs = $ENV{WITH_SUBDIRS};
- @ARGV = grep { /WITH_SUBDIRS=(.*)/ ? ( ( $with_subdirs = $1 ), 0 ) : 1 }
- @ARGV;
+ my $local_lib_path = $RT::LocalLibPath;
+ unshift @INC, $local_lib_path;
+ my $lib_path = File::Basename::dirname( $INC{'RT.pm'} );
+ unshift @INC, $lib_path;
- my %subdirs;
- %subdirs = map { $_ => 1 } split( /\s*,\s*/, $with_subdirs )
- if defined $with_subdirs;
- unless ( keys %subdirs ) {
- $subdirs{$_} = 1 foreach grep -d "$FindBin::Bin/$_", @DIRS;
+ # Set a baseline minimum version
+ unless ( $extra_args->{deprecated_rt} ) {
+ $self->requires_rt('4.0.0');
}
- # If we're running on RT 3.8 with plugin support, we really wany
- # to install libs, mason templates and po files into plugin specific
- # directories
+ # Installation locations
my %path;
- if ( $RT::LocalPluginPath ) {
- die "Because of bugs in RT 3.8.0 this extension can not be installed.\n"
- ."Upgrade to RT 3.8.1 or newer.\n" if $RT::VERSION =~ /^3\.8\.0/;
- $path{$_} = $RT::LocalPluginPath . "/$original_name/$_"
- foreach @DIRS;
- } else {
- foreach ( @DIRS ) {
- no strict 'refs';
- my $varname = "RT::Local" . ucfirst($_) . "Path";
- $path{$_} = ${$varname} || "$RT::LocalPath/$_";
- }
+ $path{$_} = $RT::LocalPluginPath . "/$name/$_"
+ foreach @DIRS;
- $path{$_} .= "/$name" for grep $path{$_}, qw(etc po var);
- }
+ # Copy RT 4.2.0 static files into NoAuth; insufficient for
+ # images, but good enough for css and js.
+ $path{static} = "$path{html}/NoAuth/"
+ unless $RT::StaticPath;
+
+ # Delete the ones we don't need
+ delete $path{$_} for grep {not -d "$FindBin::Bin/$_"} keys %path;
my %index = map { $_ => 1 } @INDEX_DIRS;
$self->no_index( directory => $_ ) foreach grep !$index{$_}, @DIRS;
my $args = join ', ', map "q($_)", map { ($_, $path{$_}) }
- grep $subdirs{$_}, keys %path;
+ sort keys %path;
- print "./$_\t=> $path{$_}\n" for sort keys %subdirs;
+ printf "%-10s => %s\n", $_, $path{$_} for sort keys %path;
- if ( my @dirs = map { ( -D => $_ ) } grep $subdirs{$_}, qw(bin html sbin) ) {
+ if ( my @dirs = map { ( -D => $_ ) } grep $path{$_}, qw(bin html sbin etc) ) {
my @po = map { ( -o => $_ ) }
grep -f,
File::Glob::bsd_glob("po/*.po");
@@ -116,12 +100,15 @@ lexicons ::
.
}
+ $self->include('Module::Install::RTx::Runtime') if $self->admin;
+ $self->include_deps( 'YAML::Tiny', 0 ) if $self->admin;
my $postamble = << ".";
install ::
+\t\$(NOECHO) \$(PERL) -Ilib -I"$local_lib_path" -I"$lib_path" -Iinc -MModule::Install::RTx::Runtime -e"RTxPlugin()"
\t\$(NOECHO) \$(PERL) -MExtUtils::Install -e \"install({$args})\"
.
- if ( $subdirs{var} and -d $RT::MasonDataDir ) {
+ if ( $path{var} and -d $RT::MasonDataDir ) {
my ( $uid, $gid ) = ( stat($RT::MasonDataDir) )[ 4, 5 ];
$postamble .= << ".";
\t\$(NOECHO) chown -R $uid:$gid $path{var}
@@ -141,11 +128,11 @@ install ::
}
$self->postamble("$postamble\n");
- unless ( $subdirs{'lib'} ) {
- $self->makemaker_args( PM => { "" => "" }, );
- } else {
+ if ( $path{lib} ) {
$self->makemaker_args( INSTALLSITELIB => $path{'lib'} );
$self->makemaker_args( INSTALLARCHLIB => $path{'lib'} );
+ } else {
+ $self->makemaker_args( PM => { "" => "" }, );
}
$self->makemaker_args( INSTALLSITEMAN1DIR => "$RT::LocalPath/man/man1" );
@@ -153,47 +140,96 @@ install ::
$self->makemaker_args( INSTALLSITEARCH => "$RT::LocalPath/man" );
if (%has_etc) {
- $self->load('RTxInitDB');
print "For first-time installation, type 'make initdb'.\n";
my $initdb = '';
$initdb .= <<"." if $has_etc{schema};
-\t\$(NOECHO) \$(PERL) -Ilib -I"$local_lib_path" -I"$lib_path" -Minc::Module::Install -e"RTxInitDB(qw(schema \$(NAME) \$(VERSION)))"
+\t\$(NOECHO) \$(PERL) -Ilib -I"$local_lib_path" -I"$lib_path" -Iinc -MModule::Install::RTx::Runtime -e"RTxDatabase(qw(schema \$(NAME) \$(VERSION)))"
.
$initdb .= <<"." if $has_etc{acl};
-\t\$(NOECHO) \$(PERL) -Ilib -I"$local_lib_path" -I"$lib_path" -Minc::Module::Install -e"RTxInitDB(qw(acl \$(NAME) \$(VERSION)))"
+\t\$(NOECHO) \$(PERL) -Ilib -I"$local_lib_path" -I"$lib_path" -Iinc -MModule::Install::RTx::Runtime -e"RTxDatabase(qw(acl \$(NAME) \$(VERSION)))"
.
$initdb .= <<"." if $has_etc{initialdata};
-\t\$(NOECHO) \$(PERL) -Ilib -I"$local_lib_path" -I"$lib_path" -Minc::Module::Install -e"RTxInitDB(qw(insert \$(NAME) \$(VERSION)))"
+\t\$(NOECHO) \$(PERL) -Ilib -I"$local_lib_path" -I"$lib_path" -Iinc -MModule::Install::RTx::Runtime -e"RTxDatabase(qw(insert \$(NAME) \$(VERSION)))"
.
$self->postamble("initdb ::\n$initdb\n");
$self->postamble("initialize-database ::\n$initdb\n");
if ($has_etc{upgrade}) {
print "To upgrade from a previous version of this extension, use 'make upgrade-database'\n";
- my $upgradedb = qq|\t\$(NOECHO) \$(PERL) -Ilib -I"$local_lib_path" -I"$lib_path" -Minc::Module::Install -e"RTxInitDB(qw(upgrade \$(NAME) \$(VERSION)))"\n|;
+ my $upgradedb = qq|\t\$(NOECHO) \$(PERL) -Ilib -I"$local_lib_path" -I"$lib_path" -Iinc -MModule::Install::RTx::Runtime -e"RTxDatabase(qw(upgrade \$(NAME) \$(VERSION)))"\n|;
$self->postamble("upgrade-database ::\n$upgradedb\n");
$self->postamble("upgradedb ::\n$upgradedb\n");
}
}
+
}
sub requires_rt {
my ($self,$version) = @_;
+ _load_rt_handle();
+
+ if ($self->is_admin) {
+ $self->add_metadata("x_requires_rt", $version);
+ my @sorted = sort RT::Handle::cmp_version $version,'4.0.0';
+ $self->perl_version('5.008003') if $sorted[0] eq '4.0.0'
+ and (not $self->perl_version or '5.008003' > $self->perl_version);
+ @sorted = sort RT::Handle::cmp_version $version,'4.2.0';
+ $self->perl_version('5.010001') if $sorted[0] eq '4.2.0'
+ and (not $self->perl_version or '5.010001' > $self->perl_version);
+ }
+
# if we're exactly the same version as what we want, silently return
return if ($version eq $RT::VERSION);
- _load_rt_handle();
my @sorted = sort RT::Handle::cmp_version $version,$RT::VERSION;
if ($sorted[-1] eq $version) {
- # should we die?
- die "\nWarning: prerequisite RT $version not found. Your installed version of RT ($RT::VERSION) is too old.\n\n";
+ die <<"EOT";
+
+**** Error: This extension requires RT $version. Your installed version
+ of RT ($RT::VERSION) is too old.
+
+EOT
+ }
+}
+
+sub requires_rt_plugin {
+ my $self = shift;
+ my ( $plugin ) = @_;
+
+ if ($self->is_admin) {
+ my $plugins = $self->Meta->{values}{"x_requires_rt_plugins"} || [];
+ push @{$plugins}, $plugin;
+ $self->add_metadata("x_requires_rt_plugins", $plugins);
}
+
+ my $path = $plugin;
+ $path =~ s{\:\:}{-}g;
+ $path = "$RT::LocalPluginPath/$path/lib";
+ if ( -e $path ) {
+ unshift @INC, $path;
+ } else {
+ my $name = $self->name;
+ warn <<"EOT";
+
+**** Warning: $name requires that the $plugin plugin be installed and
+ enabled; it does not appear to be installed.
+
+EOT
+ }
+ $self->requires(@_);
}
sub rt_too_new {
my ($self,$version,$msg) = @_;
- $msg ||= "Your version %s is too new, this extension requires a release of RT older than %s\n";
+ my $name = $self->name;
+ $msg ||= <<EOT;
+
+**** Error: Your installed version of RT (%s) is too new; this extension
+ only works with versions older than %s.
+
+EOT
+ $self->add_metadata("x_rt_too_new", $version) if $self->is_admin;
_load_rt_handle();
my @sorted = sort RT::Handle::cmp_version $version,$RT::VERSION;
@@ -222,4 +258,4 @@ sub _load_rt_handle {
__END__
-#line 362
+#line 390
diff --git a/inc/Module/Install/RTx/Factory.pm b/inc/Module/Install/RTx/Factory.pm
deleted file mode 100644
index 6776688..0000000
--- a/inc/Module/Install/RTx/Factory.pm
+++ /dev/null
@@ -1,53 +0,0 @@
-#line 1
-package Module::Install::RTx::Factory;
-use Module::Install::Base; @ISA = qw(Module::Install::Base);
-
-use strict;
-use File::Basename ();
-
-sub RTxInitDB {
- my ($self, $action, $name, $version) = @_;
-
- unshift @INC, substr(delete($INC{'RT.pm'}), 0, -5) if $INC{'RT.pm'};
-
- require RT;
- unshift @INC, "$RT::LocalPath/lib" if $RT::LocalPath;
-
- $RT::SbinPath ||= $RT::LocalPath;
- $RT::SbinPath =~ s/local$/sbin/;
-
- foreach my $file ($RT::CORE_CONFIG_FILE, $RT::SITE_CONFIG_FILE) {
- next if !-e $file or -r $file;
- die "No permission to read $file\n-- please re-run $0 with suitable privileges.\n";
- }
-
- RT::LoadConfig();
-
- require RT::System;
-
- my $lib_path = File::Basename::dirname($INC{'RT.pm'});
- my @args = ("-Ilib");
- push @args, "-I$RT::LocalPath/lib" if $RT::LocalPath;
- push @args, (
- "-I$lib_path",
- "$RT::SbinPath/rt-setup-database",
- "--action" => $action,
- ($action eq 'upgrade' ? () : ("--datadir" => "etc")),
- (($action eq 'insert') ? ("--datafile" => "etc/initialdata") : ()),
- "--dba" => $RT::DatabaseAdmin || $RT::DatabaseUser,
- "--prompt-for-dba-password" => '',
- (RT::System->can('AddUpgradeHistory') ? ("--package" => $name, "--ext-version" => $version) : ()),
- );
- # If we're upgrading against an RT which isn't at least 4.2 (has
- # AddUpgradeHistory) then pass --package. Upgrades against later RT
- # releases will pick up --package from AddUpgradeHistory.
- if ($action eq 'upgrade' and
- not RT::System->can('AddUpgradeHistory')) {
- push @args, "--package" => $name;
- }
-
- print "$^X @args\n";
- (system($^X, @args) == 0) or die "...returned with error: $?\n";
-}
-
-1;
diff --git a/inc/Module/Install/RTx/Runtime.pm b/inc/Module/Install/RTx/Runtime.pm
new file mode 100644
index 0000000..937949f
--- /dev/null
+++ b/inc/Module/Install/RTx/Runtime.pm
@@ -0,0 +1,79 @@
+#line 1
+package Module::Install::RTx::Runtime;
+
+use base 'Exporter';
+our @EXPORT = qw/RTxDatabase RTxPlugin/;
+
+use strict;
+use File::Basename ();
+
+sub _rt_runtime_load {
+ require RT;
+
+ eval { RT::LoadConfig(); };
+ if (my $err = $@) {
+ die $err unless $err =~ /^RT couldn't load RT config file/m;
+ my $warn = <<EOT;
+This usually means that your current user cannot read the file. You
+will likely need to run this installation step as root, or some user
+with more permissions.
+EOT
+ $err =~ s/This usually means.*/$warn/s;
+ die $err;
+ }
+}
+
+sub RTxDatabase {
+ my ($action, $name, $version) = @_;
+
+ _rt_runtime_load();
+
+ require RT::System;
+ my $has_upgrade = RT::System->can('AddUpgradeHistory');
+
+ my $lib_path = File::Basename::dirname($INC{'RT.pm'});
+ my @args = (
+ "-Ilib",
+ "-I$RT::LocalLibPath",
+ "-I$lib_path",
+ "$RT::SbinPath/rt-setup-database",
+ "--action" => $action,
+ ($action eq 'upgrade' ? () : ("--datadir" => "etc")),
+ (($action eq 'insert') ? ("--datafile" => "etc/initialdata") : ()),
+ "--dba" => $RT::DatabaseAdmin || $RT::DatabaseUser,
+ "--prompt-for-dba-password" => '',
+ ($has_upgrade ? ("--package" => $name, "--ext-version" => $version) : ()),
+ );
+ # If we're upgrading against an RT which isn't at least 4.2 (has
+ # AddUpgradeHistory) then pass --package. Upgrades against later RT
+ # releases will pick up --package from AddUpgradeHistory.
+ if ($action eq 'upgrade' and not $has_upgrade) {
+ push @args, "--package" => $name;
+ }
+
+ print "$^X @args\n";
+ (system($^X, @args) == 0) or die "...returned with error: $?\n";
+}
+
+sub RTxPlugin {
+ my ($name) = @_;
+
+ _rt_runtime_load();
+ require YAML::Tiny;
+ my $data = YAML::Tiny::LoadFile('META.yml');
+ my $name = $data->{name};
+
+ my @enabled = RT->Config->Get('Plugins');
+ for my $required (@{$data->{x_requires_rt_plugins} || []}) {
+ next if grep {$required eq $_} @enabled;
+
+ warn <<"EOT";
+
+**** Warning: $name requires that the $required plugin be installed and
+ enabled; it is not currently in \@Plugins.
+
+EOT
+ }
+}
+
+1;
diff --git a/inc/Module/Install/Win32.pm b/inc/Module/Install/Win32.pm
index eeaa3fe..e529382 100644
--- a/inc/Module/Install/Win32.pm
+++ b/inc/Module/Install/Win32.pm
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.06';
+ $VERSION = '1.08';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
diff --git a/inc/Module/Install/WriteAll.pm b/inc/Module/Install/WriteAll.pm
index 85d8018..2c74308 100644
--- a/inc/Module/Install/WriteAll.pm
+++ b/inc/Module/Install/WriteAll.pm
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.06';
+ $VERSION = '1.08';
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
diff --git a/inc/YAML/Tiny.pm b/inc/YAML/Tiny.pm
new file mode 100644
index 0000000..1be0cb1
--- /dev/null
+++ b/inc/YAML/Tiny.pm
@@ -0,0 +1,873 @@
+#line 1
+use 5.008001; # sane UTF-8 support
+use strict;
+use warnings;
+package YAML::Tiny;
+BEGIN {
+ $YAML::Tiny::AUTHORITY = 'cpan:ADAMK';
+}
+# git description: v1.61-3-g0a82466
+$YAML::Tiny::VERSION = '1.62';
+# XXX-INGY is 5.8.1 too old/broken for utf8?
+# XXX-XDG Lancaster consensus was that it was sufficient until
+# proven otherwise
+
+
+#####################################################################
+# 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;
+}
+
+# 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];
+ }
+}
+
+# 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;
+}
+
+sub DumpFile {
+ my $file = shift;
+ return YAML::Tiny->new(@_)->_dump_file($file);
+}
+
+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];
+ }
+}
+
+
+###
+# 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(@_);
+}
+
+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(
+ 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
+);
+
+# Printable characters for escapes
+my %UNESCAPES = (
+ 0 => "\x00", z => "\x00", N => "\x85",
+ a => "\x07", b => "\x08", t => "\x09",
+ n => "\x0a", v => "\x0b", f => "\x0c",
+ r => "\x0d", e => "\x1b", '\\' => '\\',
+);
+
+# 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 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+(?:\#.*)?|$)/;
+
+
+
+
+
+#####################################################################
+# YAML::Tiny Implementation.
+#
+# These are the private methods that do all the work. They may change
+# at any time.
+
+
+###
+# Loader functions:
+
+# Create an object from a file
+sub _load_file {
+ my $class = ref $_[0] ? ref shift : shift;
+
+ # Check the 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");
+ }
+
+ # close the file (release the lock)
+ unless ( close $fh ) {
+ $class->_error("Failed to close file '$file': $!");
+ }
+
+ $class->_load_string( $contents );
+}
+
+# Create an object from a string
+sub _load_string {
+ my $class = ref $_[0] ? ref shift : shift;
+ my $self = bless [], $class;
+ my $string = $_[0];
+ eval {
+ unless ( defined $string ) {
+ die \"Did not provide a string to load";
+ }
+
+ # 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)"?
+...
+ }
+
+ # 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;
+
+ # Split the file into lines
+ my @lines = grep { ! /^\s*(?:\#.*)?\z/ }
+ split /(?:\015{1,2}\012|\015|\012)/, $string;
+
+ # Strip the initial YAML header
+ @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->_load_scalar( "$1", [ undef ], \@lines );
+ next;
+ }
+ $in_document = 1;
+ }
+
+ if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) {
+ # A naked document
+ push @$self, undef;
+ while ( @lines and $lines[0] !~ /^---/ ) {
+ shift @lines;
+ }
+ $in_document = 0;
+
+ # 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->_load_array( $document, [ 0 ], \@lines );
+
+ } elsif ( $lines[0] =~ /^(\s*)\S/ ) {
+ # A hash at the root
+ my $document = { };
+ push @$self, $document;
+ $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' ) {
+ $self->_error(${$@});
+ } elsif ( $@ ) {
+ $self->_error($@);
+ }
+
+ return $self;
+}
+
+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
+ $string =~ s/\s*\z//;
+
+ # Explitic null/undef
+ return undef if $string eq '~';
+
+ # Single quote
+ if ( $string =~ /^$re_capture_single_quoted$re_trailing_comment\z/ ) {
+ return $self->_unquote_single($1);
+ }
+
+ # Double quote.
+ if ( $string =~ /^$re_capture_double_quoted$re_trailing_comment\z/ ) {
+ return $self->_unquote_double($1);
+ }
+
+ # Special cases
+ if ( $string =~ /^[\'\"!&]/ ) {
+ die \"YAML::Tiny does not support a feature in line '$string'";
+ }
+ return {} if $string =~ /^{}(?:\s+\#.*)?\z/;
+ return [] if $string =~ /^\[\](?:\s+\#.*)?\z/;
+
+ # Regular unquoted string
+ if ( $string !~ /^[>|]/ ) {
+ die \"YAML::Tiny found illegal characters in plain scalar: '$string'"
+ if $string =~ /^(?:-(?:\s|$)|[\@\%\`])/ or
+ $string =~ /:(?:\s|$)/;
+ $string =~ s/\s+#.*\z//;
+ return $string;
+ }
+
+ # Error
+ die \"YAML::Tiny failed to find multi-line scalar content" unless @$lines;
+
+ # Check the indent depth
+ $lines->[0] =~ /^(\s*)/;
+ $indent->[-1] = length("$1");
+ if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) {
+ die \"YAML::Tiny found bad indenting in line '$lines->[0]'";
+ }
+
+ # Pull the lines
+ my @multiline = ();
+ while ( @$lines ) {
+ $lines->[0] =~ /^(\s*)/;
+ last unless length($1) >= $indent->[-1];
+ push @multiline, substr(shift(@$lines), length($1));
+ }
+
+ my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n";
+ my $t = (substr($string, 1, 1) eq '-') ? '' : "\n";
+ return join( $j, @multiline ) . $t;
+}
+
+# Load an array
+sub _load_array {
+ my ($self, $array, $indent, $lines) = @_;
+
+ while ( @$lines ) {
+ # Check for a new document
+ if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
+ while ( @$lines and $lines->[0] !~ /^---/ ) {
+ shift @$lines;
+ }
+ return 1;
+ }
+
+ # Check the indent level
+ $lines->[0] =~ /^(\s*)/;
+ if ( length($1) < $indent->[-1] ) {
+ return 1;
+ } elsif ( length($1) > $indent->[-1] ) {
+ die \"YAML::Tiny found bad indenting in line '$lines->[0]'";
+ }
+
+ if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) {
+ # Inline nested hash
+ my $indent2 = length("$1");
+ $lines->[0] =~ s/-/ /;
+ push @$array, { };
+ $self->_load_hash( $array->[-1], [ @$indent, $indent2 ], $lines );
+
+ } elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) {
+ shift @$lines;
+ unless ( @$lines ) {
+ push @$array, undef;
+ return 1;
+ }
+ if ( $lines->[0] =~ /^(\s*)\-/ ) {
+ my $indent2 = length("$1");
+ if ( $indent->[-1] == $indent2 ) {
+ # Null array entry
+ push @$array, undef;
+ } else {
+ # Naked indenter
+ push @$array, [ ];
+ $self->_load_array(
+ $array->[-1], [ @$indent, $indent2 ], $lines
+ );
+ }
+
+ } elsif ( $lines->[0] =~ /^(\s*)\S/ ) {
+ push @$array, { };
+ $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...
+ # ---
+ # foo:
+ # - list
+ # bar: value
+ #
+ # ... so lets return and let the hash parser handle it
+ return 1;
+
+ } else {
+ die \"YAML::Tiny failed to classify line '$lines->[0]'";
+ }
+ }
+
+ return 1;
+}
+
+# Load a hash
+sub _load_hash {
+ my ($self, $hash, $indent, $lines) = @_;
+
+ while ( @$lines ) {
+ # Check for a new document
+ if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
+ while ( @$lines and $lines->[0] !~ /^---/ ) {
+ shift @$lines;
+ }
+ return 1;
+ }
+
+ # Check the indent level
+ $lines->[0] =~ /^(\s*)/;
+ if ( length($1) < $indent->[-1] ) {
+ return 1;
+ } elsif ( length($1) > $indent->[-1] ) {
+ die \"YAML::Tiny found bad indenting 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]'";
+ }
+
+ # Do we have a value?
+ if ( length $lines->[0] ) {
+ # Yes
+ $hash->{$key} = $self->_load_scalar(
+ shift(@$lines), [ @$indent, undef ], $lines
+ );
+ } else {
+ # An indent
+ shift @$lines;
+ unless ( @$lines ) {
+ $hash->{$key} = undef;
+ return 1;
+ }
+ if ( $lines->[0] =~ /^(\s*)-/ ) {
+ $hash->{$key} = [];
+ $self->_load_array(
+ $hash->{$key}, [ @$indent, length($1) ], $lines
+ );
+ } elsif ( $lines->[0] =~ /^(\s*)./ ) {
+ my $indent2 = length("$1");
+ if ( $indent->[-1] >= $indent2 ) {
+ # Null hash entry
+ $hash->{$key} = undef;
+ } else {
+ $hash->{$key} = {};
+ $self->_load_hash(
+ $hash->{$key}, [ @$indent, length($1) ], $lines
+ );
+ }
+ }
+ }
+ }
+
+ return 1;
+}
+
+
+###
+# Dumper functions:
+
+# Save an object to a file
+sub _dump_file {
+ my $self = shift;
+
+ 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 );
+ unless ( $fh ) {
+ $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 _dump_string {
+ my $self = shift;
+ return '' unless ref $self && @$self;
+
+ # Iterate over the documents
+ my $indent = 0;
+ my @lines = ();
+
+ eval {
+ foreach my $cursor ( @$self ) {
+ push @lines, '---';
+
+ # 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 _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 (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 =~ /(?:^[~!@#%&*|>?:,'"`{}\[\]]|^-+$|\s|:\z)/ or
+ $QUOTE{$string}
+ ) {
+ return "'$string'";
+ }
+ return $string;
+}
+
+sub _dump_array {
+ my ($self, $array, $indent, $seen) = @_;
+ if ( $seen->{refaddr($array)}++ ) {
+ 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->_dump_scalar( $el );
+ push @lines, $line;
+
+ } elsif ( $type eq 'ARRAY' ) {
+ if ( @$el ) {
+ push @lines, $line;
+ push @lines, $self->_dump_array( $el, $indent + 1, $seen );
+ } else {
+ $line .= ' []';
+ push @lines, $line;
+ }
+
+ } elsif ( $type eq 'HASH' ) {
+ if ( keys %$el ) {
+ push @lines, $line;
+ push @lines, $self->_dump_hash( $el, $indent + 1, $seen );
+ } else {
+ $line .= ' {}';
+ push @lines, $line;
+ }
+
+ } else {
+ die \"YAML::Tiny does not support $type references";
+ }
+ }
+
+ @lines;
+}
+
+sub _dump_hash {
+ my ($self, $hash, $indent, $seen) = @_;
+ if ( $seen->{refaddr($hash)}++ ) {
+ die \"YAML::Tiny does not support circular references";
+ }
+ my @lines = ();
+ foreach my $name ( sort keys %$hash ) {
+ my $el = $hash->{$name};
+ my $line = (' ' x $indent) . $self->_dump_scalar($name, 1) . ":";
+ my $type = ref $el;
+ if ( ! $type ) {
+ $line .= ' ' . $self->_dump_scalar( $el );
+ push @lines, $line;
+
+ } elsif ( $type eq 'ARRAY' ) {
+ if ( @$el ) {
+ push @lines, $line;
+ push @lines, $self->_dump_array( $el, $indent + 1, $seen );
+ } else {
+ $line .= ' []';
+ push @lines, $line;
+ }
+
+ } elsif ( $type eq 'HASH' ) {
+ if ( keys %$el ) {
+ push @lines, $line;
+ push @lines, $self->_dump_hash( $el, $indent + 1, $seen );
+ } else {
+ $line .= ' {}';
+ push @lines, $line;
+ }
+
+ } else {
+ 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 {
+ require Carp;
+ $errstr = $_[1];
+ $errstr =~ s/ at \S+ line \d+.*//;
+ Carp::croak( $errstr );
+}
+
+# Retrieve error
+my $errstr_warned;
+sub errstr {
+ require Carp;
+ Carp::carp( "YAML::Tiny->errstr and \$YAML::Tiny::errstr is deprecated" )
+ unless $errstr_warned++;
+ $errstr;
+}
+
+
+
+
+#####################################################################
+# Helper functions. Possibly not needed.
+
+
+# Use to detect nv or iv
+use B;
+
+# 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;
+ }
+ 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
+
+BEGIN {
+ local $@;
+ if ( eval { require Scalar::Util; Scalar::Util->VERSION(1.18); } ) {
+ *refaddr = *Scalar::Util::refaddr;
+ }
+ else {
+ eval <<'END_PERL';
+# Scalar::Util failed to load or too old
+sub refaddr {
+ my $pkg = ref($_[0]) or return undef;
+ if ( !! UNIVERSAL::can($_[0], 'can') ) {
+ bless $_[0], 'Scalar::Util::Fake';
+ } else {
+ $pkg = undef;
+ }
+ "$_[0]" =~ /0x(\w+)/;
+ my $i = do { no warnings 'portable'; hex $1 };
+ bless $_[0], $pkg if defined $pkg;
+ $i;
+}
+END_PERL
+ }
+}
+
+
+
+
+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 1488
diff --git a/inc/unicore/Name.pm b/inc/unicore/Name.pm
new file mode 100644
index 0000000..d72eb6e
--- /dev/null
+++ b/inc/unicore/Name.pm
@@ -0,0 +1,417 @@
+#line 1
+# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+# This file is machine-generated by lib/unicore/mktables from the Unicode
+# database, Version 6.3.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. Use Unicode::UCD to access the Unicode character data
+# base.
+
+
+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;
diff --git a/lib/RT/Extension/ResetPassword.pm b/lib/RT/Extension/ResetPassword.pm
index cf2fde3..a61c3fb 100644
--- a/lib/RT/Extension/ResetPassword.pm
+++ b/lib/RT/Extension/ResetPassword.pm
@@ -3,7 +3,7 @@ package RT::Extension::ResetPassword;
use strict;
use warnings;
-our $VERSION = '0.06';
+our $VERSION = '1.00';
=head1 NAME
@@ -47,7 +47,7 @@ If you are using RT 4.2 or greater, add this line:
Plugin('RT::Extension::ResetPassword');
-For RT 3.8 and 4.0, add this line:
+For RT 4.0, add this line:
Set(@Plugins, qw(RT::Extension::ResetPassword));
@@ -82,17 +82,25 @@ logged with an appropriate diagnostic message.
=head1 AUTHOR
-Jesse Vincent <jesse at bestpractical.com>
+Best Practical Solutions, LLC E<lt>modules at bestpractical.comE<gt>
+
+=head1 BUGS
+
+All bugs should be reported via email to
+
+ L<bug-RT-Extension-ResetPassword at rt.cpan.org|mailto:bug-RT-Extension-ResetPassword at rt.cpan.org>
+
+or via the web at
+
+ L<rt.cpan.org|http://rt.cpan.org/Public/Dist/Display.html?Name=RT-Extension-ResetPassword>.
=head1 LICENSE AND COPYRIGHT
-Copyright 2006-2014 Best Practical Solutions, LLC.
+This software is Copyright (c) 2012-2014 by Best Practical Solutions, LLC
-This program is free software; you can redistribute it and/or modify it
-under the terms of either: the GNU General Public License as published
-by the Free Software Foundation; or the Artistic License.
+This is free software, licensed under:
-See http://dev.perl.org/licenses/ for more information.
+ The GNU General Public License, Version 2, June 1991
=cut
-----------------------------------------------------------------------
More information about the Bps-public-commit
mailing list