File Coverage

blib/lib/Path/Class/Unicode.pm
Criterion Covered Total %
statement 51 81 62.9
branch 8 26 30.7
condition 0 6 0.0
subroutine 17 25 68.0
pod 0 13 0.0
total 76 151 50.3


line stmt bran cond sub pod time code
1             package Path::Class::Unicode;
2              
3 1     1   80161 use strict;
  1         1  
  1         31  
4 1     1   20 use 5.008_001;
  1         3  
  1         67  
5             our $VERSION = '0.07';
6              
7 1     1   484 use Exporter::Lite;
  1         635  
  1         6  
8             our @EXPORT = qw( ufile udir ufile_from_uri udir_from_uri );
9              
10 1     1   584 use Encode ();
  1         7592  
  1         33  
11 1     1   9 use Path::Class;
  1         2  
  1         58  
12 1     1   420 use URI::file;
  1         8042  
  1         32  
13 1     1   7 use Scalar::Util qw(blessed);
  1         1  
  1         721  
14              
15             sub ufile {
16 6     6 0 12847 __PACKAGE__->new(file(@_));
17             }
18              
19             sub udir {
20 0     0 0 0 __PACKAGE__->new(dir(@_));
21             }
22              
23             sub Path::Class::File::ufile {
24 2     2 0 303 my $file = shift;
25 2         6 ufile(_decode_filename($file), @_);
26             }
27              
28             sub Path::Class::Dir::udir {
29 0     0 0 0 my $dir = shift;
30 0         0 udir(_decode_filename($dir), @_);
31             }
32              
33             sub ufile_from_uri {
34 2     2 0 158 my $uri = shift;
35 2 50       20 $uri = URI->new($uri) unless blessed $uri;
36 2 50       10 if ($^O eq "MSWin32") {
37 0         0 ufile(Encode::decode_utf8($uri->file('win32')));
38             } else {
39 2         10 ufile(Encode::decode_utf8($uri->file('unix')));
40             }
41             }
42              
43             sub udir_from_uri {
44 0     0 0 0 my $uri = shift;
45 0 0       0 $uri = URI->new($uri) unless blessed $uri;
46 0 0       0 if ($^O eq "MSWin32") {
47 0         0 udir(Encode::decode_utf8($uri->file('win32')));
48             } else {
49 0         0 udir(Encode::decode_utf8($uri->file('unix')));
50             }
51             }
52              
53             sub new {
54 6     6 0 657 my($class, $path) = @_;
55 6         32 bless { path => $path }, $class;
56             }
57              
58             sub uri {
59 4     4 0 1739 my $self = shift;
60 4         58 my $path = Encode::encode_utf8($self->{path}->stringify);
61 4 50       180 $path =~ tr!\\!/! if $^O eq "MSWin32";
62 4 100       22 if ($self->is_absolute) {
63 2         81 return URI->new("file://$path");
64             } else {
65 2         111 return URI->new("file:$path");
66             }
67             }
68              
69             our $encoding;
70              
71             sub init_encoding {
72 24 100   24 0 51 unless ($encoding) {
73 1         2 $encoding = 'utf-8';
74 1 50       4 if ($^O eq 'MSWin32') {
75 0         0 eval {
76 0         0 require Win32::API;
77 0         0 Win32::API->Import('kernel32', 'UINT GetACP()');
78 0         0 $encoding = 'cp'.GetACP();
79             };
80             }
81             }
82             }
83              
84             sub stringify {
85 22     22 0 10829 my $self = shift;
86 22         30 init_encoding();
87 22         57 Encode::encode($encoding, $self->{path}->stringify);
88             }
89              
90             sub _decode_filename {
91 2     2   4 init_encoding();
92 2         2 my $filename = shift;
93 2         7 Encode::decode($encoding, "$filename");
94             }
95              
96             sub open {
97 0     0 0 0 my $self = shift;
98 0 0       0 my $class = $self->is_dir ? "IO::Dir" : "IO::File";
99 0         0 $class->new($self->stringify, @_);
100             }
101              
102             sub next {
103 0     0 0 0 my $self = shift;
104 0 0       0 $self->{path}->{dh} = $self->open unless $self->{path}->{dh};
105 0     0   0 local *IO::Dir::read = sub { Encode::decode $encoding, readdir shift };
  0         0  
106 0         0 ufile($self->{path}->next);
107             }
108              
109             sub children {
110 0     0 0 0 my ($self, %opts) = @_;
111            
112 0 0       0 $self->{path}->{dh} = $self->open unless $self->{path}->{dh};
113            
114 0         0 my @out;
115 0         0 while (my $entry = $self->{path}->{dh}->read) {
116             # XXX What's the right cross-platform way to do this?
117 0 0 0     0 next if (!$opts{all} && ($entry eq '.' || $entry eq '..'));
      0        
118 0         0 push @out, $self->file($entry);
119 0 0       0 $out[-1] = $self->subdir($entry) if -d $out[-1];
120             }
121 0         0 return @out;
122             }
123              
124             use overload (
125 1         11 q[""] => 'stringify',
126             fallback => 1,
127 1     1   5 );
  1         5  
128              
129             our $AUTOLOAD;
130             sub AUTOLOAD {
131 4     4   5 my $self = shift;
132 4         28 (my $method = $AUTOLOAD) =~ s/.*:://;
133 4         22 $self->{path}->$method(@_);
134             }
135              
136 0     0     sub DESTROY { }
137              
138             1;
139             __END__