[Bps-public-commit] RT-Extension-SLA branch, master, updated. 1.04-4-gf4caea1

? sunnavy sunnavy at bestpractical.com
Mon Jul 20 12:08:07 EDT 2015


The branch, master has been updated
       via  f4caea122929985b05773e8283f8d4a6c9740516 (commit)
       via  12ea3548438089dd8a113db852e04318dde3c4bb (commit)
       via  5885948d1a7bbe7cbfcfda7f766eafe912d996b2 (commit)
      from  8f611d9fed3fd3afbb237b5cf75c361743147e77 (commit)

Summary of changes:
 MANIFEST                          |   1 -
 META.yml                          |   4 +-
 README                            |  20 +-
 inc/Module/AutoInstall.pm         |   4 +-
 inc/Module/Install.pm             |   6 +-
 inc/Module/Install/AutoInstall.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     |   2 +-
 inc/Module/Install/Makefile.pm    |   2 +-
 inc/Module/Install/Metadata.pm    |   2 +-
 inc/Module/Install/RTx.pm         |   4 +-
 inc/Module/Install/Win32.pm       |   2 +-
 inc/Module/Install/WriteAll.pm    |   2 +-
 inc/YAML/Tiny.pm                  |  29 +--
 inc/unicore/Name.pm               | 417 --------------------------------------
 lib/RT/Action/SLA_SetDue.pm       |  23 ---
 lib/RT/Extension/SLA.pm           |  66 +++++-
 19 files changed, 100 insertions(+), 492 deletions(-)
 delete mode 100644 inc/unicore/Name.pm

- Log -----------------------------------------------------------------
commit 5885948d1a7bbe7cbfcfda7f766eafe912d996b2
Author: sunnavy <sunnavy at bestpractical.com>
Date:   Sun Jul 12 21:27:54 2015 +0800

    Revert "new option RecalculateDueOnIgnoredStatusChange"
    
    This reverts commit 8f611d9fed3fd3afbb237b5cf75c361743147e77.
    
    we are gonna implement a more reasonable feature to replace this.

diff --git a/README b/README
index e5b10ef..bd3c29b 100644
--- a/README
+++ b/README
@@ -263,17 +263,7 @@ CONFIGURATION
     result of RT's auto-open on reply scrip, therefore ensuring there's a
     new reply to calculate Due from. The overall effect is that ignored
     statuses don't let the Due date drift arbitrarily, which could wreak
-    havoc on your SLA performance. The option
-    RecalculateDueOnIgnoredStatusChange could get around the "probably be
-    overdue" issue by considering the last ignored status date too. e.g.
-
-        'level x' => {
-            KeepInLoop => {
-                BusinessMinutes => 60,
-                RecalculateDueOnIgnoredStatusChange => 1,
-                IgnoreOnStatuses => ['stalled'],
-            },
-        },
+    havoc on your SLA performance.
 
   Configuring business hours
     In the config you can set one or more work schedules. Use the following
diff --git a/lib/RT/Action/SLA_SetDue.pm b/lib/RT/Action/SLA_SetDue.pm
index f837e86..4f3ed30 100644
--- a/lib/RT/Action/SLA_SetDue.pm
+++ b/lib/RT/Action/SLA_SetDue.pm
@@ -43,16 +43,6 @@ sub Commit {
         .' to ticket #'. $ticket->id .' is txn #'. $last_reply->id
     );
 
