File::HomeDir::Win32 - Find home directories on Win32 systems

File-HomeDir-Win32 documentation Contained in the File-HomeDir-Win32 distribution.

Index

Code Index:

NAME

Top

File::HomeDir::Win32 - Find home directories on Win32 systems

SYNOPSIS

Top

  use File::HomeDir::Win32;

  print "My dir is ",home()," and root's is ",home('Administrator'),"\n";

DESCRIPTION

Top

This module provides routines for finding home directories on Win32 systems. It was designed as a companion to File::HomeDir that overrides the existing home function, which does not properly locate home directories on Windows machines.

To use both modules together:

  use File::HomeDir;

  BEGIN {
    if ($^O eq "MSWin32") {
      eval {
        require File::HomeDir::Win32;
        File::HomeDir::Win32->import();
      };
      die "$@" if ($@); 
    }
  }

or (if you have the if module),

  use File::HomeDir;
  use if ($^O eq "MSWin32"), "File::HomeDir::Win32";

The home function should work as normal.

On systems with no profiles, such as Windows 98, or in cases where it cannot find profiles, it will not override File::HomeDir. (In such cases it will die if File::HomeDir is not loaded.)

SEE ALSO

Top

  File::HomeDir

AUTHOR

Top

Robert Rothenberg <rrwo at cpan.org>

Current maintainer: Randy Kobes <r.kobes at uwinnipeg.ca>

Suggestions and Bug Reporting

Feedback is always welcome. Please use the CPAN Request Tracker at http://rt.cpan.org to submit bug reports.

LICENSE

Top

Copyright (c) 2005 Robert Rothenberg. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

File-HomeDir-Win32 documentation Contained in the File-HomeDir-Win32 distribution. 
package File::HomeDir::Win32;

use 5.006;
use strict;
use warnings;

my %Registry;

use Carp;
use Win32;
use Win32::Security::SID;
use Win32::TieRegistry ( TiedHash => \%Registry );

require Exporter;

our @ISA = qw(Exporter);

our %EXPORT_TAGS = ( 'all' => [ qw( home ) ] );
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT = qw( home );

our $VERSION = '0.04';

my %HomeDirs;

sub import {
  no strict 'refs';

  my $caller = caller(0);
  my $stash  = *{$caller."::"};

  sub _set_stash {
    my $value  = shift;
    my $caller = shift;
    my $stash  = *{$caller."::"};

    my @names  = split /::/, shift;

    # print STDERR join(" ", @names), "\n";

    while (my $level = shift @names) {
      $level .= "::",
	if (@names);
      return,
	unless (defined $stash->{$level});
      if (@names) {
	$stash = $stash->{$level};
      } else {
	no warnings 'redefine';
	$stash->{$level} = $value,
	  if ((defined &{$stash->{$level}}) && ((ref $value) eq "CODE"));
      }
    }
  }

  # print STDERR "caller = $caller\n";

  _find_homedirs(), unless (keys %HomeDirs);
  if ((keys %HomeDirs) && (defined &{$stash->{home}})) {
    if (@_ > 1) {
      carp "Exporter arguments ignored";
    }

    _set_stash(\&home, $caller, "home");

    _set_stash(\&home, $caller, "File::HomeDir::home");
    _set_stash(\&home, "main", "File::HomeDir::home"),
      if ($caller ne "main");

    return;
  }
  else {
    croak "Fatal error: cannot find profiles in Windows registry"
      unless (keys %HomeDirs);
    goto &Exporter::import;
  }
}

sub _find_homedirs {
  %HomeDirs    = ( );

  my $node_name   = Win32::NodeName;
  my $domain_name = Win32::DomainName;

  my $profiles = $Registry{'HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Windows NT\\CurrentVersion\\ProfileList\\'};
  unless ($profiles) {
    # Windows 98
    $profiles = $Registry{'HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\ProfileList\\'};  
  }
  unless ($profiles) {
    return;
  }

  foreach my $p (keys %$profiles) {
    if ($p =~ /^(S(?:-\d+)+)\\$/) {
      my $sid_str = $1;
      my $sid = Win32::Security::SID::ConvertStringSidToSid($1);
      my $uid = Win32::Security::SID::ConvertSidToName($sid);
      my $domain = "";
      if ($uid =~ /^(.+)\\(.+)$/) {
	$domain = $1;
	$uid    = $2;
      }
      if ($domain eq $node_name || $domain eq $domain_name) {
	my $path = $profiles->{$p}->{ProfileImagePath};
	$path =~ s/\%(.+)\%/$ENV{$1}/eg;
	$HomeDirs{$uid} = $path;
      }
    }
  }
}

sub home(;$) {
  my $user = $ENV{USERNAME};
  $user = shift if (@_);
  croak "Can\'t use undef as a username" unless (defined $user);

  _find_homedirs(), unless (keys %HomeDirs);

  if (exists $HomeDirs{$user}) {
    return $HomeDirs{$user};
  }
  else {
    return;
  }
}

1;

__END__