diff options
Diffstat (limited to 'lib/File')
| -rw-r--r-- | lib/File/HomeDir.pm | 720 | ||||
| -rw-r--r-- | lib/File/HomeDir/Darwin.pm | 152 | ||||
| -rw-r--r-- | lib/File/HomeDir/Darwin/Carbon.pm | 210 | ||||
| -rw-r--r-- | lib/File/HomeDir/Darwin/Cocoa.pm | 165 | ||||
| -rw-r--r-- | lib/File/HomeDir/Driver.pm | 54 | ||||
| -rw-r--r-- | lib/File/HomeDir/FreeDesktop.pm | 136 | ||||
| -rw-r--r-- | lib/File/HomeDir/MacOS9.pm | 150 | ||||
| -rw-r--r-- | lib/File/HomeDir/Test.pm | 137 | ||||
| -rw-r--r-- | lib/File/HomeDir/Unix.pm | 186 | ||||
| -rw-r--r-- | lib/File/HomeDir/Windows.pm | 241 |
10 files changed, 2151 insertions, 0 deletions
diff --git a/lib/File/HomeDir.pm b/lib/File/HomeDir.pm new file mode 100644 index 0000000..624e9f2 --- /dev/null +++ b/lib/File/HomeDir.pm @@ -0,0 +1,720 @@ +package File::HomeDir; + +# See POD at end for documentation + +use 5.00503; +use strict; +use Carp (); +use Config (); +use File::Spec (); +use File::Which (); + +# Globals +use vars qw{$VERSION @ISA @EXPORT @EXPORT_OK $IMPLEMENTED_BY}; +BEGIN { + $VERSION = '1.00'; + + # Inherit manually + require Exporter; + @ISA = qw{ Exporter }; + @EXPORT = qw{ home }; + @EXPORT_OK = qw{ + home + my_home + my_desktop + my_documents + my_music + my_pictures + my_videos + my_data + my_dist_config + my_dist_data + users_home + users_desktop + users_documents + users_music + users_pictures + users_videos + users_data + }; + + # %~ doesn't need (and won't take) exporting, as it's a magic + # symbol name that's always looked for in package 'main'. +} + +# Inlined Params::Util functions +sub _CLASS ($) { + (defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s) ? $_[0] : undef; +} +sub _DRIVER ($$) { + (defined _CLASS($_[0]) and eval "require $_[0];" and ! $@ and $_[0]->isa($_[1]) and $_[0] ne $_[1]) ? $_[0] : undef; +} + +# Platform detection +if ( $IMPLEMENTED_BY ) { + # Allow for custom HomeDir classes + # Leave it as the existing value +} elsif ( $^O eq 'MSWin32' ) { + # All versions of Windows + $IMPLEMENTED_BY = 'File::HomeDir::Windows'; +} elsif ( $^O eq 'darwin') { + # 1st: try Mac::SystemDirectory by chansen + if ( eval { require Mac::SystemDirectory; 1 } ) { + $IMPLEMENTED_BY = 'File::HomeDir::Darwin::Cocoa'; + } elsif ( eval { require Mac::Files; 1 } ) { + # 2nd try Mac::Files: Carbon - unmaintained since 2006 except some 64bit fixes + $IMPLEMENTED_BY = 'File::HomeDir::Darwin::Carbon'; + } else { + # 3rd: fallback: pure perl + $IMPLEMENTED_BY = 'File::HomeDir::Darwin'; + } +} elsif ( $^O eq 'MacOS' ) { + # Legacy Mac OS + $IMPLEMENTED_BY = 'File::HomeDir::MacOS9'; +} elsif ( File::Which::which('xdg-user-dir') ) { + # freedesktop unixes + $IMPLEMENTED_BY = 'File::HomeDir::FreeDesktop'; +} else { + # Default to Unix semantics + $IMPLEMENTED_BY = 'File::HomeDir::Unix'; +} +unless ( _DRIVER($IMPLEMENTED_BY, 'File::HomeDir::Driver') ) { + Carp::croak("Missing or invalid File::HomeDir driver $IMPLEMENTED_BY"); +} + + + + + +##################################################################### +# Current User Methods + +sub my_home { + $IMPLEMENTED_BY->my_home; +} + +sub my_desktop { + $IMPLEMENTED_BY->can('my_desktop') + ? $IMPLEMENTED_BY->my_desktop + : Carp::croak("The my_desktop method is not implemented on this platform"); +} + +sub my_documents { + $IMPLEMENTED_BY->can('my_documents') + ? $IMPLEMENTED_BY->my_documents + : Carp::croak("The my_documents method is not implemented on this platform"); +} + +sub my_music { + $IMPLEMENTED_BY->can('my_music') + ? $IMPLEMENTED_BY->my_music + : Carp::croak("The my_music method is not implemented on this platform"); +} + +sub my_pictures { + $IMPLEMENTED_BY->can('my_pictures') + ? $IMPLEMENTED_BY->my_pictures + : Carp::croak("The my_pictures method is not implemented on this platform"); +} + +sub my_videos { + $IMPLEMENTED_BY->can('my_videos') + ? $IMPLEMENTED_BY->my_videos + : Carp::croak("The my_videos method is not implemented on this platform"); +} + +sub my_data { + $IMPLEMENTED_BY->can('my_data') + ? $IMPLEMENTED_BY->my_data + : Carp::croak("The my_data method is not implemented on this platform"); +} + + +sub my_dist_data { + my $params = ref $_[-1] eq 'HASH' ? pop : {}; + my $dist = pop or Carp::croak("The my_dist_data method requires an argument"); + my $data = my_data(); + + # If datadir is not defined, there's nothing we can do: bail out + # and return nothing... + return undef unless defined $data; + + # On traditional unixes, hide the top-level directory + my $var = $data eq home() + ? File::Spec->catdir( $data, '.perl', 'dist', $dist ) + : File::Spec->catdir( $data, 'Perl', 'dist', $dist ); + + # directory exists: return it + return $var if -d $var; + + # directory doesn't exist: check if we need to create it... + return undef unless $params->{create}; + + # user requested directory creation + require File::Path; + File::Path::mkpath( $var ); + return $var; +} + +sub my_dist_config { + my $params = ref $_[-1] eq 'HASH' ? pop : {}; + my $dist = pop or Carp::croak("The my_dist_config method requires an argument"); + + # not all platforms support a specific my_config() method + my $config = $IMPLEMENTED_BY->can('my_config') + ? $IMPLEMENTED_BY->my_config + : $IMPLEMENTED_BY->my_documents; + + # If neither configdir nor my_documents is defined, there's + # nothing we can do: bail out and return nothing... + return undef unless defined $config; + + # On traditional unixes, hide the top-level dir + my $etc = $config eq home() + ? File::Spec->catdir( $config, '.perl', $dist ) + : File::Spec->catdir( $config, 'Perl', $dist ); + + # directory exists: return it + return $etc if -d $etc; + + # directory doesn't exist: check if we need to create it... + return undef unless $params->{create}; + + # user requested directory creation + require File::Path; + File::Path::mkpath( $etc ); + return $etc; +} + + + + +##################################################################### +# General User Methods + +sub users_home { + $IMPLEMENTED_BY->can('users_home') + ? $IMPLEMENTED_BY->users_home( $_[-1] ) + : Carp::croak("The users_home method is not implemented on this platform"); +} + +sub users_desktop { + $IMPLEMENTED_BY->can('users_desktop') + ? $IMPLEMENTED_BY->users_desktop( $_[-1] ) + : Carp::croak("The users_desktop method is not implemented on this platform"); +} + +sub users_documents { + $IMPLEMENTED_BY->can('users_documents') + ? $IMPLEMENTED_BY->users_documents( $_[-1] ) + : Carp::croak("The users_documents method is not implemented on this platform"); +} + +sub users_music { + $IMPLEMENTED_BY->can('users_music') + ? $IMPLEMENTED_BY->users_music( $_[-1] ) + : Carp::croak("The users_music method is not implemented on this platform"); +} + +sub users_pictures { + $IMPLEMENTED_BY->can('users_pictures') + ? $IMPLEMENTED_BY->users_pictures( $_[-1] ) + : Carp::croak("The users_pictures method is not implemented on this platform"); +} + +sub users_videos { + $IMPLEMENTED_BY->can('users_videos') + ? $IMPLEMENTED_BY->users_videos( $_[-1] ) + : Carp::croak("The users_videos method is not implemented on this platform"); +} + +sub users_data { + $IMPLEMENTED_BY->can('users_data') + ? $IMPLEMENTED_BY->users_data( $_[-1] ) + : Carp::croak("The users_data method is not implemented on this platform"); +} + + + + + +##################################################################### +# Legacy Methods + +# Find the home directory of an arbitrary user +sub home (;$) { + # Allow to be called as a method + if ( $_[0] and $_[0] eq 'File::HomeDir' ) { + shift(); + } + + # No params means my home + return my_home() unless @_; + + # Check the param + my $name = shift; + if ( ! defined $name ) { + Carp::croak("Can't use undef as a username"); + } + if ( ! length $name ) { + Carp::croak("Can't use empty-string (\"\") as a username"); + } + + # A dot also means my home + ### Is this meant to mean File::Spec->curdir? + if ( $name eq '.' ) { + return my_home(); + } + + # Now hand off to the implementor + $IMPLEMENTED_BY->users_home($name); +} + + + + + +##################################################################### +# Tie-Based Interface + +# Okay, things below this point get scary + +CLASS: { + # Make the class for the %~ tied hash: + package File::HomeDir::TIE; + + # Make the singleton object. + # (We don't use the hash for anything, though) + ### THEN WHY MAKE IT??? + my $SINGLETON = bless {}; + + sub TIEHASH { $SINGLETON } + + sub FETCH { + # Catch a bad username + unless ( defined $_[1] ) { + Carp::croak("Can't use undef as a username"); + } + + # Get our homedir + unless ( length $_[1] ) { + return File::HomeDir::my_home(); + } + + # Get a named user's homedir + Carp::carp("The tied %~ hash has been deprecated"); + return File::HomeDir::home($_[1]); + } + + sub STORE { _bad('STORE') } + sub EXISTS { _bad('EXISTS') } + sub DELETE { _bad('DELETE') } + sub CLEAR { _bad('CLEAR') } + sub FIRSTKEY { _bad('FIRSTKEY') } + sub NEXTKEY { _bad('NEXTKEY') } + + sub _bad ($) { + Carp::croak("You can't $_[0] with the %~ hash") + } +} + +# Do the actual tie of the global %~ variable +tie %~, 'File::HomeDir::TIE'; + +1; + +__END__ + +=pod + +=head1 NAME + +File::HomeDir - Find your home and other directories on any platform + +=head1 SYNOPSIS + + use File::HomeDir; + + # Modern Interface (Current User) + $home = File::HomeDir->my_home; + $desktop = File::HomeDir->my_desktop; + $docs = File::HomeDir->my_documents; + $music = File::HomeDir->my_music; + $pics = File::HomeDir->my_pictures; + $videos = File::HomeDir->my_videos; + $data = File::HomeDir->my_data; + $dist = File::HomeDir->my_dist_data('File-HomeDir'); + $dist = File::HomeDir->my_dist_config('File-HomeDir'); + + # Modern Interface (Other Users) + $home = File::HomeDir->users_home('foo'); + $desktop = File::HomeDir->users_desktop('foo'); + $docs = File::HomeDir->users_documents('foo'); + $music = File::HomeDir->users_music('foo'); + $pics = File::HomeDir->users_pictures('foo'); + $video = File::HomeDir->users_videos('foo'); + $data = File::HomeDir->users_data('foo'); + +=head1 DESCRIPTION + +B<File::HomeDir> is a module for locating the directories that are "owned" +by a user (typicaly your user) and to solve the various issues that arise +trying to find them consistently across a wide variety of platforms. + +The end result is a single API that can find your resources on any platform, +making it relatively trivial to create Perl software that works elegantly +and correctly no matter where you run it. + +This module provides two main interfaces. + +The first is a modern L<File::Spec>-style interface with a consistent +OO API and different implementation modules to support various +platforms. You are B<strongly> recommended to use this interface. + +The second interface is for legacy support of the original 0.07 interface +that exported a C<home()> function by default and tied the C<%~> variable. + +It is generally not recommended that you use this interface, but due to +back-compatibility reasons they will remain supported until at least 2010. + +The C<%~> interface has been deprecated. Documentation was removed in 2009, +Unit test were removed in 2011, usage will issue warnings from 2012, and the +interface will be removed entirely in 2015 (in line with the general Perl +toolchain convention of a 10 year support period for legacy APIs that +are potentially or actually in common use). + +=head2 Platform Neutrality + +In the Unix world, many different types of data can be mixed together +in your home directory (although on some Unix platforms this is no longer +the case, particularly for "desktop"-oriented platforms). + +On some non-Unix platforms, separate directories are allocated for +different types of data and have been for a long time. + +When writing applications on top of B<File::HomeDir>, you should thus +always try to use the most specific method you can. User documents should +be saved in C<my_documents>, data that supports an application but isn't +normally editing by the user directory should go into C<my_data>. + +On platforms that do not make any distinction, all these different +methods will harmlessly degrade to the main home directory, but on +platforms that care B<File::HomeDir> will always try to Do The Right +Thing(tm). + +=head1 METHODS + +Two types of methods are provided. The C<my_method> series of methods for +finding resources for the current user, and the C<users_method> (read as +"user's method") series for finding resources for arbitrary users. + +This split is necessary, as on most platforms it is B<much> easier to find +information about the current user compared to other users, and indeed +on a number you cannot find out information such as C<users_desktop> at +all, due to security restrictions. + +All methods will double check (using a C<-d> test) that a directory +actually exists before returning it, so you may trust in the values +that are returned (subject to the usual caveats of race conditions of +directories being deleted at the moment between a directory being returned +and you using it). + +However, because in some cases platforms may not support the concept of home +directories at all, any method may return C<undef> (both in scalar and list +context) to indicate that there is no matching directory on the system. + +For example, most untrusted 'nobody'-type users do not have a home +directory. So any modules that are used in a CGI application that +at some level of recursion use your code, will result in calls to +File::HomeDir returning undef, even for a basic home() call. + +=head2 my_home + +The C<my_home> method takes no arguments and returns the main home/profile +directory for the current user. + +If the distinction is important to you, the term "current" refers to the +real user, and not the effective user. + +This is also the case for all of the other "my" methods. + +Returns the directory path as a string, C<undef> if the current user +does not have a home directory, or dies on error. + +=head2 my_desktop + +The C<my_desktop> method takes no arguments and returns the "desktop" +directory for the current user. + +Due to the diversity and complexity of implementions required to deal with +implementing the required functionality fully and completely, the +C<my_desktop> method may or may not be implemented on each platform. + +That said, I am extremely interested in code to implement C<my_desktop> on +Unix, as long as it is capable of dealing (as the Windows implementation +does) with internationalisation. It should also avoid false positive +results by making sure it only returns the appropriate directories for the +appropriate platforms. + +Returns the directory path as a string, C<undef> if the current user +does not have a desktop directory, or dies on error. + +=head2 my_documents + +The C<my_documents> method takes no arguments and returns the directory (for +the current user) where the user's documents are stored. + +Returns the directory path as a string, C<undef> if the current user +does not have a documents directory, or dies on error. + +=head2 my_music + +The C<my_music> method takes no arguments and returns the directory +where the current user's music is stored. + +No bias is made to any particular music type or music program, rather the +concept of a directory to hold the user's music is made at the level of the +underlying operating system or (at least) desktop environment. + +Returns the directory path as a string, C<undef> if the current user +does not have a suitable directory, or dies on error. + +=head2 my_pictures + +The C<my_pictures> method takes no arguments and returns the directory +where the current user's pictures are stored. + +No bias is made to any particular picture type or picture program, rather the +concept of a directory to hold the user's pictures is made at the level of the +underlying operating system or (at least) desktop environment. + +Returns the directory path as a string, C<undef> if the current user +does not have a suitable directory, or dies on error. + +=head2 my_videos + +The C<my_videos> method takes no arguments and returns the directory +where the current user's videos are stored. + +No bias is made to any particular video type or video program, rather the +concept of a directory to hold the user's videos is made at the level of the +underlying operating system or (at least) desktop environment. + +Returns the directory path as a string, C<undef> if the current user +does not have a suitable directory, or dies on error. + +=head2 my_data + +The C<my_data> method takes no arguments and returns the directory where +local applications should stored their internal data for the current +user. + +Generally an application would create a subdirectory such as C<.foo>, +beneath this directory, and store its data there. By creating your +directory this way, you get an accurate result on the maximum number of +platforms. But see the documentation about C<my_dist_config()> or +C<my_dist_data()> below. + +For example, on Unix you get C<~/.foo> and on Win32 you get +C<~/Local Settings/Application Data/.foo> + +Returns the directory path as a string, C<undef> if the current user +does not have a data directory, or dies on error. + + +=head2 my_dist_config + + File::HomeDir->my_dist_config( $dist [, \%params] ); + + # For example... + + File::HomeDir->my_dist_config( 'File-HomeDir' ); + File::HomeDir->my_dist_config( 'File-HomeDir', { create => 1 } ); + +The C<my_dist_config> method takes a distribution name as argument and +returns an application-specific directory where they should store their +internal configuration. + +The base directory will be either C<my_config> if the platform supports +it, or C<my_documents> otherwise. The subdirectory itself will be +C<BASE/Perl/Dist-Name>. If the base directory is the user's homedir, +C<my_dist_config> will be in C<~/.perl/Dist-Name> (and thus be hidden on +all Unixes). + +The optional last argument is a hash reference to tweak the method +behaviour. The following hash keys are recognized: + +=over 4 + +=item * create + +Passing a true value to this key will force the creation of the +directory if it doesn't exist (remember that C<File::HomeDir>'s policy +is to return C<undef> if the directory doesn't exist). + +Defaults to false, meaning no automatic creation of directory. + +=back + + +=head2 my_dist_data + + File::HomeDir->my_dist_data( $dist [, \%params] ); + + # For example... + + File::HomeDir->my_dist_data( 'File-HomeDir' ); + File::HomeDir->my_dist_data( 'File-HomeDir', { create => 1 } ); + +The C<my_dist_data> method takes a distribution name as argument and +returns an application-specific directory where they should store their +internal data. + +This directory will be of course a subdirectory of C<my_data>. Platforms +supporting data-specific directories will use +C<DATA_DIR/perl/dist/Dist-Name> following the common +"DATA/vendor/application" pattern. If the C<my_data> directory is the +user's homedir, C<my_dist_data> will be in C<~/.perl/dist/Dist-Name> +(and thus be hidden on all Unixes). + +The optional last argument is a hash reference to tweak the method +behaviour. The following hash keys are recognized: + +=over 4 + +=item * create + +Passing a true value to this key will force the creation of the +directory if it doesn't exist (remember that C<File::HomeDir>'s policy +is to return C<undef> if the directory doesn't exist). + +Defaults to false, meaning no automatic creation of directory. + +=back + +=head2 users_home + + $home = File::HomeDir->users_home('foo'); + +The C<users_home> method takes a single param and is used to locate the +parent home/profile directory for an identified user on the system. + +While most of the time this identifier would be some form of user name, +it is permitted to vary per-platform to support user ids or UUIDs as +applicable for that platform. + +Returns the directory path as a string, C<undef> if that user +does not have a home directory, or dies on error. + +=head2 users_documents + + $docs = File::HomeDir->users_documents('foo'); + +Returns the directory path as a string, C<undef> if that user +does not have a documents directory, or dies on error. + +=head2 users_data + + $data = File::HomeDir->users_data('foo'); + +Returns the directory path as a string, C<undef> if that user +does not have a data directory, or dies on error. + +=head1 FUNCTIONS + +=head2 home + + use File::HomeDir; + $home = home(); + $home = home('foo'); + $home = File::HomeDir::home(); + $home = File::HomeDir::home('foo'); + +The C<home> function is exported by default and is provided for +compatibility with legacy applications. In new applications, you should +use the newer method-based interface above. + +Returns the directory path to a named user's home/profile directory. + +If provided no param, returns the directory path to the current user's +home/profile directory. + +=head1 TO DO + +=over 4 + +=item * Add more granularity to Unix, and add support to VMS and other +esoteric platforms, so we can consider going core. + +=item * Add consistent support for users_* methods + +=back + +=head1 SUPPORT + +This module is stored in an Open Repository at the following address. + +L<http://svn.ali.as/cpan/trunk/File-HomeDir> + +Write access to the repository is made available automatically to any +published CPAN author, and to most other volunteers on request. + +If you are able to submit your bug report in the form of new (failing) +unit tests, or can apply your fix directly instead of submitting a patch, +you are B<strongly> encouraged to do so as the author currently maintains +over 100 modules and it can take some time to deal with non-Critical bug +reports or patches. + +This will guarantee that your issue will be addressed in the next +release of the module. + +If you cannot provide a direct test or fix, or don't have time to do so, +then regular bug reports are still accepted and appreciated via the CPAN +bug tracker. + +L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=File-HomeDir> + +For other issues, for commercial enhancement or support, or to have your +write access enabled for the repository, contact the author at the email +address above. + +=head1 ACKNOWLEDGEMENTS + +The biggest acknowledgement goes to Chris Nandor, who wielded his +legendary Mac-fu and turned my initial fairly ordinary Darwin +implementation into something that actually worked properly everywhere, +and then donated a Mac OS X license to allow it to be maintained properly. + +=head1 AUTHORS + +Adam Kennedy E<lt>adamk@cpan.orgE<gt> + +Sean M. Burke E<lt>sburke@cpan.orgE<gt> + +Chris Nandor E<lt>cnandor@cpan.orgE<gt> + +Stephen Steneker E<lt>stennie@cpan.orgE<gt> + +=head1 SEE ALSO + +L<File::ShareDir>, L<File::HomeDir::Win32> (legacy) + +=head1 COPYRIGHT + +Copyright 2005 - 2012 Adam Kennedy. + +Some parts copyright 2000 Sean M. Burke. + +Some parts copyright 2006 Chris Nandor. + +Some parts copyright 2006 Stephen Steneker. + +Some parts copyright 2009-2011 Jérôme Quelin. + +This program is free software; you can redistribute +it and/or modify it under the same terms as Perl itself. + +The full text of the license can be found in the +LICENSE file included with this module. + +=cut diff --git a/lib/File/HomeDir/Darwin.pm b/lib/File/HomeDir/Darwin.pm new file mode 100644 index 0000000..7990eb7 --- /dev/null +++ b/lib/File/HomeDir/Darwin.pm @@ -0,0 +1,152 @@ +package File::HomeDir::Darwin; + +use 5.00503; +use strict; +use Cwd (); +use Carp (); +use File::HomeDir::Unix (); + +use vars qw{$VERSION @ISA}; +BEGIN { + $VERSION = '1.00'; + @ISA = 'File::HomeDir::Unix'; +} + + + + + +##################################################################### +# Current User Methods + +sub my_home { + my $class = shift; + + if ( exists $ENV{HOME} and defined $ENV{HOME} ) { + return $ENV{HOME}; + } + + my $home = (getpwuid($<))[7]; + return $home if $home && -d $home; + + return undef; +} + +sub _my_home { + my($class, $path) = @_; + my $home = $class->my_home; + return undef unless defined $home; + + my $folder = "$home/$path"; + unless ( -d $folder ) { + # Make sure that symlinks resolve to directories. + return undef unless -l $folder; + my $dir = readlink $folder or return; + return undef unless -d $dir; + } + + return Cwd::abs_path($folder); +} + +sub my_desktop { + my $class = shift; + $class->_my_home('Desktop'); +} + +sub my_documents { + my $class = shift; + $class->_my_home('Documents'); +} + +sub my_data { + my $class = shift; + $class->_my_home('Library/Application Support'); +} + +sub my_music { + my $class = shift; + $class->_my_home('Music'); +} + +sub my_pictures { + my $class = shift; + $class->_my_home('Pictures'); +} + +sub my_videos { + my $class = shift; + $class->_my_home('Movies'); +} + + + + + +##################################################################### +# Arbitrary User Methods + +sub users_home { + my $class = shift; + my $home = $class->SUPER::users_home(@_); + return defined $home ? Cwd::abs_path($home) : undef; +} + +sub users_desktop { + my ($class, $name) = @_; + return undef if $name eq 'root'; + $class->_to_user( $class->my_desktop, $name ); +} + +sub users_documents { + my ($class, $name) = @_; + return undef if $name eq 'root'; + $class->_to_user( $class->my_documents, $name ); +} + +sub users_data { + my ($class, $name) = @_; + $class->_to_user( $class->my_data, $name ) + || + $class->users_home($name); +} + +# cheap hack ... not entirely reliable, perhaps, but ... c'est la vie, since +# there's really no other good way to do it at this time, that i know of -- pudge +sub _to_user { + my ($class, $path, $name) = @_; + my $my_home = $class->my_home; + my $users_home = $class->users_home($name); + defined $users_home or return undef; + $path =~ s/^\Q$my_home/$users_home/; + return $path; +} + +1; + +=pod + +=head1 NAME + +File::HomeDir::Darwin - Find your home and other directories on Darwin (OS X) + +=head1 DESCRIPTION + +This module provides Mac OS X specific file path for determining +common user directories in pure perl, by just using C<$ENV{HOME}> +without Carbon nor Cocoa API calls. In normal usage this module will +always be used via L<File::HomeDir>. + +=head1 SYNOPSIS + + use File::HomeDir; + + # Find directories for the current user + $home = File::HomeDir->my_home; # /Users/mylogin + $desktop = File::HomeDir->my_desktop; # /Users/mylogin/Desktop + $docs = File::HomeDir->my_documents; # /Users/mylogin/Documents + $music = File::HomeDir->my_music; # /Users/mylogin/Music + $pics = File::HomeDir->my_pictures; # /Users/mylogin/Pictures + $videos = File::HomeDir->my_videos; # /Users/mylogin/Movies + $data = File::HomeDir->my_data; # /Users/mylogin/Library/Application Support + +=cut diff --git a/lib/File/HomeDir/Darwin/Carbon.pm b/lib/File/HomeDir/Darwin/Carbon.pm new file mode 100644 index 0000000..496a1f2 --- /dev/null +++ b/lib/File/HomeDir/Darwin/Carbon.pm @@ -0,0 +1,210 @@ +package File::HomeDir::Darwin::Carbon; + +# Basic implementation for the Dawin family of operating systems. +# This includes (most prominently) Mac OS X. + +use 5.00503; +use strict; +use Cwd (); +use Carp (); +use File::HomeDir::Darwin (); + +use vars qw{$VERSION @ISA}; +BEGIN { + $VERSION = '1.00'; + + # This is only a child class of the pure Perl darwin + # class so that we can do homedir detection of all three + # drivers at one via ->isa. + @ISA = 'File::HomeDir::Darwin'; + + # Load early if in a forking environment and we have + # prefork, or at run-time if not. + local $@; + eval "use prefork 'Mac::Files'"; +} + + + + + +##################################################################### +# Current User Methods + +sub my_home { + my $class = shift; + + # A lot of unix people and unix-derived tools rely on + # the ability to overload HOME. We will support it too + # so that they can replace raw HOME calls with File::HomeDir. + if ( exists $ENV{HOME} and defined $ENV{HOME} ) { + return $ENV{HOME}; + } + + require Mac::Files; + $class->_find_folder( + Mac::Files::kCurrentUserFolderType(), + ); +} + +sub my_desktop { + my $class = shift; + + require Mac::Files; + $class->_find_folder( + Mac::Files::kDesktopFolderType(), + ); +} + +sub my_documents { + my $class = shift; + + require Mac::Files; + $class->_find_folder( + Mac::Files::kDocumentsFolderType(), + ); +} + +sub my_data { + my $class = shift; + + require Mac::Files; + $class->_find_folder( + Mac::Files::kApplicationSupportFolderType(), + ); +} + +sub my_music { + my $class = shift; + + require Mac::Files; + $class->_find_folder( + Mac::Files::kMusicDocumentsFolderType(), + ); +} + +sub my_pictures { + my $class = shift; + + require Mac::Files; + $class->_find_folder( + Mac::Files::kPictureDocumentsFolderType(), + ); +} + +sub my_videos { + my $class = shift; + + require Mac::Files; + $class->_find_folder( + Mac::Files::kMovieDocumentsFolderType(), + ); +} + +sub _find_folder { + my $class = shift; + my $name = shift; + + require Mac::Files; + my $folder = Mac::Files::FindFolder( + Mac::Files::kUserDomain(), + $name, + ); + return undef unless defined $folder; + + unless ( -d $folder ) { + # Make sure that symlinks resolve to directories. + return undef unless -l $folder; + my $dir = readlink $folder or return; + return undef unless -d $dir; + } + + return Cwd::abs_path($folder); +} + + + + + +##################################################################### +# Arbitrary User Methods + +sub users_home { + my $class = shift; + my $home = $class->SUPER::users_home(@_); + return defined $home ? Cwd::abs_path($home) : undef; +} + +# in theory this can be done, but for now, let's cheat, since the +# rest is Hard +sub users_desktop { + my ($class, $name) = @_; + return undef if $name eq 'root'; + $class->_to_user( $class->my_desktop, $name ); +} + +sub users_documents { + my ($class, $name) = @_; + return undef if $name eq 'root'; + $class->_to_user( $class->my_documents, $name ); +} + +sub users_data { + my ($class, $name) = @_; + $class->_to_user( $class->my_data, $name ) + || + $class->users_home($name); +} + +# cheap hack ... not entirely reliable, perhaps, but ... c'est la vie, since +# there's really no other good way to do it at this time, that i know of -- pudge +sub _to_user { + my ($class, $path, $name) = @_; + my $my_home = $class->my_home; + my $users_home = $class->users_home($name); + defined $users_home or return undef; + $path =~ s/^\Q$my_home/$users_home/; + return $path; +} + +1; + +=pod + +=head1 NAME + +File::HomeDir::Darwin - Find your home and other directories on Darwin (OS X) + +=head1 DESCRIPTION + +This module provides Darwin-specific implementations for determining +common user directories. In normal usage this module will always be +used via L<File::HomeDir>. + +Note -- since this module requires Mac::Carbon and Mac::Carbon does +not work with 64-bit perls, on such systems, File::HomeDir will try +L<File::HomeDir::Darwin::Cocoa> and then fall back to the (pure Perl) +L<File::HomeDir::Darwin>. + +=head1 SYNOPSIS + + use File::HomeDir; + + # Find directories for the current user + $home = File::HomeDir->my_home; # /Users/mylogin + $desktop = File::HomeDir->my_desktop; # /Users/mylogin/Desktop + $docs = File::HomeDir->my_documents; # /Users/mylogin/Documents + $music = File::HomeDir->my_music; # /Users/mylogin/Music + $pics = File::HomeDir->my_pictures; # /Users/mylogin/Pictures + $videos = File::HomeDir->my_videos; # /Users/mylogin/Movies + $data = File::HomeDir->my_data; # /Users/mylogin/Library/Application Support + +=head1 TODO + +=over 4 + +=item * Test with Mac OS (versions 7, 8, 9) + +=item * Some better way for users_* ? + +=back diff --git a/lib/File/HomeDir/Darwin/Cocoa.pm b/lib/File/HomeDir/Darwin/Cocoa.pm new file mode 100644 index 0000000..b54ea69 --- /dev/null +++ b/lib/File/HomeDir/Darwin/Cocoa.pm @@ -0,0 +1,165 @@ +package File::HomeDir::Darwin::Cocoa; + +use 5.00503; +use strict; +use Cwd (); +use Carp (); +use File::HomeDir::Darwin (); + +use vars qw{$VERSION @ISA}; +BEGIN { + $VERSION = '1.00'; + @ISA = 'File::HomeDir::Darwin'; + + # Load early if in a forking environment and we have + # prefork, or at run-time if not. + local $@; + eval "use prefork 'Mac::SystemDirectory'"; +} + + + + + +##################################################################### +# Current User Methods + +sub my_home { + my $class = shift; + + # A lot of unix people and unix-derived tools rely on + # the ability to overload HOME. We will support it too + # so that they can replace raw HOME calls with File::HomeDir. + if ( exists $ENV{HOME} and defined $ENV{HOME} ) { + return $ENV{HOME}; + } + + require Mac::SystemDirectory; + return Mac::SystemDirectory::HomeDirectory(); +} + +# from 10.4 +sub my_desktop { + my $class = shift; + + require Mac::SystemDirectory; + eval { + $class->_find_folder(Mac::SystemDirectory::NSDesktopDirectory()) + } + || + $class->SUPER::my_desktop; +} + +# from 10.2 +sub my_documents { + my $class = shift; + + require Mac::SystemDirectory; + eval { + $class->_find_folder(Mac::SystemDirectory::NSDocumentDirectory()) + } + || + $class->SUPER::my_documents; +} + +# from 10.4 +sub my_data { + my $class = shift; + + require Mac::SystemDirectory; + eval { + $class->_find_folder(Mac::SystemDirectory::NSApplicationSupportDirectory()) + } + || + $class->SUPER::my_data; +} + +# from 10.6 +sub my_music { + my $class = shift; + + require Mac::SystemDirectory; + eval { + $class->_find_folder(Mac::SystemDirectory::NSMusicDirectory()) + } + || + $class->SUPER::my_music; +} + +# from 10.6 +sub my_pictures { + my $class = shift; + + require Mac::SystemDirectory; + eval { + $class->_find_folder(Mac::SystemDirectory::NSPicturesDirectory()) + } + || + $class->SUPER::my_pictures; +} + +# from 10.6 +sub my_videos { + my $class = shift; + + require Mac::SystemDirectory; + eval { + $class->_find_folder(Mac::SystemDirectory::NSMoviesDirectory()) + } + || + $class->SUPER::my_videos; +} + +sub _find_folder { + my $class = shift; + my $name = shift; + + require Mac::SystemDirectory; + my $folder = Mac::SystemDirectory::FindDirectory($name); + return undef unless defined $folder; + + unless ( -d $folder ) { + # Make sure that symlinks resolve to directories. + return undef unless -l $folder; + my $dir = readlink $folder or return; + return undef unless -d $dir; + } + + return Cwd::abs_path($folder); +} + +1; + +=pod + +=head1 NAME + +File::HomeDir::Darwin::Cocoa - Find your home and other directories on Darwin (OS X) + +=head1 DESCRIPTION + +This module provides Darwin-specific implementations for determining +common user directories using Cocoa API through +L<Mac::SystemDirectory>. In normal usage this module will always be +used via L<File::HomeDir>. + +Theoretically, this should return the same paths as both of the other +Darwin drivers. + +Because this module requires L<Mac::SystemDirectory>, if the module +is not installed, L<File::HomeDir> will fall back to L<File::HomeDir::Darwin>. + +=head1 SYNOPSIS + + use File::HomeDir; + + # Find directories for the current user + $home = File::HomeDir->my_home; # /Users/mylogin + $desktop = File::HomeDir->my_desktop; # /Users/mylogin/Desktop + $docs = File::HomeDir->my_documents; # /Users/mylogin/Documents + $music = File::HomeDir->my_music; # /Users/mylogin/Music + $pics = File::HomeDir->my_pictures; # /Users/mylogin/Pictures + $videos = File::HomeDir->my_videos; # /Users/mylogin/Movies + $data = File::HomeDir->my_data; # /Users/mylogin/Library/Application Support + +=cut diff --git a/lib/File/HomeDir/Driver.pm b/lib/File/HomeDir/Driver.pm new file mode 100644 index 0000000..348f97b --- /dev/null +++ b/lib/File/HomeDir/Driver.pm @@ -0,0 +1,54 @@ +package File::HomeDir::Driver; + +# Abstract base class that provides no functionality, +# but confirms the class is a File::HomeDir driver class. + +use 5.00503; +use strict; +use Carp (); + +use vars qw{$VERSION}; +BEGIN { + $VERSION = '1.00'; +} + +sub my_home { + Carp::croak("$_[0] does not implement compulsory method $_[1]"); +} + +1; + +=pod + +=head1 NAME + +File::HomeDir::Driver - Base class for all File::HomeDir drivers + +=head1 DESCRIPTION + +This module is the base class for all L<File::HomeDir> drivers, and must +be inherited from to identify a class as a driver. + +It is primarily provided as a convenience for this specific identification +purpose, as L<File::HomeDir> supports the specification of custom drivers +and an C<-E<gt>isa> check is used during the loading of the driver. + +=head1 AUTHOR + +Adam Kennedy E<lt>adamk@cpan.orgE<gt> + +=head1 SEE ALSO + +L<File::HomeDir> + +=head1 COPYRIGHT + +Copyright 2009 - 2011 Adam Kennedy. + +This program is free software; you can redistribute +it and/or modify it under the same terms as Perl itself. + +The full text of the license can be found in the +LICENSE file included with this module. + +=cut diff --git a/lib/File/HomeDir/FreeDesktop.pm b/lib/File/HomeDir/FreeDesktop.pm new file mode 100644 index 0000000..c006921 --- /dev/null +++ b/lib/File/HomeDir/FreeDesktop.pm @@ -0,0 +1,136 @@ +package File::HomeDir::FreeDesktop; + +# Specific functionality for unixes running free desktops +# compatible with (but not using) File-BaseDir-0.03 + +# See POD at the end of the file for more documentation. + +use 5.00503; +use strict; +use Carp (); +use File::Spec (); +use File::Which (); +use File::HomeDir::Unix (); + +use vars qw{$VERSION @ISA}; +BEGIN { + $VERSION = '1.00'; + @ISA = 'File::HomeDir::Unix'; +} + +# xdg uses $ENV{XDG_CONFIG_HOME}/user-dirs.dirs to know where are the +# various "my xxx" directories. That is a shell file. The official API +# is the xdg-user-dir executable. It has no provision for assessing +# the directories of a user that is different than the one we are +# running under; the standard substitute user mechanisms are needed to +# overcome this. + +my $xdgprog = File::Which::which('xdg-user-dir'); + +sub _my { + # No quoting because input is hard-coded and only comes from this module + my $thingy = qx($xdgprog $_[1]); + chomp $thingy; + return $thingy; +} + +# Simple stuff +sub my_desktop { shift->_my('DESKTOP') } +sub my_documents { shift->_my('DOCUMENTS') } +sub my_music { shift->_my('MUSIC') } +sub my_pictures { shift->_my('PICTURES') } +sub my_videos { shift->_my('VIDEOS') } + +sub my_data { + $ENV{XDG_DATA_HOME} + or + File::Spec->catdir( + shift->my_home, + qw{ .local share } + ); +} + +sub my_config { + $ENV{XDG_CONFIG_HOME} + or + File::Spec->catdir( + shift->my_home, + qw{ .config } + ); +} + +# Custom locations (currently undocumented) +sub my_download { shift->_my('DOWNLOAD') } +sub my_publicshare { shift->_my('PUBLICSHARE') } +sub my_templates { shift->_my('TEMPLATES') } + +sub my_cache { + $ENV{XDG_CACHE_HOME} + || + File::Spec->catdir(shift->my_home, qw{ .cache }); +} + + + + + +##################################################################### +# General User Methods + +sub users_desktop { Carp::croak('The users_desktop method is not available on an XDG based system.'); } +sub users_documents { Carp::croak('The users_documents method is not available on an XDG based system.'); } +sub users_music { Carp::croak('The users_music method is not available on an XDG based system.'); } +sub users_pictures { Carp::croak('The users_pictures method is not available on an XDG based system.'); } +sub users_videos { Carp::croak('The users_videos method is not available on an XDG based system.'); } +sub users_data { Carp::croak('The users_data method is not available on an XDG based system.'); } + +1; + +=pod + +=head1 NAME + +File::HomeDir::FreeDesktop - Find your home and other directories on FreeDesktop.org Unix + +=head1 DESCRIPTION + +This module provides implementations for determining common user +directories. In normal usage this module will always be +used via L<File::HomeDir>. + +=head1 SYNOPSIS + + use File::HomeDir; + + # Find directories for the current user + $home = File::HomeDir->my_home; # /home/mylogin + $desktop = File::HomeDir->my_desktop; + $docs = File::HomeDir->my_documents; + $music = File::HomeDir->my_music; + $pics = File::HomeDir->my_pictures; + $videos = File::HomeDir->my_videos; + $data = File::HomeDir->my_data; + +=head1 AUTHORS + +Jerome Quelin E<lt>jquellin@cpan.org<gt> + +Adam Kennedy E<lt>adamk@cpan.orgE<gt> + +=head1 SEE ALSO + +L<File::HomeDir>, L<File::HomeDir::Win32> (legacy) + +=head1 COPYRIGHT + +Copyright 2009 - 2011 Jerome Quelin. + +Some parts copyright 2010 Adam Kennedy. + +This program is free software; you can redistribute +it and/or modify it under the same terms as Perl itself. + +The full text of the license can be found in the +LICENSE file included with this module. + +=cut diff --git a/lib/File/HomeDir/MacOS9.pm b/lib/File/HomeDir/MacOS9.pm new file mode 100644 index 0000000..c88ec34 --- /dev/null +++ b/lib/File/HomeDir/MacOS9.pm @@ -0,0 +1,150 @@ +package File::HomeDir::MacOS9; + +# Half-assed implementation for the legacy Mac OS9 operating system. +# Provided mainly to provide legacy compatibility. May be removed at +# a later date. + +use 5.00503; +use strict; +use Carp (); +use File::HomeDir::Driver (); + +use vars qw{$VERSION @ISA}; +BEGIN { + $VERSION = '1.00'; + @ISA = 'File::HomeDir::Driver'; +} + +# Load early if in a forking environment and we have +# prefork, or at run-time if not. +SCOPE: { + local $@; + eval "use prefork 'Mac::Files'"; +} + + + + + +##################################################################### +# Current User Methods + +sub my_home { + my $class = shift; + + # Try for $ENV{HOME} if we have it + if ( defined $ENV{HOME} ) { + return $ENV{HOME}; + } + + ### DESPERATION SETS IN + + # We could use the desktop + SCOPE: { + local $@; + eval { + my $home = $class->my_desktop; + return $home if $home and -d $home; + }; + } + + # Desperation on any platform + SCOPE: { + # On some platforms getpwuid dies if called at all + local $SIG{'__DIE__'} = ''; + my $home = (getpwuid($<))[7]; + return $home if $home and -d $home; + } + + Carp::croak("Could not locate current user's home directory"); +} + +sub my_desktop { + my $class = shift; + + # Find the desktop via Mac::Files + local $SIG{'__DIE__'} = ''; + require Mac::Files; + my $home = Mac::Files::FindFolder( + Mac::Files::kOnSystemDisk(), + Mac::Files::kDesktopFolderType(), + ); + return $home if $home and -d $home; + + Carp::croak("Could not locate current user's desktop"); +} + + + + + +##################################################################### +# General User Methods + +sub users_home { + my ($class, $name) = @_; + + SCOPE: { + # On some platforms getpwnam dies if called at all + local $SIG{'__DIE__'} = ''; + my $home = (getpwnam($name))[7]; + return $home if defined $home and -d $home; + } + + Carp::croak("Failed to find home directory for user '$name'"); +} + +1; + +=pod + +=head1 NAME + +File::HomeDir::MacOS9 - Find your home and other directories on legacy Macs + +=head1 SYNOPSIS + + use File::HomeDir; + + # Find directories for the current user + $home = File::HomeDir->my_home; + $desktop = File::HomeDir->my_desktop; + +=head1 DESCRIPTION + +This module provides implementations for determining common user +directories on legacy Mac hosts. In normal usage this module will always be +used via L<File::HomeDir>. + +This module is no longer actively maintained, and is included only for +extreme back-compatibility. + +Only the C<my_home> and C<my_desktop> methods are supported. + +=head1 SUPPORT + +See the support section the main L<File::HomeDir> module. + +=head1 AUTHORS + +Adam Kennedy E<lt>adamk@cpan.orgE<gt> + +Sean M. Burke E<lt>sburke@cpan.orgE<gt> + +=head1 SEE ALSO + +L<File::HomeDir> + +=head1 COPYRIGHT + +Copyright 2005 - 2011 Adam Kennedy. + +Some parts copyright 2000 Sean M. Burke. + +This program is free software; you can redistribute +it and/or modify it under the same terms as Perl itself. + +The full text of the license can be found in the +LICENSE file included with this module. + +=cut diff --git a/lib/File/HomeDir/Test.pm b/lib/File/HomeDir/Test.pm new file mode 100644 index 0000000..8d0e12c --- /dev/null +++ b/lib/File/HomeDir/Test.pm @@ -0,0 +1,137 @@ +package File::HomeDir::Test; + +use 5.00503; +use strict; +use Carp (); +use File::Spec (); +use File::Temp (); +use File::HomeDir::Driver (); + +use vars qw{$VERSION @ISA %DIR $ENABLED}; +BEGIN { + $VERSION = '1.00'; + @ISA = 'File::HomeDir::Driver'; + %DIR = (); + $ENABLED = 0; +} + +# Special magic use in test scripts +sub import { + my $class = shift; + die "Attempted to initialise File::HomeDir::Test trice" if %DIR; + + # Fill the test directories + my $BASE = File::Temp::tempdir( CLEANUP => 1 ); + %DIR = map { $_ => File::Spec->catdir( $BASE, $_ ) } qw{ + my_home + my_desktop + my_documents + my_data + my_music + my_pictures + my_videos + }; + + # Hijack HOME to the home directory + $ENV{HOME} = $DIR{my_home}; + + # Make File::HomeDir load us instead of the native driver + $File::HomeDir::IMPLEMENTED_BY = # Prevent a warning + $File::HomeDir::IMPLEMENTED_BY = 'File::HomeDir::Test'; + + # Ready to go + $ENABLED = 1; +} + + + + + +##################################################################### +# Current User Methods + +sub my_home { + mkdir($DIR{my_home}, 0755) unless -d $DIR{my_home}; + return $DIR{my_home}; +} + +sub my_desktop { + mkdir($DIR{my_desktop}, 0755) unless -d $DIR{my_desktop}; + return $DIR{my_desktop}; +} + +sub my_documents { + mkdir($DIR{my_documents}, 0755) unless -f $DIR{my_documents}; + return $DIR{my_documents}; +} + +sub my_data { + mkdir($DIR{my_data}, 0755) unless -d $DIR{my_data}; + return $DIR{my_data}; +} + +sub my_music { + mkdir($DIR{my_music}, 0755) unless -d $DIR{my_music}; + return $DIR{my_music}; +} + +sub my_pictures { + mkdir($DIR{my_pictures}, 0755) unless -d $DIR{my_pictures}; + return $DIR{my_pictures}; +} + +sub my_videos { + mkdir($DIR{my_videos}, 0755) unless -d $DIR{my_videos}; + return $DIR{my_videos}; +} + +sub users_home { + return undef; +} + +1; + +__END__ + +=pod + +=head1 NAME + +File::HomeDir::Test - Prevent the accidental creation of user-owned files during testing + +=head1 SYNOPSIS + + use Test::More test => 1; + use File::HomeDir::Test; + use File::HomeDir; + +=head1 DESCRIPTION + +B<File::HomeDir::Test> is a L<File::HomeDir> driver intended for use in the test scripts +of modules or applications that write files into user-owned directories. + +It is designed to prevent the pollution of user directories with files that are not part +of the application install itself, but were created during testing. These files can leak +state information from the tests into the run-time usage of an application, and on Unix +systems also prevents tests (which may be executed as root via sudo) from writing files +which cannot later be modified or removed by the regular user. + +=head1 SUPPORT + +See the support section of the main L<File::HomeDir> documentation. + +=head1 AUTHOR + +Adam Kennedy E<lt>adamk@cpan.orgE<gt> + +=head1 COPYRIGHT + +Copyright 2005 - 2011 Adam Kennedy. + +This program is free software; you can redistribute +it and/or modify it under the same terms as Perl itself. + +The full text of the license can be found in the +LICENSE file included with this module. + +=cut diff --git a/lib/File/HomeDir/Unix.pm b/lib/File/HomeDir/Unix.pm new file mode 100644 index 0000000..6e3c3a1 --- /dev/null +++ b/lib/File/HomeDir/Unix.pm @@ -0,0 +1,186 @@ +package File::HomeDir::Unix; + +# See POD at the end of the file for documentation + +use 5.00503; +use strict; +use Carp (); +use File::HomeDir::Driver (); + +use vars qw{$VERSION @ISA}; +BEGIN { + $VERSION = '1.00'; + @ISA = 'File::HomeDir::Driver'; +} + + + + + +##################################################################### +# Current User Methods + +sub my_home { + my $class = shift; + my $home = $class->_my_home(@_); + + # On Unix in general, a non-existant home means "no home" + # For example, "nobody"-like users might use /nonexistant + if ( defined $home and ! -d $home ) { + $home = undef; + } + + return $home; +} + +sub _my_home { + my $class = shift; + if ( exists $ENV{HOME} and defined $ENV{HOME} ) { + return $ENV{HOME}; + } + + # This is from the original code, but I'm guessing + # it means "login directory" and exists on some Unixes. + if ( exists $ENV{LOGDIR} and $ENV{LOGDIR} ) { + return $ENV{LOGDIR}; + } + + ### More-desperate methods + + # Light desperation on any (Unixish) platform + SCOPE: { + my $home = (getpwuid($<))[7]; + return $home if $home and -d $home; + } + + return undef; +} + +# On unix by default, everything is under the same folder +sub my_desktop { + shift->my_home; +} + +sub my_documents { + shift->my_home; +} + +sub my_data { + shift->my_home; +} + +sub my_music { + shift->my_home; +} + +sub my_pictures { + shift->my_home; +} + +sub my_videos { + shift->my_home; +} + + + + + +##################################################################### +# General User Methods + +sub users_home { + my ($class, $name) = @_; + + # IF and only if we have getpwuid support, and the + # name of the user is our own, shortcut to my_home. + # This is needed to handle HOME environment settings. + if ( $name eq getpwuid($<) ) { + return $class->my_home; + } + + SCOPE: { + my $home = (getpwnam($name))[7]; + return $home if $home and -d $home; + } + + return undef; +} + +sub users_desktop { + shift->users_home(@_); +} + +sub users_documents { + shift->users_home(@_); +} + +sub users_data { + shift->users_home(@_); +} + +sub users_music { + shift->users_home(@_); +} + +sub users_pictures { + shift->users_home(@_); +} + +sub users_videos { + shift->users_home(@_); +} + +1; + +=pod + +=head1 NAME + +File::HomeDir::Unix - Find your home and other directories on legacy Unix + +=head1 SYNOPSIS + + use File::HomeDir; + + # Find directories for the current user + $home = File::HomeDir->my_home; # /home/mylogin + $desktop = File::HomeDir->my_desktop; # All of these will... + $docs = File::HomeDir->my_documents; # ...default to home... + $music = File::HomeDir->my_music; # ...directory + $pics = File::HomeDir->my_pictures; # + $videos = File::HomeDir->my_videos; # + $data = File::HomeDir->my_data; # + +=head1 DESCRIPTION + +This module provides implementations for determining common user +directories. In normal usage this module will always be +used via L<File::HomeDir>. + +=head1 SUPPORT + +See the support section the main L<File::HomeDir> module. + +=head1 AUTHORS + +Adam Kennedy E<lt>adamk@cpan.orgE<gt> + +Sean M. Burke E<lt>sburke@cpan.orgE<gt> + +=head1 SEE ALSO + +L<File::HomeDir>, L<File::HomeDir::Win32> (legacy) + +=head1 COPYRIGHT + +Copyright 2005 - 2011 Adam Kennedy. + +Some parts copyright 2000 Sean M. Burke. + +This program is free software; you can redistribute +it and/or modify it under the same terms as Perl itself. + +The full text of the license can be found in the +LICENSE file included with this module. + +=cut diff --git a/lib/File/HomeDir/Windows.pm b/lib/File/HomeDir/Windows.pm new file mode 100644 index 0000000..4e1de6a --- /dev/null +++ b/lib/File/HomeDir/Windows.pm @@ -0,0 +1,241 @@ +package File::HomeDir::Windows; + +# See POD at the end of the file for documentation + +use 5.00503; +use strict; +use Carp (); +use File::Spec (); +use File::HomeDir::Driver (); + +use vars qw{$VERSION @ISA}; +BEGIN { + $VERSION = '1.00'; + @ISA = 'File::HomeDir::Driver'; +} + +sub CREATE () { 1 } + + + + + +##################################################################### +# Current User Methods + +sub my_home { + my $class = shift; + + # A lot of unix people and unix-derived tools rely on + # the ability to overload HOME. We will support it too + # so that they can replace raw HOME calls with File::HomeDir. + if ( exists $ENV{HOME} and $ENV{HOME} ) { + return $ENV{HOME}; + } + + # Do we have a user profile? + if ( exists $ENV{USERPROFILE} and $ENV{USERPROFILE} ) { + return $ENV{USERPROFILE}; + } + + # Some Windows use something like $ENV{HOME} + if ( exists $ENV{HOMEDRIVE} and exists $ENV{HOMEPATH} and $ENV{HOMEDRIVE} and $ENV{HOMEPATH} ) { + return File::Spec->catpath( + $ENV{HOMEDRIVE}, $ENV{HOMEPATH}, '', + ); + } + + return undef; +} + +sub my_desktop { + my $class = shift; + + # The most correct way to find the desktop + SCOPE: { + require Win32; + my $dir = Win32::GetFolderPath(Win32::CSIDL_DESKTOP(), CREATE); + return $dir if $dir and $class->_d($dir); + } + + # MSWindows sets WINDIR, MS WinNT sets USERPROFILE. + foreach my $e ( 'USERPROFILE', 'WINDIR' ) { + next unless $ENV{$e}; + my $desktop = File::Spec->catdir($ENV{$e}, 'Desktop'); + return $desktop if $desktop and $class->_d($desktop); + } + + # As a last resort, try some hard-wired values + foreach my $fixed ( + # The reason there are both types of slash here is because + # this set of paths has been kept from thethe original version + # of File::HomeDir::Win32 (before it was rewritten). + # I can only assume this is Cygwin-related stuff. + "C:\\windows\\desktop", + "C:\\win95\\desktop", + "C:/win95/desktop", + "C:/windows/desktop", + ) { + return $fixed if $class->_d($fixed); + } + + return undef; +} + +sub my_documents { + my $class = shift; + + # The most correct way to find my documents + SCOPE: { + require Win32; + my $dir = Win32::GetFolderPath(Win32::CSIDL_PERSONAL(), CREATE); + return $dir if $dir and $class->_d($dir); + } + + return undef; +} + +sub my_data { + my $class = shift; + + # The most correct way to find my documents + SCOPE: { + require Win32; + my $dir = Win32::GetFolderPath(Win32::CSIDL_LOCAL_APPDATA(), CREATE); + return $dir if $dir and $class->_d($dir); + } + + return undef; +} + +sub my_music { + my $class = shift; + + # The most correct way to find my music + SCOPE: { + require Win32; + my $dir = Win32::GetFolderPath(Win32::CSIDL_MYMUSIC(), CREATE); + return $dir if $dir and $class->_d($dir); + } + + return undef; +} + +sub my_pictures { + my $class = shift; + + # The most correct way to find my pictures + SCOPE: { + require Win32; + my $dir = Win32::GetFolderPath(Win32::CSIDL_MYPICTURES(), CREATE); + return $dir if $dir and $class->_d($dir); + } + + return undef; +} + +sub my_videos { + my $class = shift; + + # The most correct way to find my videos + SCOPE: { + require Win32; + my $dir = Win32::GetFolderPath(Win32::CSIDL_MYVIDEO(), CREATE); + return $dir if $dir and $class->_d($dir); + } + + return undef; +} + +# Special case version of -d +sub _d { + my $self = shift; + my $path = shift; + + # Window can legally return a UNC path from GetFolderPath. + # Not only is the meaning of -d complicated in this situation, + # but even on a local network calling -d "\\\\cifs\\path" can + # take several seconds. UNC can also do even weirder things, + # like launching processes and such. + # To avoid various crazy bugs caused by this, we do NOT attempt + # to validate UNC paths at all so that the code that is calling + # us has an opportunity to take special actions without our + # blundering getting in the way. + if ( $path =~ /\\\\/ ) { + return 1; + } + + # Otherwise do a stat as normal + return -d $path; +} + +1; + +=pod + +=head1 NAME + +File::HomeDir::Windows - Find your home and other directories on Windows + +=head1 SYNOPSIS + + use File::HomeDir; + + # Find directories for the current user (eg. using Windows XP Professional) + $home = File::HomeDir->my_home; # C:\Documents and Settings\mylogin + $desktop = File::HomeDir->my_desktop; # C:\Documents and Settings\mylogin\Desktop + $docs = File::HomeDir->my_documents; # C:\Documents and Settings\mylogin\My Documents + $music = File::HomeDir->my_music; # C:\Documents and Settings\mylogin\My Documents\My Music + $pics = File::HomeDir->my_pictures; # C:\Documents and Settings\mylogin\My Documents\My Pictures + $videos = File::HomeDir->my_videos; # C:\Documents and Settings\mylogin\My Documents\My Video + $data = File::HomeDir->my_data; # C:\Documents and Settings\mylogin\Local Settings\Application Data + +=head1 DESCRIPTION + +This module provides Windows-specific implementations for determining +common user directories. In normal usage this module will always be +used via L<File::HomeDir>. + +Internally this module will use L<Win32>::GetFolderPath to fetch the location +of your directories. As a result of this, in certain unusual situations +(usually found inside large organisations) the methods may return UNC paths +such as C<\\cifs.local\home$>. + +If your application runs on Windows and you want to have it work comprehensively +everywhere, you may need to implement your own handling for these paths as they +can cause strange behaviour. + +For example, stat calls to UNC paths may work but block for several seconds, but +opendir() may not be able to read any files (creating the appearance of an existing +but empty directory). + +To avoid complicating the problem any further, in the rare situation that a UNC path +is returned by C<GetFolderPath> the usual -d validation checks will B<not> be done. + +=head1 SUPPORT + +See the support section the main L<File::HomeDir> module. + +=head1 AUTHORS + +Adam Kennedy E<lt>adamk@cpan.orgE<gt> + +Sean M. Burke E<lt>sburke@cpan.orgE<gt> + +=head1 SEE ALSO + +L<File::HomeDir>, L<File::HomeDir::Win32> (legacy) + +=head1 COPYRIGHT + +Copyright 2005 - 2011 Adam Kennedy. + +Some parts copyright 2000 Sean M. Burke. + +This program is free software; you can redistribute +it and/or modify it under the same terms as Perl itself. + +The full text of the license can be found in the +LICENSE file included with this module. + +=cut |