File Coverage

blib/lib/utf8/all.pm

Criterion	Covered	Total	%
statement	91	93	97.8
branch	34	48	70.8
condition	3	3	100.0
subroutine	16	16	100.0
pod			n/a
total	144	160	90.0

package utf8::all;
use strict;
use warnings;
use 5.010; # state

# ABSTRACT: turn on Unicode - all of it
our $VERSION = '0.022'; # VERSION

#pod =head1 SYNOPSIS
#pod
#pod     use utf8::all;                      # Turn on UTF-8, all of it.
#pod
#pod     open my $in, '<', 'contains-utf8';  # UTF-8 already turned on here
#pod     print length 'føø bār';             # 7 UTF-8 characters
#pod     my $utf8_arg = shift @ARGV;         # @ARGV is UTF-8 too (only for main)
#pod
#pod =head1 DESCRIPTION
#pod
#pod The C pragma tells the Perl parser to allow UTF-8 in the
#pod program text in the current lexical scope. This also means that you
#pod can now use literal Unicode characters as part of strings, variable
#pod names, and regular expressions.
#pod
#pod C goes further:
#pod
#pod =over 4
#pod
#pod =item *
#pod
#pod L|charnames> are imported so C<\N{...}> sequences can be
#pod used to compile Unicode characters based on names.
#pod
#pod =item *
#pod
#pod On Perl C or higher, the C is
#pod enabled.
#pod
#pod =item *
#pod
#pod C and C are enabled on Perl
#pod C<5.16.0> and higher.
#pod
#pod =item *
#pod
#pod Filehandles are opened with UTF-8 encoding turned on by default
#pod (including STDIN, STDOUT, STDERR). Meaning that they automatically
#pod convert UTF-8 octets to characters and vice versa. If you I
#pod want UTF-8 for a particular filehandle, you'll have to set C
#pod $filehandle>.
#pod
#pod =item *
#pod
#pod C<@ARGV> gets converted from UTF-8 octets to Unicode characters (when
#pod C is used from the main package). This is similar to the
#pod behaviour of the C<-CA> perl command-line switch (see L).
#pod
#pod =item *
#pod
#pod C, C, C (including the C and
#pod backtick operators), and L|perlfunc/glob> (including the C<< <>
#pod >> operator) now all work with and return Unicode characters instead
#pod of (UTF-8) octets.
#pod
#pod =back
#pod
#pod =head2 Lexical Scope
#pod
#pod The pragma is lexically-scoped, so you can do the following if you had
#pod some reason to:
#pod
#pod     {
#pod         use utf8::all;
#pod         open my $out, '>', 'outfile';
#pod         my $utf8_str = 'føø bār';
#pod         print length $utf8_str, "\n"; # 7
#pod         print $out $utf8_str;         # out as utf8
#pod     }
#pod     open my $in, '<', 'outfile';      # in as raw
#pod     my $text = do { local $/; <$in>};
#pod     print length $text, "\n";         # 10, not 7!
#pod
#pod Instead of lexical scoping, you can also use C to turn
#pod off the effects.
#pod
#pod Note that the effect on C<@ARGV> and the C, C, and
#pod C file handles is always global!
#pod
#pod =head2 UTF-8 Errors
#pod
#pod C will handle invalid code points (i.e., utf-8 that does
#pod not map to a valid unicode "character"), as a fatal error.
#pod
#pod For C, C, and C, one can change this
#pod behaviour by setting the attribute L.
#pod
#pod =head1 COMPATIBILITY
#pod
#pod The filesystems of Dos, Windows, and OS/2 do not (fully) support
#pod UTF-8. The C and C functions and C operators
#pod will therefore not be replaced on these systems.
#pod
#pod =head1 SEE ALSO
#pod
#pod =over 4
#pod
#pod =item *
#pod
#pod L for fully utf-8 aware File::Find functions.
#pod
#pod =item *
#pod
#pod L for fully utf-8 aware Cwd functions.
#pod
#pod =back
#pod
#pod =cut

use Import::Into;
use parent qw(Encode charnames utf8 open warnings feature);
use Symbol qw(qualify_to_ref);
use Config;

# Holds the pointers to the original version of redefined functions
state %_orig_functions;

# Current (i.e., this) package
my $current_package = __PACKAGE__;

require Carp;
$Carp::Internal{$current_package}++; # To get warnings reported at correct caller level

#pod =attr $utf8::all::UTF8_CHECK
#pod
#pod By default C marks decoding errors as fatal (default value
#pod for this setting is C). If you want, you can change this by
#pod setting C<$utf8::all::UTF8_CHECK>. The value C reports
#pod the encoding errors as warnings, and C will completely
#pod ignore them. Please see L for details. Note: C is
#pod I enforced.
#pod
#pod Important: Only controls the handling of decoding errors in C,
#pod C, and C.
#pod
#pod =cut

use Encode ();
use PerlIO::utf8_strict;

our $UTF8_CHECK = Encode::FB_CROAK | Encode::LEAVE_SRC; # Die on encoding errors

# UTF-8 Encoding object
my $_UTF8 = Encode::find_encoding('UTF-8');

