# ScriptClient.pm
#
# Talk to the NASD scriptable client
#
# Author: Nat Lanza
#
# Copyright (c) of Carnegie Mellon University, 1999.
#
# Permission to reproduce, use, and prepare derivative works of
# this software for internal use is granted provided the copyright
# and "No Warranty" statements are included with all reproductions
# and derivative works. This software may also be redistributed
# without charge provided that the copyright and "No Warranty"
# statements are included in all redistributions.
#
# NO WARRANTY. THIS SOFTWARE IS FURNISHED ON AN "AS IS" BASIS.
# CARNEGIE MELLON UNIVERSITY MAKES NO WARRANTIES OF ANY KIND, EITHER
# EXPRESSED OR IMPLIED AS TO THE MATTER INCLUDING, BUT NOT LIMITED
# TO: WARRANTY OF FITNESS FOR PURPOSE OR MERCHANTABILITY, EXCLUSIVITY
# OF RESULTS OR RESULTS OBTAINED FROM USE OF THIS SOFTWARE. CARNEGIE
# MELLON UNIVERSITY DOES NOT MAKE ANY WARRANTY OF ANY KIND WITH RESPECT
# TO FREEDOM FROM PATENT, TRADEMARK, OR COPYRIGHT INFRINGEMENT.
#

package NASD::ScriptClient;

use strict;
use IO::File;
use POSIX qw(:sys_wait_h);
use Fcntl;

use Exporter;
use vars qw(@ISA @EXPORT *CHILDIN *CHILDOUT *CHILDDATAIN *CHILDDATAOUT);
@ISA = 'Exporter';
@EXPORT = qw(&get_lines       &send_data      &get_data
	     &nasd_bind       &nasd_unbind    &nasd_create
	     &nasd_remove     &nasd_getattr   &nasd_setattr
	     &nasd_initialize &nasd_listpart  &nasd_partition
	     &nasd_driveinfo  &nasd_partinfo  &nasd_eject
	     &nasd_flush      &nasd_sync      &nasd_noop
	     &nasd_null       &nasd_read      &nasd_tread
	     &nasd_write      &nasd_rangeread &nasd_rangetread
	     &nasd_rangewrite
	    );

my $version = '1.00';
my $client_prog = "utils/script_client/nasd_script_client";

sub abort { &shutdown_client; die @_; }

sub init_client {
  my $cpath;
  if (defined $ENV{NASD_ROOT}) { $cpath = $ENV{NASD_ROOT}."/".$client_prog; }
  else                         { $cpath = "../../" . $client_prog; }

  pipe READ,        CHILDOUT;
  pipe CHILDIN,     WRITE;
  pipe CHILDDATAIN, DATAWRITE;
  pipe DATAREAD,    CHILDDATAOUT;

  autoflush READ 1;
  autoflush WRITE 1;
  autoflush DATAWRITE 1;
  autoflush DATAREAD 1;

  my $pid;
  if ($pid = fork) { # parent
    $SIG{CHLD} = sub { 1 while (waitpid(-1, WNOHANG)) > 0 };
  } else { # child 
    open STDIN, "<&=CHILDIN" or die "Couldn't dup stdin in child: $!\n";
    open STDOUT, ">&=CHILDOUT" or die "Couldn't dup stdout in child: $!\n";

    autoflush STDIN 1;
    autoflush STDOUT 1;
    autoflush CHILDDATAIN 1;
    autoflush CHILDDATAOUT 1;

    fcntl(CHILDDATAIN, Fcntl::F_SETFD(), 0);
    fcntl(CHILDDATAOUT, Fcntl::F_SETFD(), 0);

    exec($cpath, fileno(CHILDDATAIN), fileno(CHILDDATAOUT));

    die "Couldn't exec the script client: $!";
  }

  ## pull off the version line and verify
  my ($kind, $output) = &get_response;
  
  if ($kind) {
    if ($output =~ /^VERSION\s+([0-9.]+)/) {
      abort "Bad version $1!\n" unless ($1 eq $version); }
    else { abort "Couldn't understand version line!\n"; }          }
  else       {
    if (defined $kind) { abort "Client gave us an error: $1\n"; }
    else               { abort "Got weird line '$output'\n";    }  }
}


sub shutdown_client {
  close WRITE;
  close READ;
}


sub send_command {
  my @args = @_;
  my $cmdline = (join ' ', @args);

  print WRITE $cmdline, "\n";
}


