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


line stmt bran cond sub pod time code
1             package Cwd::utf8;
2 3     3   77168 use strict;
  3         9  
  3         80  
3 3     3   18 use warnings;
  3         7  
  3         73  
4 3     3   57 use 5.010; # state
  3         10  
5              
6             # ABSTRACT: Fully UTF-8 aware Cwd
7             our $VERSION = '0.010'; # VERSION
8              
9             #pod =begin :prelude
10             #pod
11             #pod =for test_synopsis
12             #pod my $file;
13             #pod
14             #pod =end :prelude
15             #pod
16             #pod =head1 SYNOPSIS
17             #pod
18             #pod # Using the utf-8 versions of cwd, getcwd, fastcwd, fastgetcwd
19             #pod use Cwd::utf8;
20             #pod my $dir = getcwd;
21             #pod
22             #pod # Using the utf-8 versions of abs_path
23             #pod use Cwd::utf8 qw(abs_path);
24             #pod my $abs_path = abs_path($file);
25             #pod
26             #pod # Exporting no functions
27             #pod use Cwd::utf8 qw(:none); # NOT "use Cwd::utf8 qw();"!
28             #pod my $real_path = Cwd::real_path($file);
29             #pod
30             #pod =head1 DESCRIPTION
31             #pod
32             #pod While the original L functions are capable of handling UTF-8
33             #pod quite well, they expects and return all data as bytes, not as
34             #pod characters.
35             #pod
36             #pod This module replaces all the L functions with fully UTF-8 aware
37             #pod versions, both expecting and returning characters.
38             #pod
39             #pod B Replacement of functions is not done on DOS, Windows, and OS/2
40             #pod as these systems do not have full UTF-8 file system support.
41             #pod
42             #pod =head2 Behaviour
43             #pod
44             #pod The module behaves as a pragma so you can use both C
45             #pod Cwd::utf8> and C to turn utf-8 support on
46             #pod or off.
47             #pod
48             #pod By default, cwd(), getcwd(), fastcwd(), and fastgetcwd() (and, on
49             #pod Win32, getdcwd()) are exported (as with the original L). If you
50             #pod want to prevent this, use C. (As all the
51             #pod magic happens in the module's import function, you can not simply use
52             #pod C)
53             #pod
54             #pod =head1 COMPATIBILITY
55             #pod
56             #pod The filesystems of Dos, Windows, and OS/2 do not (fully) support
57             #pod UTF-8. The L function will therefore not be replaced on these
58             #pod systems.
59             #pod
60             #pod =head1 SEE ALSO
61             #pod
62             #pod =for :list
63             #pod * L -- The original module
64             #pod * L -- Fully utf-8 aware versions of the L
65             #pod functions.
66             #pod * L -- Turn on utf-8, all of it.
67             #pod This was also the module I first added the utf-8 aware versions of
68             #pod L and L to before moving them to their own package.
69             #pod
70             #pod =cut
71              
72 3     3   17 use Cwd ();
  3         11  
  3         41  
73 3     3   415 use Encode ();
  3         7551  
  3         495  
74              
75             # Holds the pointers to the original version of redefined functions
76             state %_orig_functions;
77              
78             # Current (i.e., this) package
79             my $current_package = __PACKAGE__;
80              
81             # Original package (i.e., the one for which this module is replacing the functions)
82             my $original_package = $current_package;
83             $original_package =~ s/::utf8$//;
84              
85             require Carp;
86             $Carp::Internal{$current_package}++; # To get warnings reported at correct caller level
87              
88             #pod =attr $Cwd::utf8::UTF8_CHECK
89             #pod
90             #pod By default C marks decoding errors as fatal (default value
91             #pod for this setting is C). If you want, you can change this by
92             #pod setting C. The value C reports
93             #pod the encoding errors as warnings, and C will completely
94             #pod ignore them. Please see L for details. Note: C is
95             #pod I enforced.
96             #pod
97             #pod =cut
98              
99             our $UTF8_CHECK = Encode::FB_CROAK | Encode::LEAVE_SRC; # Die on encoding errors
100              
101             # UTF-8 Encoding object
102             my $_UTF8 = Encode::find_encoding('UTF-8');
103              
104             sub import {
105             # Target package (i.e., the one loading this module)
106 8     8   1053 my $target_package = caller;
107              
108             # If run on the dos/os2/windows platform, ignore overriding functions silently.
109             # These platforms do not have (proper) utf-8 file system suppport...
110 8 50       155 unless ($^O =~ /MSWin32|cygwin|dos|os2/) {
111 3     3   20 no strict qw(refs); ## no critic (TestingAndDebugging::ProhibitNoStrict)
  3         7  
  3         827  
112 3     3   19 no warnings qw(redefine);
  3         7  
  3         1154  
113              
114             # Redefine each of the functions to their UTF-8 equivalent
115 8         16 for my $f (@{$original_package . '::EXPORT'}, @{$original_package . '::EXPORT_OK'}) {
  8         27  
  8         30  
116             # If we already have the _orig_function, we have redefined the function
117             # in an earlier load of this module, so we need not do it again
118 72 100       178 unless ($_orig_functions{$f}) {
119 27         41 $_orig_functions{$f} = \&{$original_package . '::' . $f};
  27         100  
120 27     39   83 *{$original_package . '::' . $f} = sub { return _utf8_cwd($f, @_); };
  27         96  
  39         105292  
121             }
122             }
123 8         39 $^H{$current_package} = 1; # Set compiler hint that we should use the utf-8 version
124             }
125              
126             # Determine symbols to export
127 8         15 shift; # First argument contains the package (that's us)
128 8 100       659 @_ = (':DEFAULT') if !@_; # If nothing provided, use default
129 8 100       17 @_ = map { $_ eq ':none' ? () : $_ } @_; # Replace :none tag with empty list
  11         42  
130              
131             # Use exporter to export
132 8         41 require Exporter;
133 8 100       643 Exporter::export_to_level($original_package, 1, $target_package, @_) if (@_);
134              
135 7         2478 return;
136             }
137              
138             sub unimport { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
139 1     1   7 $^H{$current_package} = 0; # Set compiler hint that we should not use the utf-8 version
140 1         89 return;
141             }
142              
143             sub _utf8_cwd {
144 39     39   103 my $func = shift;
145              
146 39         280 my $hints = (caller 1)[10]; # Use caller level 1 because of the added anonymous sub around call
147 39 100       587 if (! $hints->{$current_package}) {
148             # Use original function if we're not using Cwd::utf8 in calling package
149 22         8089 return $_orig_functions{$func}->(@_);
150             } else {
151 17 100       101 $UTF8_CHECK |= Encode::LEAVE_SRC if $UTF8_CHECK; # Enforce LEAVE_SRC
152 17 50       50 my @args = map { $_ ? $_UTF8->encode($_, $UTF8_CHECK) : $_ } @_;
  11         125  
153 16 50       126 if (wantarray) {
154 0 0       0 return map { $_ ? $_UTF8->decode($_, $UTF8_CHECK) : $_ } $_orig_functions{$func}->(@args);
  0         0  
155             } else {
156 16         10200 my $r = $_orig_functions{$func}->(@args);
157 16 50       196 return $r ? $_UTF8->decode($r, $UTF8_CHECK) : $r;
158             }
159             }
160             }
161              
162             1;
163              
164             __END__