File Coverage

blib/lib/Cwd/utf8.pm

Criterion	Covered	Total	%
statement	51	53	96.2
branch	16	22	72.7
condition			n/a
subroutine	11	11	100.0
pod			n/a
total	78	86	90.7

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

# ABSTRACT: Fully UTF-8 aware Cwd
our $VERSION = '0.011'; # VERSION

#pod =begin :prelude
#pod
#pod =for test_synopsis
#pod my $file;
#pod
#pod =end :prelude
#pod
#pod =head1 SYNOPSIS
#pod
#pod     # Using the utf-8 versions of cwd, getcwd, fastcwd, fastgetcwd
#pod     use Cwd::utf8;
#pod     my $dir = getcwd;
#pod
#pod     # Using the utf-8 versions of abs_path
#pod     use Cwd::utf8 qw(abs_path);
#pod     my $abs_path = abs_path($file);
#pod
#pod     # Exporting no functions
#pod     use Cwd::utf8 qw(:none); # NOT "use Cwd::utf8 qw();"!
#pod     my $real_path = Cwd::real_path($file);
#pod
#pod =head1 DESCRIPTION
#pod
#pod While the original L functions are capable of handling UTF-8
#pod quite well, they expects and return all data as bytes, not as
#pod characters.
#pod
#pod This module replaces all the L functions with fully UTF-8 aware
#pod versions, both expecting and returning characters.
#pod
#pod B Replacement of functions is not done on DOS, Windows, and OS/2
#pod as these systems do not have full UTF-8 file system support.
#pod
#pod =head2 Behaviour
#pod
#pod The module behaves as a pragma so you can use both C
#pod Cwd::utf8> and C to turn utf-8 support on
#pod or off.
#pod
#pod By default, cwd(), getcwd(), fastcwd(), and fastgetcwd() (and, on
#pod Win32, getdcwd()) are exported (as with the original L). If you
#pod want to prevent this, use C. (As all the
#pod magic happens in the module's import function, you can not simply use
#pod C)
#pod
#pod =head1 COMPATIBILITY
#pod
#pod The filesystems of Dos, Windows, and OS/2 do not (fully) support
#pod UTF-8. The L function will therefore not be replaced on these
#pod systems.
#pod
#pod =head1 SEE ALSO
#pod
#pod =for :list
#pod * L -- The original module
#pod * L -- Fully utf-8 aware versions of the L
#pod   functions.
#pod * L -- Turn on utf-8, all of it.
#pod   This was also the module I first added the utf-8 aware versions of
#pod   L and L to before moving them to their own package.
#pod
#pod =cut

use Cwd ();
use Encode ();

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

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

# Original package (i.e., the one for which this module is replacing the functions)
my $original_package = $current_package;
$original_package =~ s/::utf8$//;

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

#pod =attr $Cwd::utf8::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. 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 =cut

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 {
    # Target package (i.e., the one loading this module)
    my $target_package = caller;

    # If run on the dos/os2/windows platform, ignore overriding functions silently.
    # These platforms do not have (proper) utf-8 file system suppport...
    unless ($^O =~ /MSWin32|cygwin|dos|os2/) {
        no strict qw(refs); ## no critic (TestingAndDebugging::ProhibitNoStrict)
        no warnings qw(redefine);

        # Redefine each of the functions to their UTF-8 equivalent
        for my $f (@{$original_package . '::EXPORT'}, @{$original_package . '::EXPORT_OK'}) {
            # If we already have the _orig_function, we have redefined the function
            # in an earlier load of this module, so we need not do it again
            unless ($_orig_functions{$f}) {
                $_orig_functions{$f} = \&{$original_package . '::' . $f};
                *{$original_package . '::' . $f} = sub { return _utf8_cwd($f, @_); };
            }
        }
        $^H{$current_package} = 1; # Set compiler hint that we should use the utf-8 version
    }

    # Determine symbols to export
    shift; # First argument contains the package (that's us)
    @_ = (':DEFAULT') if !@_; # If nothing provided, use default
    @_ = map { $_ eq ':none' ? () : $_ } @_; # Replace :none tag with empty list

    # Use exporter to export
    require Exporter;
    Exporter::export_to_level($original_package, 1, $target_package, @_) if (@_);

    return;
}

sub unimport { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
    $^H{$current_package} = 0; # Set compiler hint that we should not use the utf-8 version
    return;
}

sub _utf8_cwd {
    my $func = shift;

    my $hints = (caller 1)[10]; # Use caller level 1 because of the added anonymous sub around call
    if (! $hints->{$current_package}) {
        # Use original function if we're not using Cwd::utf8 in calling package
        return $_orig_functions{$func}->(@_);
    } else {
        $UTF8_CHECK |= Encode::LEAVE_SRC if $UTF8_CHECK; # Enforce LEAVE_SRC
        my @args = map { $_ ? $_UTF8->encode($_, $UTF8_CHECK) : $_ } @_;
        if (wantarray) {
            return map { $_ ? $_UTF8->decode($_, $UTF8_CHECK) : $_ } $_orig_functions{$func}->(@args);
        } else {
            my $r = $_orig_functions{$func}->(@args);
            return $r ? $_UTF8->decode($r, $UTF8_CHECK) : $r;
        }
    }
}

1;

__END__