sub import {
    # Enable features/pragmas in calling package
    my $target = caller;

    'utf8'->import::into($target);
    'open'->import::into($target, 'IO' => ':utf8_strict');

    # use open ':std' only works with some encodings.
    state $have_encoded_std = 0;
    if (!$have_encoded_std++) {
        binmode STDERR, ':utf8_strict';
        binmode STDOUT, ':utf8_strict';
        binmode STDIN,  ':utf8_strict';
    }

    'charnames'->import::into($target, qw{:full :short});
    'warnings'->import::into($target, qw{FATAL utf8});
    'feature'->import::into($target, qw{unicode_strings}) if $^V >= v5.11.0;
    'feature'->import::into($target, qw{unicode_eval fc}) if $^V >= v5.16.0;

    unless ($^O =~ /MSWin32|cygwin|dos|os2/) {
        no strict qw(refs); ## no critic (TestingAndDebugging::ProhibitNoStrict)
        no warnings qw(redefine);

        # Replace readdir with utf8 aware version
        *{$target . '::readdir'} = \&_utf8_readdir;

        # Replace readdir with utf8 aware version
        *{$target . '::readlink'} = \&_utf8_readlink;

        # Replace glob with utf8 aware version
        *{$target . '::glob'} = \&_utf8_glob;

        # Set compiler hint to encode/decode in the redefined functions
        $^H{'utf8::all'} = 1;
    }

    # Make @ARGV utf-8 when called from the main package, unless perl was launched
    # with the -CA flag as this already has @ARGV decoded automatically.
    # -CA is active if the the fifth bit (32) of the ${^UNICODE} variable is set.
    # (see perlrun on the -C command switch for details about ${^UNICODE})
    if (!(${^UNICODE} & 32)) {
        state $have_encoded_argv = 0;
        if ($target eq 'main' && !$have_encoded_argv++) {
            $UTF8_CHECK |= Encode::LEAVE_SRC if $UTF8_CHECK; # Enforce LEAVE_SRC
            $_ = ($_ ? $_UTF8->decode($_, $UTF8_CHECK) : $_) for @ARGV;
        }
    }

    return;
}

sub unimport { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
    # Disable features/pragmas in calling package
    # Note: Does NOT undo the effect on @ARGV,
    #       nor on the STDIN, STDOUT, and STDERR file handles!
    #       These effects are always "global".

    my $target = caller;
    'utf8'->unimport::out_of($target);
    'open'->import::into($target, qw{IO :bytes});

    $^H{'utf8::all'} = 0; # Reset compiler hint

    return;
}

sub _utf8_readdir(*) { ## no critic (Subroutines::ProhibitSubroutinePrototypes)
    my $pre_handle = shift;
    my $hints = (caller 0)[10];
   my $handle = ref($pre_handle) ? $pre_handle : qualify_to_ref($pre_handle, caller);
    if (not $hints->{'utf8::all'}) {
        return CORE::readdir($handle);
    } else {
        $UTF8_CHECK |= Encode::LEAVE_SRC if $UTF8_CHECK; # Enforce LEAVE_SRC
        if (wantarray) {
            return map { $_ ? $_UTF8->decode($_, $UTF8_CHECK) : $_ } CORE::readdir($handle);
        } else {
            my $r = CORE::readdir($handle);
            return $r ? $_UTF8->decode($r, $UTF8_CHECK) : $r;
        }
    }
}

sub _utf8_readlink(_) { ## no critic (Subroutines::ProhibitSubroutinePrototypes)
    my $arg = shift;
    my $hints = (caller 0)[10];
    if (not $hints->{'utf8::all'}) {
        return CORE::readlink($arg);
    } else {
        $UTF8_CHECK |= Encode::LEAVE_SRC if $UTF8_CHECK; # Enforce LEAVE_SRC
        $arg = $arg ? $_UTF8->encode($arg, $UTF8_CHECK) : $arg;
        my $r = CORE::readlink($arg);
        return $r ? $_UTF8->decode($r, $UTF8_CHECK) : $r;
    }
}

sub _utf8_glob {
    my $arg = $_[0]; # Making this a lexical somehow is important!
    my $hints = (caller 0)[10];
    if (not $hints->{'utf8::all'}) {
        return CORE::glob($arg);
    } else {
        $UTF8_CHECK |= Encode::LEAVE_SRC if $UTF8_CHECK; # Enforce LEAVE_SRC
        $arg = $arg ? $_UTF8->encode($arg, $UTF8_CHECK) : $arg;
        if (wantarray) {
            return map { $_ ? $_UTF8->decode($_, $UTF8_CHECK) : $_ } CORE::glob($arg);
        } else {
            my $r = CORE::glob($arg);
            return $r ? $_UTF8->decode($r, $UTF8_CHECK) : $r;
        }
    }
}

#pod =head1 INTERACTION WITH AUTODIE
#pod
#pod If you use L, which is a great idea, you need to use at least
#pod version B<2.12>, released on L
#pod 2012|https://metacpan.org/source/PJF/autodie-2.12/Changes#L3>.
#pod Otherwise, autodie obliterates the IO layers set by the L
#pod pragma. See L
#pod #54777|https://rt.cpan.org/Ticket/Display.html?id=54777> and L
#pod #7|https://github.com/doherty/utf8-all/issues/7>.
#pod
#pod =cut

1;

__END__