sub get_response {
  my $line = <READ>;
  my ($num, $type);

  chomp($line);

  if ($line =~ /^([.!\#])\s+([0-9]+)$/) { $type = $1; $num = $2; }
  else { abort "Couldn't understand start line '$line'!\n"; }

  my $data = ""; my $i;
  for ($i = 0; $i < $num; $i++) { $data .= <READ>; }

  chomp($data);

  if    ($type eq '.') { return (1, $data);     }
  elsif ($type eq '!') { return (0, $data);     }
  else                 { return (undef, $data); }
}


sub send_data {
  my ($data) = @_;

  return syswrite DATAWRITE, $data;
}


sub get_data {
  my ($length) = @_;
  my $data = "";

  my $got = sysread DATAREAD, $data, $length;

  print STDERR "Short read! expected $length bytes, got $got.\n"
    if ($got != $length);
  
  return $data;
}


sub get_lines {
  my ($num) = @_;

  my @lines = ();
  $#lines = $num-1;

  my $i;
  for ($i = 0; $i < $num; $i++) { $lines[$i] = <READ>; chomp($lines[$i]); }

  return @lines;
}


######################################################################
##
## actual NASD RPC calls

sub sc_unimp { return (0, "Function '$_[0]' not yet implemented", undef); }

sub sc_generic {
  my ($command, $nargs, $usage, @args) = @_;

  return(0, "usage: $command $usage", undef)
    if (defined $nargs and @args != $nargs);

  send_command(uc $command, @args);

  my ($rc, $response) = get_response();

  return ($rc, $response, undef);
}


sub nasd_bind {
  my ($rc, $response) = sc_generic("bind", 1, "<drivename>", @_);
  return ($rc, $response, undef);
}


sub nasd_unbind {
  my ($rc, $response) = sc_generic("unbind", 0, "", @_);
  return ($rc, $response, undef);
}


sub nasd_create {
  my ($rc, $response) =
    sc_generic("create", 3, "<partnum> <protection> <password>", @_);
  return ($rc, $response, undef) unless $rc;

  my ($ok, $objno) = split /\n/, $response;
  return ($rc, "$ok\n", $objno);
}


sub nasd_remove {
  my ($rc, $response) =
    sc_generic("remove", 4,
	       "<identifier> <partnum> <protection> <password>", @_);
  return ($rc, $response, undef);
}


sub nasd_getattr {
  my ($rc, $response) =
    sc_generic("getattr", 4,
	       "<identifier> <partnum> <protection> <password>", @_);
  return ($rc, $response, undef) unless $rc;

  my %attr; my $ok;
  
  ($ok,
   $attr{block_preallocation},
   $attr{blocks_used},
   $attr{block_size},
   $attr{av},
   $attr{object_len},
   $attr{attr_modify_time},
   $attr{object_modify_time},
   $attr{object_create_time},
   $attr{fs_attr_modify_time},
   $attr{fs_object_modify_time},
   $attr{layout_hint}) = split /\n/, $response;

  if ($ok =~ /^OK\s+DATA\s+([0-9]+)/) {
    my $size = $1;
    $attr{fs_specific} = get_data($size);
  }

  return ($rc, "OK\n", \%attr);
}


sub nasd_setattr {
  sc_unimp();
}


sub nasd_initialize {
  my ($rc, $response) = sc_generic("initialize", 1, "<password>", @_);
  return ($rc, $response, undef);
}


sub nasd_listpart {
  my ($rc, $response) =
    sc_generic("listpart", 3, "<partnum> <protection> <password>", @_);
  return ($rc, $response, undef) unless $rc;
  
  my ($ok, @objlist) = split /\n/, $response;
  return ($rc, "$ok\n", \@objlist);
}


sub nasd_partition {
  my ($rc, $response) =
    sc_generic("partition", 4,
	       "<partnum> <blocks> <protection> <password>", @_);
  return ($rc, $response, undef);
}


sub nasd_driveinfo {
  my ($rc, $response) =
    sc_generic("driveinfo", 2, "<protection> <password>", @_);
  
  return ($rc, $response, undef) unless $rc;

  my %dhash; my $ok;

  ($ok, $dhash{max_parts}, $dhash{blocksize}, $dhash{num_parts},
   $dhash{num_blocks}, $dhash{blocks_allocated}) = split /\n/, $response;

  return ($rc, "$ok\n", \%dhash);
}


sub nasd_partinfo {
  my ($rc, $response) =
    sc_generic("partinfo", 3, "<partnum> <protection> <password>", @_);

  return ($rc, $response, undef) unless $rc;

  my %phash; my $ok;

  ($ok, $phash{first_obj}, $phash{num_obj}, $phash{part_size},
   $phash{blocks_used}, $phash{blocks_allocated}, $phash{max_objs},
   $phash{blocksize}, $phash{min_protection}) = split /\n/, $response;

  return ($rc, "$ok\n", \%phash);
}


sub nasd_eject {
  my ($rc, $response) =
    sc_generic("eject", 4,
	       "<identifier> <partition> <protection> <password>", @_);
  return ($rc, $response, undef);
}


sub nasd_flush {
  my ($rc, $response) =
    sc_generic("flush", 4,
	       "<identifier> <partition> <protection> <password>", @_);
  return ($rc, $response, undef);
}


sub nasd_sync {
  my ($rc, $response) = sc_generic("sync", 0, "", @_);
  return ($rc, $response, undef);
}


sub nasd_noop {
  my ($rc, $response) = sc_generic("noop", 0, "", @_);
  return ($rc, $response, undef);
}


sub nasd_null {
  my ($rc, $response) = sc_generic("null", 0, "", @_);
  return ($rc, $response, undef);
}


sub nasd_read {
  my ($rc, $response) =
    sc_generic("read", 6,
	       "<partnum> <identifier> <offset> <len> <protection> <password>",
	       @_);
  # XXXXXX bad
  return ($rc, $response, undef);
}


sub nasd_tread {
  sc_unimp();
}


sub nasd_write {
  sc_unimp();
}


sub nasd_rangeread {
  sc_unimp();
}


sub nasd_rangetread {
  sc_unimp();
}


sub nasd_rangewrite {
  sc_unimp();
}


1;