-    my $meta =
-        $RT::ServiceAgreements{ 'Levels' }{ $level }
-      ? $RT::ServiceAgreements{ 'Levels' }{ $level }{ $is_outside ? 'Response' : 'KeepInLoop' }
-      : undef;
-    if ( $meta && $meta->{IgnoreOnStatuses} && $meta->{RecalculateDueOnIgnoredStatusChange} ) {
-        my $last_ignored_status_txn = $self->LastIgnoredStatusAct(@{$meta->{IgnoreOnStatuses}});
-        $last_reply = $last_ignored_status_txn
-          if $last_ignored_status_txn && $last_reply->Created lt $last_ignored_status_txn->Created;
-    }
-
     my $response_due = $self->Due(
         Ticket => $ticket,
         Level => $level,
@@ -119,17 +109,4 @@ sub LastEffectiveAct {
     return ($res, 1);
 }
 
-sub LastIgnoredStatusAct {
-    my $self = shift;
-    my @statuses = @_;
-    my $txns = $self->TicketObj->Transactions;
-    $txns->Limit( FIELD => 'FIELD', VALUE => 'Status' );
-    $txns->Limit( FIELD => 'OldValue', OPERATOR => 'IN', VALUE => \@statuses );
-    $txns->OrderByCols(
-        { FIELD => 'Created', ORDER => 'DESC' },
-        { FIELD => 'id', ORDER => 'DESC' },
-    );
-    return $txns->First;
-}
-
 1;
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index b386cce..1b375e8 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -305,18 +305,6 @@ out of stalled-like statuses is often the result of RT's auto-open on reply
 scrip, therefore ensuring there's a new reply to calculate Due from.  The
 overall effect is that ignored statuses don't let the Due date drift
 arbitrarily, which could wreak havoc on your SLA performance.
-The option C<RecalculateDueOnIgnoredStatusChange> could get around the
-"probably be overdue" issue by considering the last ignored status date too.
-e.g.
-
-    'level x' => {
-        KeepInLoop => {
-            BusinessMinutes => 60,
-            RecalculateDueOnIgnoredStatusChange => 1,
-            IgnoreOnStatuses => ['stalled'],
-        },
-    },
-
 
 =head2 Configuring business hours
 

commit 12ea3548438089dd8a113db852e04318dde3c4bb
Author: sunnavy <sunnavy at bestpractical.com>
Date:   Mon Jul 13 20:16:48 2015 +0800

    new ExcludeTimeOnIgnoredStatuses option

diff --git a/README b/README
index bd3c29b..e5c710d 100644
--- a/README
+++ b/README
@@ -263,7 +263,17 @@ CONFIGURATION
     result of RT's auto-open on reply scrip, therefore ensuring there's a
     new reply to calculate Due from. The overall effect is that ignored
     statuses don't let the Due date drift arbitrarily, which could wreak
-    havoc on your SLA performance.
+    havoc on your SLA performance. ExcludeTimeOnIgnoredStatuses option could
+    get around the "probably be overdue" issue by excluding the time spent
+    on ignored statuses.
+
+            'level x' => {
+                KeepInLoop => {
+                    BusinessMinutes => 60,
+                    ExcludeTimeOnIgnoredStatuses => 1,
+                    IgnoreOnStatuses => ['stalled'],
+                },
+            },
 
   Configuring business hours
     In the config you can set one or more work schedules. Use the following
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index 1b375e8..e76bf9d 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -305,6 +305,16 @@ out of stalled-like statuses is often the result of RT's auto-open on reply
 scrip, therefore ensuring there's a new reply to calculate Due from.  The
 overall effect is that ignored statuses don't let the Due date drift
 arbitrarily, which could wreak havoc on your SLA performance.
+ExcludeTimeOnIgnoredStatuses option could get around the "probably be
+overdue" issue by excluding the time spent on ignored statuses.
+
+        'level x' => {
+            KeepInLoop => {
+                BusinessMinutes => 60,
+                ExcludeTimeOnIgnoredStatuses => 1,
+                IgnoreOnStatuses => ['stalled'],
+            },
+        },
 
 =head2 Configuring business hours
 
@@ -483,6 +493,52 @@ sub CalculateTime {
             }
         }
 
