diff options
author | Lorry Tar Creator <lorry-tar-importer@lorry> | 2012-10-19 21:35:48 +0000 |
---|---|---|
committer | Lorry Tar Creator <lorry-tar-importer@lorry> | 2012-10-19 21:35:48 +0000 |
commit | d08b8685307cd5e8980f3c9409d4b3c1d06b2c24 (patch) | |
tree | 30c354e50c1fd36e567bce95d686ab786cd83fff /lib/File/HomeDir | |
download | File-HomeDir-tarball-master.tar.gz |
File-HomeDir-1.00HEADFile-HomeDir-1.00master
Diffstat (limited to 'lib/File/HomeDir')
-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 |
9 files changed, 1431 insertions, 0 deletions
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 |