Software::Packager::Svr4 - The Software::Packager extension for System VR4 packages

 use Software::Packager;
 my $packager = new Software::Packager('svr4');

 $packager->add_item(%object_data);

 $packager->package();

 $packager->install_dir('/usr/local');
 my $base_dir = $packager->install_dir;

 $packager->compatible_version('/some/path/file');

 $packager->compatible_version($compver_stored_in_string);

 my $compatible_version = $packager->compatible_version();

 $packager->space('/some/path/file');

 $packager->space($space_data_stored_in_string);
 my $space = $packager->space();

 $packager->request_script('/some/path/file');

 $packager->request_script($request_script_stored_in_string);
 my $request_script = $packager->request_script();

package	Software::Packager::Svr4;

use strict;
use File::Copy;
use File::Path;
use File::Basename;
use IO::File;
use POSIX qw(uname);

use base qw( Software::Packager );
use Software::Packager::Object::Svr4;
our $VERSION;
$VERSION = substr(q$Revision: 1.2 $, 9);

sub new {
  my $class = shift;
  my $self = bless {}, $class;

  return $self;
}

sub add_item {
  my $self = shift;
  my %data = @_;
  my $object = Software::Packager::Object::Svr4->new(%data) || return;

  # check that the object has a unique destination
  return
    if exists $self->{OBJECTS}->{$object->destination};

  $self->{OBJECTS}->{$object->destination} = $object;
}

sub get_all_classes {
  my $self = shift;
  my %class;

  foreach($self->get_directory_objects, $self->get_file_objects,
	  $self->get_link_objects) {
    $class{$_->class}++;
  }
  return keys %class;
}

sub package {
  my $self = shift;
  my $dir = $self->output_dir;

  my $pkginfo = IO::File->new(">$dir/pkginfo")
    || die "Couldn't open pkginfo for output: $!\n";
  my %info = $self->info;
  print $pkginfo "$_=$info{$_}\n"
    for keys %info;

  my $pkgmap = IO::File->new(">$dir/pkgmap")
    || die "Couldn't open pkgmap for output: $!\n";

  mkdir "$dir/reloc", 0755;
  chdir "$dir/reloc";
  my $maxlength = 0;
  foreach($self->get_directory_objects, $self->get_file_objects,
	  $self->get_link_objects) {
warn $_->destination, ", ", $_->prototype, "\n";
    if($_->prototype eq 'f') {
      open(IN,  $_->source)
	|| die "Couldn't open ", $_->source, " for input: $!\n";
      open(OUT, ">./".$_->destination)
	|| die "Couldn't open ", $_->destination, " for output: $!\n";
      ($_->{length},$_->{crc}) = _sum_copy(\*IN, \*OUT);
      $maxlength = $_->{length} if $_->{length} > $maxlength;
      $_->{mtime} = [lstat($_->source)]->[10];
      close IN;
      close OUT;
      chmod $_->mode, $_->destination;
    } elsif($_->prototype eq 'd') {
      mkdir $_->destination, $_->mode;
    }

    $pkgmap->print(_pkgmap_line($_));
  }
  chdir "../..";

  print $pkgmap ":1 ". int($maxlength / 512). "\n";
  $pkgmap->close;
}

# an implementation of the 'cksum' utility in perl.  written for the perl
# power tools (ppt) project by theo van dinter (felicity@kluge.net).
#
# id: cksum,v 1.3 1999/03/04 17:14:08 felicity exp
# modified to copy the file while it sums
sub _sum_copy {
  my($fh) = shift;
  my($ofh) = shift;
  my($crc) = my($len) = 0;
  my($buf,$num,$i);
  my($buflen) = 4096; # buffer is "4k", you can up it if you want...

  while($num = sysread $fh, $buf, $buflen) {
    $len += $num;
    $crc += unpack("%32C*", $buf);
    syswrite $ofh, $buf;
  }

  # crc = s (total of bytes)
  $crc = ($crc & 0xffff) + ($crc & 0xffffffff) / 0x10000; # r
  $crc = ($crc & 0xffff) + ($crc / 0x10000); # cksum

  return $len,int($crc),($len+511)/512; # round # of blocks up ...
}