+        if (   $args{ Ticket }
+            && $agreement->{ IgnoreOnStatuses }
+            && $agreement->{ ExcludeTimeOnIgnoredStatuses } )
+        {
+            my $txns = RT::Transactions->new( RT->SystemUser );
+            $txns->LimitToTicket($args{Ticket}->id);
+            $txns->Limit(
+                FIELD => 'Field',
+                VALUE => 'Status',
+            );
+            my $date = RT::Date->new( RT->SystemUser );
+            $date->Set( Value => $args{ Time } );
+            $txns->Limit(
+                FIELD    => 'Created',
+                OPERATOR => '>=',
+                VALUE    => $date->ISO( Timezone => 'UTC' ),
+            );
+
+            my $last_time = $args{ Time };
+            while ( my $txn = $txns->Next ) {
+                if ( grep( { $txn->OldValue eq $_ } @{ $agreement->{ IgnoreOnStatuses } } ) ) {
+                    if ( !grep( { $txn->NewValue eq $_ } @{ $agreement->{ IgnoreOnStatuses } } ) ) {
+                        if ( defined $agreement->{ 'BusinessMinutes' } ) {
+
+                            # re-init $bhours to make sure we don't have a cached start/end,
+                            # so the time here is not outside the calculated business hours
+
+                            my $bhours = $self->BusinessHours( $agreement->{ 'BusinessHours' } );
+                            my $time = $bhours->between( $last_time, $txn->CreatedObj->Unix );
+                            if ( $time > 0 ) {
+                                $res = $bhours->add_seconds( $res, $time );
+                            }
+                        }
+                        else {
+                            my $time = $txn->CreatedObj->Unix - $last_time;
+                            $res += $time;
+                        }
+                        $last_time = $txn->CreatedObj->Unix;
+                    }
+                }
+                else {
+                    $last_time = $txn->CreatedObj->Unix;
+                }
+            }
+        }
+
         if ( defined $agreement->{'BusinessMinutes'} ) {
             if ( $agreement->{'BusinessMinutes'} ) {
                 $res = $bhours->add_seconds(

commit f4caea122929985b05773e8283f8d4a6c9740516
Author: sunnavy <sunnavy at bestpractical.com>
Date:   Mon Jul 13 20:17:22 2015 +0800

    update package files

diff --git a/MANIFEST b/MANIFEST
index 5b6e78c..b117a19 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -16,7 +16,6 @@ inc/Module/Install/RTx/Runtime.pm
 inc/Module/Install/Substitute.pm
 inc/Module/Install/Win32.pm
 inc/Module/Install/WriteAll.pm
-inc/unicore/Name.pm
 inc/YAML/Tiny.pm
 lib/RT/Action/SLA.pm
 lib/RT/Action/SLA_SetDefault.pm
diff --git a/META.yml b/META.yml
index af184ed..142a8e1 100644
--- a/META.yml
+++ b/META.yml
@@ -9,7 +9,7 @@ configure_requires:
   ExtUtils::MakeMaker: 6.59
 distribution_type: module
 dynamic_config: 1
-generated_by: 'Module::Install version 1.12'
+generated_by: 'Module::Install version 1.16'
 license: gpl
 meta-spec:
   url: http://module-build.sourceforge.net/META-spec-v1.4.html
@@ -29,6 +29,6 @@ resources:
   license: http://opensource.org/licenses/gpl-license.php
   repository: https://github.com/bestpractical/rt-extension-sla
 version: '1.04'
-x_module_install_rtx_version: '0.36'
+x_module_install_rtx_version: '0.37'
 x_requires_rt: 4.0.0
 x_rt_too_new: 4.4.0
diff --git a/inc/Module/AutoInstall.pm b/inc/Module/AutoInstall.pm
index 4aca606..22dfa82 100644
--- a/inc/Module/AutoInstall.pm
+++ b/inc/Module/AutoInstall.pm
@@ -8,7 +8,7 @@ use ExtUtils::MakeMaker ();
 
 use vars qw{$VERSION};
 BEGIN {
-	$VERSION = '1.12';
+	$VERSION = '1.16';
 }
 
 # special map on pre-defined feature sets
@@ -537,7 +537,7 @@ sub _install_cpan {
     while ( my ( $opt, $arg ) = splice( @config, 0, 2 ) ) {
         ( $args{$opt} = $arg, next )
           if $opt =~ /^(?:force|notest)$/;    # pseudo-option
-        $CPAN::Config->{$opt} = $arg;
+        $CPAN::Config->{$opt} = $opt eq 'urllist' ? [$arg] : $arg;
     }
 
     if ($args{notest} && (not CPAN::Shell->can('notest'))) {
diff --git a/inc/Module/Install.pm b/inc/Module/Install.pm
index 5460dd5..f44ab4d 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.12';
+	$VERSION = '1.16';
 
 	# Storage for the pseudo-singleton
 	$MAIN    = undef;
@@ -378,6 +378,7 @@ eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
 sub _read {
 	local *FH;
 	open( FH, '<', $_[0] ) or die "open($_[0]): $!";
+	binmode FH;
 	my $string = do { local $/; <FH> };
 	close FH or die "close($_[0]): $!";
 	return $string;
@@ -386,6 +387,7 @@ END_NEW
 sub _read {
 	local *FH;
 	open( FH, "< $_[0]"  ) or die "open($_[0]): $!";
+	binmode FH;
 	my $string = do { local $/; <FH> };
 	close FH or die "close($_[0]): $!";
 	return $string;
@@ -416,6 +418,7 @@ eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
 sub _write {
 	local *FH;
 	open( FH, '>', $_[0] ) or die "open($_[0]): $!";
+	binmode FH;
 	foreach ( 1 .. $#_ ) {
 		print FH $_[$_] or die "print($_[0]): $!";
 	}
@@ -425,6 +428,7 @@ END_NEW
 sub _write {
 	local *FH;
 	open( FH, "> $_[0]"  ) or die "open($_[0]): $!";
+	binmode FH;
 	foreach ( 1 .. $#_ ) {
 		print FH $_[$_] or die "print($_[0]): $!";
 	}
diff --git a/inc/Module/Install/AutoInstall.pm b/inc/Module/Install/AutoInstall.pm
index ab1e5fa..e19d259 100644
--- a/inc/Module/Install/AutoInstall.pm
+++ b/inc/Module/Install/AutoInstall.pm
@@ -6,7 +6,7 @@ use Module::Install::Base ();
 
 use vars qw{$VERSION @ISA $ISCORE};
 BEGIN {
-	$VERSION = '1.12';
+	$VERSION = '1.16';
 	@ISA     = 'Module::Install::Base';
 	$ISCORE  = 1;
 }
diff --git a/inc/Module/Install/Base.pm b/inc/Module/Install/Base.pm
index f9bf5de..5762a74 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.12';
+	$VERSION = '1.16';
 }
 
 # Suspend handler for "redefined" warnings
diff --git a/inc/Module/Install/Can.pm b/inc/Module/Install/Can.pm
index b4e5e3b..d859276 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.12';
+	$VERSION = '1.16';
 	@ISA     = 'Module::Install::Base';
 	$ISCORE  = 1;
 }
diff --git a/inc/Module/Install/Fetch.pm b/inc/Module/Install/Fetch.pm
index 54f14fb..41d3517 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.12';
+	$VERSION = '1.16';
 	@ISA     = 'Module::Install::Base';
 	$ISCORE  = 1;
 }
diff --git a/inc/Module/Install/Include.pm b/inc/Module/Install/Include.pm
index 7224cff..2eb1d1f 100644
--- a/inc/Module/Install/Include.pm
+++ b/inc/Module/Install/Include.pm
@@ -6,7 +6,7 @@ use Module::Install::Base ();
 
 use vars qw{$VERSION @ISA $ISCORE};
 BEGIN {
-	$VERSION = '1.12';
+	$VERSION = '1.16';
 	@ISA     = 'Module::Install::Base';
 	$ISCORE  = 1;
 }
diff --git a/inc/Module/Install/Makefile.pm b/inc/Module/Install/Makefile.pm
index 81cddd5..e9918d2 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.12';
+	$VERSION = '1.16';
 	@ISA     = 'Module::Install::Base';
 	$ISCORE  = 1;
 }
diff --git a/inc/Module/Install/Metadata.pm b/inc/Module/Install/Metadata.pm
index 2c66b1e..9792685 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.12';
+	$VERSION = '1.16';
 	@ISA     = 'Module::Install::Base';
 	$ISCORE  = 1;
 }
diff --git a/inc/Module/Install/RTx.pm b/inc/Module/Install/RTx.pm
index 73e7245..97acf77 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.36';
+our $VERSION = '0.37';
 
 use FindBin;
 use File::Glob     ();
@@ -123,7 +123,7 @@ install ::
         $has_etc{acl}++;
     }
     if ( -e 'etc/initialdata' ) { $has_etc{initialdata}++; }
-    if ( grep { /\d+\.\d+(\.\d+)?.*$/ } glob('etc/upgrade/*.*') ) {
+    if ( grep { /\d+\.\d+\.\d+.*$/ } glob('etc/upgrade/*.*.*') ) {
         $has_etc{upgrade}++;
     }
 
diff --git a/inc/Module/Install/Win32.pm b/inc/Module/Install/Win32.pm
index e48c32d..218a66b 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.12';
+	$VERSION = '1.16';
 	@ISA     = 'Module::Install::Base';
 	$ISCORE  = 1;
 }
diff --git a/inc/Module/Install/WriteAll.pm b/inc/Module/Install/WriteAll.pm
index 409ef40..530749b 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.12';
+	$VERSION = '1.16';
 	@ISA     = qw{Module::Install::Base};
 	$ISCORE  = 1;
 }
diff --git a/inc/YAML/Tiny.pm b/inc/YAML/Tiny.pm
index 1be0cb1..3e0837a 100644
--- a/inc/YAML/Tiny.pm
+++ b/inc/YAML/Tiny.pm
@@ -2,16 +2,12 @@
 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';
+package YAML::Tiny; # git description: v1.66-5-ge09e1ae
 # 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.67';
 
 #####################################################################
 # The YAML::Tiny API.
@@ -300,10 +296,11 @@ Did you decode with lax ":utf8" instead of strict ":encoding(UTF-8)"?
             }
         }
     };
