File Coverage

blib/lib/Unicode/Casing.pm

Criterion	Covered	Total	%
statement	53	63	84.1
branch	15	34	44.1
condition	15	18	83.3
subroutine	12	12	100.0
pod	0	2	0.0
total	95	129	73.6

package Unicode::Casing;    # pod is after __END__ in this file

require 5.010;  # Because of Perl bugs; can work on earlier Perls with care
use strict;
use warnings;
use Carp;
use B::Hooks::OP::Check;
use B::Hooks::OP::PPAddr;

require Exporter;

our @ISA = qw(Exporter);

our @EXPORT_OK = ();

our @EXPORT = ();

our $VERSION = '0.16';

require XSLoader;
XSLoader::load('Unicode::Casing', $VERSION);

# List of references to functions that are overridden by this module
# anywhere in the program.  Each gets a unique id, which is its index
# into this list.
my @_function_list;

our @recursed;
local @recursed;

# The way it works is that each function that is overridden has a
# reference stored to it in the array.  The index in the array to it is
# stored in %^H with the key being the name of the overridden function,
# like 'uc'.  This keeps track of scoping.  A .xs function is set up to
# intercept calls to the overridden-functions, and it calls _dispatch
# with the name of the function which was being called and the string to
# change the case of. _dispatch looks up the function name in %^H to
# find the index which in turn yields the function reference.  If there
# is no overridden function, the core one is called instead.  (This can
# happen when part of the core code processing a call to one of these
# functions itself calls a casing function, as happens with Unicode
# table look-ups.)

my $fc_glob;

# This is a work-around, suggested by Matt S. Trout, to the problem that
# CORE::fc() is a syntax error on Perls prior to v5.15.8.  We have to avoid
# compiling that expression on those Perls, but we want the compile-time
# version of it on Perls that handle it.  Another solution would be to put it
# in a sub module that is loaded with a 'use if,'.  We want CORE:: to get the
# official version.  We can't do a string eval or otherwise defer this to
# runtime, because by the time _dispatch is called, the op has been replaced,
# and we would get infinite recursion.
# Actually, I'm not sure the CORE:: is actually needed at all, but am leaving
# it in just to be safe.
BEGIN {
    no strict;
    $fc_glob = \*{"CORE::fc"} if $^V ge v5.15.8;
}

sub _dispatch {
    my ($string, $function) = @_;

    # Called by the XS op-interceptor to look for the correct user-defined
    # function, and call it.
    #   $string is the scalar whose case is being changed
    #   $function is the generic name, like 'uc', of the case-changing
    #       function.

    return if ! defined $string;

    # This is the key that should be stored in the hash hints for this
    # function if overridden
    my $key = id_key($function);

    # For reasons I don't understand, the intermediate $hints_hash_ref cannot
    # be skipped; in 5.13.11 anyway.
    my $hints_hash_ref = (caller(0))[10];

    my $index = $hints_hash_ref->{$key};

    if (! defined $index # Not overridden
        || defined $recursed[$index])
    {
        return CORE::uc($string) if $function eq 'uc';
        return CORE::lc($string) if $function eq 'lc';
        return CORE::ucfirst($string) if $function eq 'ucfirst';
        return CORE::lcfirst($string) if $function eq 'lcfirst';
        return &$fc_glob($string) if $function eq 'fc';
    }

    local $recursed[$index] = $string;

    # Force scalar context and returning exactly one value;
    my $ret = &{$_function_list[$index]}($string);
    return $ret;
}

sub setup_key { # key into %^H for value returned from setup();
    return __PACKAGE__ . "_setup_" . shift;
}

sub id_key { # key into %^H for index into @_function_list
    return __PACKAGE__ . "_id_" . shift;
}

sub import {
    shift;  # Ignore 'casing' parameter.

    my %args;

    while (my $function = shift) {
        return if $function eq '-load';
        my $user_sub;
        if (! defined ($user_sub = shift)) {
            croak("Missing CODE reference for $function");
        }
        if (ref $user_sub ne 'CODE') {
            croak("$user_sub (for $function) is not a CODE reference");
        }
        if ($function ne 'uc' && $function ne 'lc'
            && $function ne 'ucfirst' && $function ne 'lcfirst'
            && ! ($function eq 'fc' && $^V ge v5.15.8))
        {
            my $msg = "$function must be one of: 'uc', 'lc', 'ucfirst', 'lcfirst'";
            $msg .= ", 'fc'" if $^V ge v5.15.8;
            croak($msg);
        }
        elsif (exists $args{$function}) {
            croak("Only one override for \"$function\" is allowed");
        }
        $args{$function} = 1;

        push @_function_list, $user_sub;
        $^H{id_key($function)} = scalar @_function_list - 1;

        # Remove any existing override in the current scope
        my $setup_key = setup_key($function);
        teardown($function, $^H{$setup_key}) if exists $^H{$setup_key};

        # Save code returned so can tear down upon unimport();
        $^H{$setup_key} = setup($function);
    }

    croak("Must specify at least one case override") unless %args;
    return;
}

sub unimport {
    foreach my $function (qw(lc uc lcfirst ucfirst fc)) {
        my $id = $^H{setup_key($function)};
        teardown($function, $id) if defined $id;
    }
    return;
}

1;
__END__