sub _pkgmap_line {
  my $finfo = shift;

  (defined $finfo->part ? $finfo->part : "1") . " " .
    $finfo->prototype . " " . 
    (defined $finfo->class ? $finfo->class : "none") . " " .

      $finfo->destination . " " . sprintf("%04o",$finfo->mode)
	. " " . $finfo->user . " " . $finfo->group . " " .
	  ($finfo->prototype eq 'f' ? $finfo->{length} .
	   " " . $finfo->{crc} . " "
	   . $finfo->{mtime} . "\n" : "\n")
}

sub info {
  my $self = shift;
  my %info;

  $info{PKG} = $self->package_name || warn "No package name.\n";
  $info{NAME} = $self->program_name || warn "No program name.\n";
  $info{VERSION} = $self->version || warn "No version number.\n";
  $info{ARCH} = $self->architecture
    if $self->architecture;
  $info{PSTAMP} = $self->creator
    || POSIX::strftime([POSIX::uname]->[1].'%Y%m%d%H%M%S', localtime);
  $info{CLASSES} = join(", ",$self->get_all_classes);
  $info{CATEGORY} = $self->category
    if $self->category;
  $info{VENDOR} = $self->vendor
    if $self->vendor;
  $info{BASEDIR} = $self->install_dir;
  $info{EMAIL} = $self->email_contact
    if $self->email_contact;

  return %info;
}

sub package_name {
  my $self = shift;
  my $name = shift;

  return $self->{PACKAGE_NAME}
    unless $name;

  for ($name) {
    if (m{^(?![a-zA-Z])}) {
      warn qq{Warning: Package name "$name" does not start with a letter.
Removing non letters from the start.\n};
      s{^(.*?)(?=[a-zA-Z])(.*)}{$2};
    }
    if (/[^a-zA-Z0-9+-]!/) {
      warn qq{Warning: Package name "$name" contains
charaters other that alphanumeric, + and -. Removing them.\n};
      tr/a-zA-Z0-9+-//cd;
    }
    if (length > 256) {
      warn qq{Warning: Package name "$name" is longer than 9 charaters.
Truncating to 9 charaters.\n};
      $_ = substr($_, 0, 256);
    }
    if (/^install$|^new$|^all$/) {
      warn "Warning: The package name $name is reserved.\n";
    }
    $self->{PACKAGE_NAME} = $_;
  }

}

sub program_name {
  my $self = shift;
  my $name = shift;

  return ($self->{PROGRAM_NAME} || $self->package_name)
    unless $self->{PROGRAM_NAME};
  for($name) {
    if (length > 256) {
      warn qq{Warning: Package name "$_" is longer than 256 charaters.
Truncating to 256 charaters.\n};
      $_ = substr($_, 0, 256);
    }
    $self->{PROGRAM_NAME} = $_;
  }

}

sub architecture {
  my $self = shift;
  my $name = shift;

  $self->{ARCHITECTURE} = $name
    if $name;
  $self->{ARCHITECTURE} ||= [uname]->[4];
}

sub version {
  my $self = shift;
  my $version = shift;

  if ($version) {
    if (substr($version, 0, 1) eq '(') {
      warn "Warning: The version starts with a left parenthesis.
Removing it.\n";
      $version = substr($version,1);
    }
    if (length $version > 256) {
      warn "Warning: The version is longer than 256 charaters.
Truncating it.\n";
      $version = substr($version,0,256);
    }
    $self->{PACKAGE_VERSION} = $version;
  }

  return $self->{PACKAGE_VERSION};
}

sub install_dir {
  my $self = shift;
  my $value = shift;

  return ($self->{BASEDIR} || '/')
    unless $value;
  for($value) {
    if (substr($_,0,1) ne '/') {
      warn qq{Warning: The installation directory does not start with a "/".
Prepending "/" to $value.};
      $_ = "/$value";
    }
    $self->{BASEDIR} = $_;
  }
}

sub compatible_version {
  my $self = shift;
  my $value = shift;

  $self->{COMPVER} = $value
    if $value;
  return $self->{COMPVER};
}

sub space {
  my $self = shift;
  my $value = shift;

  $self->{SPACE} = $value
    if $value;
  return $self->{SPACE};
}

sub request_script {
  my $self = shift;
  my $value = shift;

  $self->{REQUEST_SCRIPT} = $value
    if $value;
  return $self->{REQUEST_SCRIPT};
}

1;
__END__