Initial revision

9 files changed, 481 insertions, 0 deletions

diff --git a/fml/lib/IO/@template b/fml/lib/IO/@template
new file mode 100644
index 00000000..81d97312
--- /dev/null
+++ b/fml/lib/IO/@template
@@ -0,0 +1,4 @@
+# Descriptions: 
+#    Arguments: $self $args
+# Side Effects: 
+# Return Value: none
diff --git a/fml/lib/IO/Adapter/File.pm b/fml/lib/IO/Adapter/File.pm
new file mode 100644
index 00000000..e69de29b
--- /dev/null
+++ b/fml/lib/IO/Adapter/File.pm
diff --git a/fml/lib/IO/Adapter/LDAP.pm b/fml/lib/IO/Adapter/LDAP.pm
new file mode 100644
index 00000000..e69de29b
--- /dev/null
+++ b/fml/lib/IO/Adapter/LDAP.pm
diff --git a/fml/lib/IO/Adapter/NIS.pm b/fml/lib/IO/Adapter/NIS.pm
new file mode 100644
index 00000000..e69de29b
--- /dev/null
+++ b/fml/lib/IO/Adapter/NIS.pm
diff --git a/fml/lib/IO/Adapter/RDBMS.pm b/fml/lib/IO/Adapter/RDBMS.pm
new file mode 100644
index 00000000..e69de29b
--- /dev/null
+++ b/fml/lib/IO/Adapter/RDBMS.pm
diff --git a/fml/lib/IO/Adapter/UnixGroup.pm b/fml/lib/IO/Adapter/UnixGroup.pm
new file mode 100644
index 00000000..e69de29b
--- /dev/null
+++ b/fml/lib/IO/Adapter/UnixGroup.pm
diff --git a/fml/lib/IO/File/Atomic.pm b/fml/lib/IO/File/Atomic.pm
new file mode 100644
index 00000000..0efc717e
--- /dev/null
+++ b/fml/lib/IO/File/Atomic.pm
@@ -0,0 +1,167 @@
+#-*- perl -*-
+#
+#  Copyright (C) 2001 Ken'ichi Fukamachi
+#   All rights reserved. This program is free software; you can
+#   redistribute it and/or modify it under the same terms as Perl itself. 
+#
+# $Id$
+# $FML$
+#
+
+package IO::File::Atomic;
+use strict;
+use vars qw(@ISA @EXPORT @EXPORT_OK);
+use Carp;
+
+require Exporter;
+@ISA = qw(IO::File);
+
+
+sub BEGIN {}
+
+
+sub new
+{
+    my ($class) = shift;
+    my $self = $class->SUPER::new();
+    $self->open(@_) if @_;
+    $self;
+}
+
+
+sub open
+{
+    my ($self, $file, $mode) = @_;
+
+    # get an instance 
+    ref($self) or $self = $self->new;
+
+    # default mode is "w"
+    $mode ||= "w";
+
+    # temporary file
+    my $temp = $file.".new.".$$;
+    ${*$self}{ _orig } = $file;
+    ${*$self}{ _temp } = $temp;
+
+    # real open with $mode
+    $self->autoflush;
+    $self->SUPER::open($temp, "w") ? $self : undef;
+}
+
+
+sub rw_open
+{
+    my ($self, $file, $mode) = @_;
+
+    use FileHandle;
+    my $rh = new FileHandle $file;
+    my $wh = $self->open($file, $mode);
+
+    return ($rh, $wh);
+}
+
+
+sub close
+{
+    my ($self) = @_;
+    my $fh = $self;
+    my $orig = ${ *$fh }{ _orig };
+    my $temp = ${ *$fh }{ _temp };
+
+    if (rename($temp, $orig)) {
+       ${ *$fh }{ _error } = "fail to rename($temp, $orig)";
+    }
+    else {
+       undef;
+    }
+}
+
+
+sub error
+{
+    my ($self) = @_;
+    my $fh = $self;
+    ${ *$fh }{ _error };
+}
+
+
+sub rollback
+{
+    my ($self) = @_;
+    my $fh = $self;
+    my $temp = ${ *$fh }{ _temp };
+    if (-f $temp) { unlink $temp;}
+}
+
+
+sub DESTROY 
+{ 
+    my ($self) = @_;
+    $self->rollback;
+}
+
+
+=head1 NAME
+
+IO::Atomic.pm - atomic  operation
+
+
+=head1 SYNOPSIS
+
+    use IO::Atomic;
+    my $wh = new IO::Atomic->open($file);
+    print $wh "new/updated things ...";
+    $wh->close;
+
+So, in usual cases, you use in this way.
+
+    use FileHandle;
+    use IO::Atomic;
+
+    # get read handle for $file
+    my $rh = new FileHandle $file;
+
+    # get  handle to update $file
+    my $wh = new IO::Atomic->open($file);
+    while (<$rh>) {
+        print $wh "new/updated things ...";
+    } 
+    $wh->close;
+    $rh->close;
+
+You can use this method to open $file for both read and write.
+
+    use IO::Atomic;
+    my ($rh, $wh) = IO::Atomic->rw_open($file);
+    while (<$rh>) {
+        print $wh "new/updated things ...";    
+    }
+    $wh->close;
+    $rh->close;
+
+
+=head1 DESCRIPTION
+
+=head2 new
+
+=item Function()
+
+
+=head1 AUTHOR
+
+=head1 COPYRIGHT
+
+Copyright (C) 2001 __YOUR_NAME__
+
+All rights reserved. This program is free software; you can
+redistribute it and/or modify it under the same terms as Perl itself. 
+
+=head1 HISTORY
+
+IO::__MODULE_NAME__.pm appeared in fml5.
+
+=cut
+
+
+1;
diff --git a/fml/lib/IO/MapAdapter.pm b/fml/lib/IO/MapAdapter.pm
new file mode 100644
index 00000000..658f8623
--- /dev/null
+++ b/fml/lib/IO/MapAdapter.pm
@@ -0,0 +1,305 @@
+#-*- perl -*-
+#
+#  Copyright (C) 2001 Ken'ichi Fukamachi
+#   All rights reserved. This program is free software; you can
+#   redistribute it and/or modify it under the same terms as Perl itself. 
+#
+# $Id$
+# $FML$
+#
+
+package IO::MapAdapter;
+use strict;
+use Carp;
+
+
+BEGIN {}
+
+
+sub new
+{
+    my ($self, $args) = @_;
+    my ($type) = ref($self) || $self;
+    my ($me)   = {};
+
+    if ( ref($args) eq 'CODE' ) {
+	$me->{_type} = 'array_on_memory';
+	eval { &$args($me);};
+	_log($me, $@) if $@;
+    }
+    else {
+	if ($args =~ /file:(\S+)/ || $args =~ m@^(/\S+)@) {
+	    $me->{_file} = $1;
+	    $me->{_type} = 'file';
+	}
+	elsif ($args =~ /unix\.group:(\S+)/) {
+	    $me->{_name} = $1;
+	    $me->{_type} = 'unix.group';
+	}
+	elsif ($args =~ /(ldap|mysql|postgresql):(\S+)/) {
+	    $me->{_type}   = $1;
+	    $me->{_schema} = $2;
+
+	    # lowercase the '_type' syntax
+	    $me->{_type}   =~ tr/A-Z/a-z/;
+	}
+	else {
+	    my $s = "IO::MapAdapter::new: args='$args' is unknown.";
+	    print STDERR $s, "\n";
+	    _log($me, $s);
+	}
+    }
+
+    return bless $me, $type;
+}
+
+
+sub _log
+{
+    my ($self, $mesg) = @_;
+    $self->{ _error } = $mesg;
+}
+
+
+sub error
+{
+    my ($self) = @_;
+    return $self->{ _error };
+}
+
+
+sub dump_variables
+{
+    my ($self, $args) = @_;
+    my ($k, $v);
+    while (($k, $v) = each %$self) {
+	print STDERR "IO::Map.debug: $k => $v\n";
+    }
+}
+
+
+sub open
+{
+    my ($self, $flag) = @_;
+
+    # default flag is "r" == "read open"
+    $flag ||= 'r';
+
+    if ($self->{'_type'} eq 'file') {
+	my $file = $self->{_file};
+	eval q{ use FileHandle;};
+	my $fh = new FileHandle $file, $flag;
+	if (defined $fh) {
+	    $self->{_fh} = $fh;
+	    return $fh;
+	}
+	else {
+	    $self->_log("Error: cannot open $file $flag");
+	}
+    }
+    elsif ($self->{'_type'} eq 'unix.group') {
+	my @x = getgrnam( $self->{_name} );
+	my @members = split ' ', $x[3];
+	$self->{_members}     = \@members;
+	$self->{_num_members} = $#members;
+	$self->{_counter}     = 0;
+	return defined @members ? \@members : undef;
+    }
+    elsif ($self->{'_type'} eq 'array_on_memory') {
+	my $r_array = $self->{ _recipients_array_on_memory };
+	my @members = @$r_array;
+	$self->{_members}     = $r_array;
+	$self->{_num_members} = $#members;
+	$self->{_counter}     = 0;
+	return defined @members ? \@members : undef;
+    }
+    elsif ($self->{'_type'} eq 'ldap' ||
+	   $self->{'_type'} eq 'mysql' ||
+	   $self->{'_type'} eq 'postgresql'
+	   ) {
+	return undef;
+    }
+    else {
+	$self->_log("Error: type=$self->{_type} is unknown type.");
+    }
+}
+
+
+my $c = 0;
+my $ec = 0;
+sub line_count { my ($self) = @_; return "${ec}/${c}";}
+
+
+# aliases for convenience
+sub get_member    { my ($self) = @_; $self->_get_address;}
+sub get_active    { my ($self) = @_; $self->_get_address;}
+sub get_recipient { my ($self) = @_; $self->_get_address;}
+sub _get_address
+{
+    my ($self) = @_;
+
+    if ($self->{'_type'} eq 'file') {
+	my ($buf) = '';
+	my $fh = $self->{_fh};
+
+	if (defined $fh) {
+	  INPUT:
+	    while ($buf = <$fh>) {
+		$c++; # for benchmark (debug)
+		next INPUT if not defined $buf;
+		next INPUT if $buf =~ /^\s*$/o;
+		next INPUT if $buf =~ /^\#/o;
+		next INPUT if $buf =~ /\sm=/o;
+		next INPUT if $buf =~ /\sr=/o;
+		next INPUT if $buf =~ /\ss=/o;
+		last INPUT;
+	    }
+
+	    if (defined $buf) {
+		my @buf = split(/\s+/, $buf);
+		$buf    = $buf[0];
+		$buf    =~ s/[\r\n]*$//o;
+		$ec++;
+	    }
+	    return $buf;
+	}
+	return undef;
+    }
+    elsif ($self->{'_type'} eq 'unix.group') {
+	my $i  = $self->{_counter}++;
+	my $ra = $self->{_members};
+	defined $$ra[ $i ] ? $$ra[ $i ] : undef;
+    }
+    elsif ($self->{'_type'} eq 'array_on_memory') {
+	my $i  = $self->{_counter}++;
+	my $ra = $self->{_members};
+	defined $$ra[ $i ] ? $$ra[ $i ] : undef;
+    }
+    elsif ($self->{'_type'} eq 'ldap' ||
+	   $self->{'_type'} eq 'mysql' ||
+	   $self->{'_type'} eq 'postgresql'
+	   ) {
+	$self->_log("Error: not yet implemented");
+	return undef;
+    }
+    else {
+	$self->_log("Error: type=$self->{_type} is unknown type.");
+    }
+}
+
+
+# raw line reading
+sub getline
+{
+    my ($self) = @_;
+
+    if ($self->{'_type'} eq 'file') {
+	my $fh = $self->{_fh};
+	$fh->getline;
+    }
+    elsif ($self->{'_type'} eq 'unix.group') {
+	my $i  = $self->{_counter}++;
+	my $ra = $self->{_members};
+	defined $$ra[ $i ] ? $$ra[ $i ] : undef;
+    }
+    elsif ($self->{'_type'} eq 'ldap' ||
+	   $self->{'_type'} eq 'mysql' ||
+	   $self->{'_type'} eq 'postgresql'
+	   ) {
+	$self->_log("Error: not yet implemented");
+	return undef;
+    }
+    else {
+	$self->_log("Error: type=$self->{_type} is unknown type.");
+    }
+}
+
+
+sub getpos
+{
+    my ($self) = @_;
+
+    if ($self->{'_type'} eq 'file') {
+	my $fh = $self->{_fh};
+	tell($fh);
+    }
+    elsif ($self->{'_type'} eq 'unix.group') {
+	$self->{_counter};
+    }
+    elsif ($self->{'_type'} eq 'array_on_memory') {
+	$self->{_counter};
+    }
+    else {
+	$self->_log("Error: type=$self->{_type} is unknown type.");
+    }
+}
+
+
+sub setpos
+{
+    my ($self, $pos) = @_;
+
+    if ($self->{'_type'} eq 'file') {
+	my $fh = $self->{_fh};
+	seek($fh, $pos, 0);
+    }
+    elsif ($self->{'_type'} eq 'unix.group') {
+	$self->{_counter} = $pos;
+    }
+    elsif ($self->{'_type'} eq 'array_on_memory') {
+	$self->{_counter} = $pos;
+    }
+    else {
+	$self->_log("Error: type=$self->{_type} is unknown type.");
+    }
+}
+
+
+sub eof
+{
+    my ($self) = @_;
+
+    if ($self->{'_type'} eq 'file') {
+	my $fh = $self->{_fh};
+	$fh->eof;
+    }
+    elsif ($self->{'_type'} eq 'unix.group') {
+	$self->{_counter} > $self->{_num_members} ? 1 : 0;
+    }
+    elsif ($self->{'_type'} eq 'array_on_memory') {
+	$self->{_counter} > $self->{_num_members} ? 1 : 0;
+    }
+    else {
+	$self->_log("Error: type=$self->{_type} is unknown type.");
+    }
+}
+
+
+sub close
+{
+    my ($self) = @_;
+
+    if ($self->{'_type'} eq 'file') {
+	$self->{_fh}->close;
+    }
+    elsif ($self->{'_type'} eq 'unix.group') {
+	;
+    }
+    elsif ($self->{'_type'} eq 'array_on_memory') {
+	;
+    }
+    else {
+	$self->_log("Error: type=$self->{_type} is unknown type.");
+    }
+}
+
+
+sub DESTROY
+{
+    my ($self) = @_;
+    $self->close;
+    undef $self;
+}
+
+
+1;
diff --git a/fml/lib/IO/index.ja.html b/fml/lib/IO/index.ja.html
new file mode 100644
index 00000000..4705f6d2
--- /dev/null
+++ b/fml/lib/IO/index.ja.html
@@ -0,0 +1,5 @@
+<UL>
+	<LI>
+	<A HREF=MapAdapter.pm>MapAdapter.pm</A>
+
+</UL>