-    if ( ref $@ eq 'SCALAR' ) {
-        $self->_error(${$@});
-    } elsif ( $@ ) {
-        $self->_error($@);
+    my $err = $@;
+    if ( ref $err eq 'SCALAR' ) {
+        $self->_error(${$err});
+    } elsif ( $err ) {
+        $self->_error($err);
     }
 
     return $self;
@@ -515,6 +512,10 @@ sub _load_hash {
             die \"YAML::Tiny failed to classify line '$lines->[0]'";
         }
 
+        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
@@ -828,9 +829,10 @@ sub _can_flock {
 #####################################################################
 # Use Scalar::Util if possible, otherwise emulate it
 
+use Scalar::Util ();
 BEGIN {
     local $@;
-    if ( eval { require Scalar::Util; Scalar::Util->VERSION(1.18); } ) {
+    if ( eval { Scalar::Util->VERSION(1.18); } ) {
         *refaddr = *Scalar::Util::refaddr;
     }
     else {
@@ -852,8 +854,7 @@ END_PERL
     }
 }
 
-
-
+delete $YAML::Tiny::{refaddr};
 
 1;
 
@@ -870,4 +871,4 @@ END_PERL
 
 __END__
 
-#line 1488
+#line 1489
diff --git a/inc/unicore/Name.pm b/inc/unicore/Name.pm
deleted file mode 100644
index d72eb6e..0000000
--- a/inc/unicore/Name.pm
+++ /dev/null
@@ -1,417 +0,0 @@
-#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;

-----------------------------------------------------------------------


More information about the Bps-public-commit mailing list