tie VARIABLE, CLASSNAME, LIST
####
use Tie::Dir;
tie %hash, Tie::Dir, "./";
##
##
TIEHASH classname, LIST
DESTROY this
FETCH this, key
STORE this, key, value
DELETE this, key
EXISTS this, key
FIRSTKEY this
NEXTKEY this, lastkey
##
##
TIEARRAY classname, LIST
DESTROY this
FETCH this, key
STORE this, key, value
##
##
TIEHANDLE classname, LIST
WRITE this, LIST
PRINT this, LIST
PRINTF this, LIST
READ this, LIST
READLINE this
GETC this
CLOSE this
DESTROY this
##
##
# tie %hash, Tie::Dir, ".", DIR_UNLINK;
sub TIEHASH {
my($class,$dir,$unlink) = @_;
$unlink ||= 0;
bless [$dir,undef,$unlink], $class;
}
##
##
sub TIESCALAR {
my $class = shift;
my $name = shift;
my $city = system("/bin/cat", "$name\.city");
return bless \$city, $class;
}
##
##
use Tie::getCity; # If the module name was Tie/getCity.pm
tie($foo, 'Tie::getCity', $ENV{REMOTE_USER});
##
##
untie $foo;
##
##
package Example;
use strict;
use vars qw($VERSION);
# pull $VERSION from RCS version identifier
($VERSION = substr(q$Revision: 0.7 $, 10)) =~ s/\s+$//;
sub Version {return $VERSION;}
use Carp;
##
##
# Create tied hash
sub TIEHASH {
my $self = shift;
my $path = shift;
my $mode = shift || 'r';
if (@_) {
croak ("usage: tie(\%hash, \$file, [mode])");
}
my $clobber = ($mode eq 'rw' ? 1 : 0);
my $node = {
PATH => $path,
CLOBBER => $clobber,
CURRENT => {}
};
open(FH, "$path");
my @lines = ;
close FH;
my ($line, $id, $pass);
foreach $line (@lines) {
($id, $pass) = split(/\:/,$line);
$node->{CURRENT}{$id} = $pass;
}
return bless $node => $self;
}
##
##
$hash{FOO} = "bar";
##
##
# Store an entry
sub STORE {
my $self = shift;
my ($id) = shift;
my ($passwd) = shift;
my ($passwdFile) = $self->{PATH};
my ($return)=0;
my (@cache);
my ($cryptedPass);
unless ($self->{CLOBBER}) {
carp ("No write access for $self->{PATH}");
return;
}
if (!$id && !$passwd) {return 1;}
}
##
##
$hash{name} = "";
# or
$hash{name} = undef;
##
##
if ($passwd eq "") {
$cryptedPass = "";
} else {
$cryptedPass = crypt($passwd, $salt);
}
##
##
# Warning, possible race condition ahead
# I need to update this opening a locking!
if (!open(FH,"<$passwdFile")) {
carp("Cannot open $passwdFile: $!");
return;
}
flock(FH, 2);
if (!exists $self->{CURRENT}{Id}) {
while () {
if ( /^$Id\:/ ) {
push (@cache, "$Id\:$cryptedPass\n")
unless $cryptedPass eq "";
$return = 1;
} else {
push (@cache, $_);
}
}
}
close FH;
if ($return) {
if (!open(FH, ">$passwdFile")) {
carp("Cannot open $passwdFile: $!");
return;
}
flock(FH, 2);
while (@cache) {
print FH shift (@cache);
}
} else {
if (!open(FH, ">>$passwdFile")) {
carp("Cannot open $passwdFile: $!");
return;
}
flock(FH, 2);
print FH "$Id\:$cryptedPass\n" unless $cryptedPass eq "";
$foo = $hash{FOO};
}
##
##
sub FETCH {
my $self = shift;
my $Id = shift;
if (exists $self->{CURRENT}{$Id}) {
return $self->{CURRENT}{$Id};
} else {
return "$Id doesn't exist";
}
}
##
##
delete $hash{FOO};
##
##
sub DELETE {
my $self = shift;
my ($Id) = shift;
my ($passwdFile) = $self->{PATH};
my (@cache);
unless ($self->{CLOBBER}) {
carp ("No write access for $self->{PATH}");
return;
}
if (!exists $self->{CURRENT}{$Id}) {return 1;}
delete $self->{CURRENT}{$Id};
if (!open(FH,"<$passwdFile")) {
carp("Cannot open $passwdFile: $!");
return;
}
flock(FH, 2);
while () {
if ( /^$Id\:/ ) {
next;
} else {
push (@cache, $_);
}
}
close FH;
if (!open(FH,">$passwdFile")) {
carp("Cannot open $passwdFile: $!");
return;
}
flock(FH, 2);
while (@cache) {
print FH shift (@cache);
}
close FH;
return 1;
}
##
##
%hash = "";
%hash = %newHash;
%hash = {};
undef %hash;
##
##
sub CLEAR {
my $self = shift;
my ($passwdFile) = $self->{PATH};
unless ($self->{CLOBBER}) {
carp ("No write access for $self->{PATH}");
return;
}
if (!open(FH,">$passwdFile")) {
carp("Cannot open $passwdFile: $!");
return;
}
close FH;
$self->{CURRENT} = {};
}
##
##
sub FIRSTKEY {
my $self = shift;
my $a = keys %{$self->{CURRENT}};
each %{$self->{CURRENT}};
}
##
##
sub NEXTKEY {
my $self = shift;
return each %{$self->{CURRENT}};
}
##
##
sub DESTROY { unlink "/tmp/tie.txt";}
##
##
#!/usr/bin/perl
use Example;
tie(%hash, "Example", "example", "rw") || die "Can't tie : $!";
&ask;
sub ask {
print "(A)dd, (D)elete, or (G)et user:";
$ans = ;
if ($ans =~ /a/i) { &add; }
elsif ($ans =~ /d/i) { &delete;}
elsif ($ans =~ /g/i) {&get;}
else { print "Try again\n"; &ask;}
}
sub add {
print "User Name:";
$name = ;
print "\nPassword:";
$pass = ;
chop $name;
chop $pass;
$hash{$name} = $pass;
print "\nAdded\nAgain (Y/N)?";
$again = ;
if ($again !~ /y/i) { untie %hash; exit;}else{&ask;}
}
sub delete {
print "User Name:";
$name = ;
chop $name;
delete $hash{$name};
print "\nDeleted\nAgain (Y/N)?";
$again = ;
if ($again !~ /y/i) { untie %hash; exit;}else{&ask;}
}
sub get {
print "User Name:";
$name = ;
chop $name;
if (!exists $hash{$name}) {
print "$name isn't valid";
} else {
print "$name\'s encrypted password is " . $hash{$name};
}
print "\nAgain (Y/N)?";
$again = ;
if ($again !~ /y/i) { untie %hash; exit;}else{&ask;}
}
##
##
tied(%hash)->newPwdFile('/usr/local/apache/.passwds');
##
##
$obj = tie(%hash, 'Tie::Class', 'rw');
$obj->newPwdFile('/usr/local/apache/.passwds');
##
##
sub newPwdFile {
my $self = shift;
$self->{PATH} = @_ ? shift : die "No new file given";
unless (-e $self->{PATH}) {
if ($self->{CLOBBER}) {
unless (open(FH,">$self->{PATH}")) {
croak("Can't create $self->{PATH}: $!");
}
} else {
croak("$self->{PATH} does not exist");
}
}
close FH;
my ($line, $id, $pass, @lines);
foreach $line (@lines) {
($id, $pass) = split(/\:/,$line);
$self->{CURRENT}{$id} = $pass;
}
}
##
##
# Usage: tie($VARIABLE,'TrackScalar', FILE, "\$VARIABLE name/description");
# use TrackScalar;
# my $var;
# tie($var, 'TrackScalar', 'track.txt', "\$var (keeps count)");
package TrackScalar;
use strict;
use vars qw($VERSION @ISA);
# Get Revision number from RCS
($VERSION = substr(q$Revision: 0.2 $, 10)) =~ s/\s+$//;
sub Version {return $VERSION;}
use IO::File;
# Create tied scalar
sub TIESCALAR {
my $class = shift;
my $log = shift;
my $var = shift || "(undefined)";
my $fh = new IO::File ">> $log"
or die "Cannot open $log: $!\n";
# Notice that the variable being blessed in the object is
# an anonymous hash, and this is tied to the scalar
return bless {FH => $fh, VAL => 0, VAR => $var}, $class;
}
sub FETCH {
my $self = shift;
my ($package, $filename, $line) = caller();
my $fh = $self->{FH};
print $fh "package $package, ",
"$filename line $line FETCHED $self->{VAR}\n";
return $self->{VAL};
}
sub STORE {
my $self = shift;
my $var = shift;
my $fh = $self->{FH};
my ($package, $filename, $line) = caller();
print $fh "package $package, ",
"$filename line $line changed $self->{VAR} to $var\n";
$self->{VAL} = $var;
}
sub DESTROY {
undef %{$_[0]};
}
1;