root/lang/perl/Path-Class-URI/trunk/lib/Path/Class/Unicode.pm @ 25675

Revision 25675, 3.7 kB (checked in by mattn, 5 years ago)

override next()

Line 
1package Path::Class::Unicode;
2
3use strict;
4use 5.008_001;
5our $VERSION = '0.01';
6
7use Exporter::Lite;
8our @EXPORT = qw( ufile udir ufile_from_uri udir_from_uri );
9
10use Encode ();
11use Path::Class;
12use URI::file;
13use Scalar::Util qw(blessed);
14
15sub ufile {
16    __PACKAGE__->new(file(@_));
17}
18
19sub udir {
20    __PACKAGE__->new(dir(@_));
21}
22
23sub ufile_from_uri {
24    my $uri = shift;
25    if ($^O eq "MSWin32") {
26        $uri =~ s!^file:///!file://!g; # remove leading slash for absolute
27        $uri = URI->new($uri) unless blessed $uri;
28        ufile(Encode::decode_utf8($uri->file('win32')));
29    } else {
30        $uri = URI->new($uri) unless blessed $uri;
31        ufile(Encode::decode_utf8($uri->file('unix')));
32    }
33}
34
35sub udir_from_uri {
36    my $uri = shift;
37    if ($^O eq "MSWin32") {
38        $uri =~ s!^file:///!file://!g; # remove leading slash for absolute
39        $uri = URI->new($uri) unless blessed $uri;
40        udir(Encode::decode_utf8($uri->file('win32')));
41    } else {
42        $uri = URI->new($uri) unless blessed $uri;
43        udir(Encode::decode_utf8($uri->file('unix')));
44    }
45}
46
47sub new {
48    my($class, $path) = @_;
49    bless { path => $path }, $class;
50}
51
52sub uri {
53    my $self = shift;
54    my $path = Encode::encode_utf8($self->{path}->stringify);
55    if ($^O eq "MSWin32") {
56        $path =~ tr!\\!/!; # can't use backslash as separator
57        $path = "/$path" if $self->is_absolute; # make "file:///x:/foo/bar/"
58    }
59    if ($self->is_absolute) {
60        return URI->new("file://$path");
61    } else {
62        return URI->new("file:$path");
63    }
64}
65
66our $encoding;
67
68sub stringify {
69    my $self = shift;
70
71    unless ($encoding) {
72        $encoding = 'utf-8';
73        if ($^O eq 'MSWin32') {
74            eval {
75                require Win32::API;
76                Win32::API->Import('kernel32', 'UINT GetACP()');
77                $encoding = 'cp'.GetACP();
78            };
79        }
80    }
81
82    Encode::encode($encoding, $self->{path}->stringify);
83}
84
85sub open {
86    my $self = shift;
87    my $class = $self->is_dir ? "IO::Dir" : "IO::File";
88    $class->new($self->stringify, @_);
89}
90
91sub next {
92    my $self = shift;
93    $self->{path}->{dh} = $self->open unless $self->{path}->{dh};
94    my $file = $self->{path}->next;
95    $file = Encode::encode($encoding, $file) if $file;
96    $file;
97}
98
99use overload (
100    q[""] => 'stringify',
101    fallback => 1,
102);
103
104our $AUTOLOAD;
105sub AUTOLOAD {
106    my $self = shift;
107    (my $method = $AUTOLOAD) =~ s/.*:://;
108    $self->{path}->$method(@_);
109}
110
111sub DESTROY { }
112
1131;
114__END__
115
116=encoding utf-8
117
118=for stopwords TODO UTF-8 filenames cp932 mattn
119
120=head1 NAME
121
122Path::Class::Unicode - Maps Unicode filenames to local encoding and code pages
123
124=head1 SYNOPSIS
125
126  use Path::Class::Unicode;
127
128  # Use ufile() to create Unicode objects
129  my $fn   = "\x{55ed}.txt";
130  my $file = ufile("path", $fn);
131
132  my $fh = $file->open;
133
134  my $fn   = "\x{55ed}.txt";
135  my $file = ufile("/path", $fn);
136  my $uri  = $file->uri;  # file:///path/%E5%97%AD.txt (always utf-8)
137
138  my $fh   = ufile_from_uri($uri)->open;
139
140=head1 DESCRIPTION
141
142Path::Class::Unicode is a Path::Class extension to handle Unicode
143file names by mapping them to local encodings when stringified. It maps
144to UTF-8 for all UNIX systems including Mac OS X and uses Windows code
145page (like cp932 for Japanese) in Win32 systems.
146
147It's very useful if you store file paths using URI representation like
148L<file://> and uses URI escaped UTF-8 characters for non-ASCII
149characters. See L<Path::Class::URI> for details.
150
151=head1 TODO
152
153It would be nice if we could proxy filehandles using Win32API::File.
154
155=head1 AUTHOR
156
157Tatsuhiko Miyagawa E<lt>miyagawa@cpan.orgE<gt>
158
159mattn
160
161=head1 LICENSE
162
163This library is free software; you can redistribute it and/or modify
164it under the same terms as Perl itself.
165
166=head1 SEE ALSO
167
168=cut
Note: See TracBrowser for help on using the browser.