package Disklabel;

=head1 NAME

Disklabel - manipulate Tru64 UNIX disklabels

=head1 SYNOPSIS

 use Disklabel;

 $dl = Disklabel->new('disk-name');

 # get values
 $val = $dl->prolog('sectors/unit');
 $val = $dl->size('a');
 $sectors = $dl->prolog('sectors/unit');

 # set values
 $dl->size(a => 1024 * 1024);
 $dl->fstype(h => 'cnx');
 $dl->offset(d => 1024 * 1024);
 $dl->prolog(label => 'clu_member1');

 # write to disk
 $dl->write;

 # with exception handling...
 eval {
  $dl = Disklabel->new('disk-name');
 };
 if ($@) { print "oops\n"; }

 # ... and the write ...
 eval {
  $dl->write;
 };
 if ($@) { print "oops\n"; }

=head1 DESCRIPTION

Disklabel provides a simple object-oriented interface to Tru64 UNIX
disklabels.  It is probably adaptable to other Unices, but I couldn't
say.  The "new" and "write" methods can cause an exception to be thrown,
("die"), so you may want to call them in an "eval {}" block.

The disk-name should be specified without path information and without
partition letter, i.e., C<dsk55>.  Allowable partition-letters are
C<[a-h]>.  Disklabel.pm has only been tested on Tru64 UNIX V5.1.  It
may work on V4.

The following methods are provided:

=over 4

=item new(E<lt>disk<gt>)

returns an disklabel object with the disklabel information for the
specified disk, or undef if the disk was not labelled.  Can also
return exceptions if something unexpected happens.

=item size(E<lt>partition-letterE<gt> [, E<lt>new-sizeE<gt>])

retrieves or sets size associated with the partition-letter, depending
on whether new-size is provided.

=item offset(E<lt>partition-letterE<gt> [, E<lt>new-sizeE<gt>])

retrieves or sets offset (see C<size()>);

=item fstype(E<lt>partition-letterE<gt> [, E<lt>new-sizeE<gt>])

retrieves or sets fstype (see C<size()>);

=item prolog(E<lt>keyE<gt> [, E<lt>new-valueE<gt>])

retrieves or sets a prolog value, i.e. the "key: value" pairs
that appear before the partition information.

=item write(E<lt>diskE<gt>)

writes new partition-table to disk specified.

=back

=head1 VERSION

This is version 0.1 (run away screaming).

=head1 AUTHOR

Robert Urban <urban@UNIX-Beratung.de>

=cut

BEGIN {
	$PERFORM_CLEANUP = 0;
	$DEBUG			= 1;
	$VERBOSE		= 1;
	$DISKLABEL		= '/usr/sbin/disklabel';
}

use FileHandle;

#=================================================================
# beginning of public interface
#=================================================================

sub new
{
	my $proto = shift;
	my $class = ref($proto) || $proto;

	my $self = {};
	bless($self, $class);
	if (@_) {
		$self->{disk} = shift;
		my $ret = $self->_read();
		defined($ret) || return undef;
	} else {
		die "must supply a disk-name";
	}

	$self;
}

sub fstype
{
	my $self = shift;
	my $part = shift;

	@_ ? $self->{ref}->{part}->{$part}->{fstype} = shift
		: $self->{ref}->{part}->{$part}->{fstype};
}

sub offset
{
	my $self = shift;
	my $part = shift;

	@_ ? $self->{ref}->{part}->{$part}->{offset} = shift
		: $self->{ref}->{part}->{$part}->{offset};
}

sub size
{
	my $self = shift;
	my $part = shift;

	@_ ? $self->{ref}->{part}->{$part}->{size} = shift
		: $self->{ref}->{part}->{$part}->{size};
}

sub prolog
{
	my $self = shift;
	my $field = shift;

	@_ ? $self->{ref}->{prolog}->{$field} = shift
		: $self->{ref}->{prolog}->{$field};
}

sub write
{
	my $self = shift;
	my $devname = shift;

	if (!$devname) {
		die "devname not specified";
	}

	#my($devname, $dl_ref) = @_;
	$devname =~ s/[a-h]$//;

	#----------------------------------------
	# write disklabel to file to be used to restore label
	#----------------------------------------
	my $tmpfile = "/tmp/label-$devname";
	$self->_print($tmpfile);

	#----------------------------------------
	# restore edited label
	#----------------------------------------
	my $cmd ="$DISKLABEL -r -R -t advfs $devname $tmpfile";
	$VERBOSE && print "restoring disk label from [$tmpfile]\n";
	executeCommand($cmd) || die "restore-disklabel to [$devname] failed";

	#----------------------------------------
	# cleanup
	#----------------------------------------
	$PERFORM_CLEANUP && myUnlink($tmpfile);
}

#=================================================================
# beginning of private interface
#=================================================================

sub _read
{
	#my $disk = shift;
	my $self = shift;

	my $disk = $self->{disk};

	my $debug = 0;

	if ($debug) {print "getDisklabel: disk=[$disk]\n";}
	$disk =~ s/[a-h]$//;

	my ($part, $size, $offset, $fstype, $fsize, $bsize);

	my $prolog;

	my $ref;
	my $fh = FileHandle->new;
	open($fh, "$DISKLABEL -r $disk 2>&1|") || die "popen disklabel";
	my $in_prolog = 1;
	my $line = 0;
	while(<$fh>) {
		chomp;
		if ($debug) {print "LABEL> $_\n";}
		if (/No such device or address/) {
			die "non-existent disk [$disk]";
		}
		if (/permission denied/i) {
			die "permission denied";
		}
		if (/^Disk is unlabeled/) {
			close($fh);
			return undef;
		}
		#if (/^\s*#/) {$prolog .= $_; next;}
		if (!$in_prolog) {
			if (/^\s*#/) {
				if ($debug) {print " -COM2-\n";}
				$ref->{com2} = $_;
				next;
			}
			if (m{^\s+
				([a-h])				# partition
					:\s+
				(\d+)				# size
					\s+
				(\d+)				# offset
					\s+
				(\S+)				# fstype
					\s+
					(
						(\d+)		# fsize
							\s+
						(\d+)		# bsize
							\s+
					)?
				\#\s+}x)			# the rest
			{
				if ($debug) {print " -matched p-line-\n";}
				($part, $size, $offset, $fstype, $fsize, $bsize) =
					($1, $2, $3, $4, $6, $7);
				#print " $part: $size $offset $fstype\n";
				$ref->{part}->{$part} = {
					size	=> $size,
					offset	=> $offset,
					fstype	=> $fstype,
					fsize	=> $fsize,
					bsize	=> $bsize,
				};
			}
		} else {
			$prolog .= "$_\n";
			if (/^(\d+)\s+partitions:/) {
				if ($debug) {print " -setting in_prolog=0-\n";}
				$ref->{num_parts} = $1;
				$in_prolog = 0;
				next;
			}
			if (m!#\s+/dev\S+:$!) {
				if ($debug) {print " -COM1-\n";}
				$ref->{com1} = $_;
			} elsif (m!^([^:]+):(\s+(\S.*))?\s*$!) {
				#$key = $1;
				#$val = $3;
				$ref->{prolog}->{$1} = $3;
				if ($debug) {print " -prolog item: $1 = [$3]\n";}
				push(@{$ref->{prolog_order}}, $1);
			}
		}
		$line++;
	}
	close($fh);

	($line < 5) && return undef;

	$ref->{old_prolog} = $prolog;
	$self->{ref} = $ref;
}

sub _print
{
	my ($self, $file) = @_;

	my $dl_ref = $self->{ref};

	my $fh = FileHandle->new;
	if ($file) {
		open($fh, ">$file") || die "can't write to $file";
	} else {
		open($fh, ">&STDOUT") || die "can't dup stdout";
	}

	print $fh $dl_ref->{com1}, "\n";
	foreach my $key (@{$dl_ref->{prolog_order}}) {
		print $fh $key.': '.$dl_ref->{prolog}->{$key}."\n";
	}
	print $fh "\n";
	print $fh $dl_ref->{num_parts}, " partitions:\n";
	print $fh $dl_ref->{com2}, "\n";
	foreach my $part ('a' .. 'h') {
		if (!exists($dl_ref->{part}->{$part})) { next; }
		printf$fh "%3s: %10d %10d %9s %8d %5d\n",
			$part,
			$dl_ref->{part}->{$part}->{size},
			$dl_ref->{part}->{$part}->{offset},
			$dl_ref->{part}->{$part}->{fstype},
			$dl_ref->{part}->{$part}->{fsize},
			$dl_ref->{part}->{$part}->{bsize};
	}
	close($fh);
}

sub executeCommand
{
	my $cmd = shift;

	$VERBOSE && print "    CMD: $cmd\n";
	$DEBUG && return 1; # success

	return !system("$cmd 2>&1 > /dev/null");
}

sub dump
{
	my $self = shift;

	my $dl_ref = $self->{ref};

	print "-------- PROLOG --------\n";
	foreach my $key (@{$dl_ref->{prolog_order}}) {
		print $key.': '.$dl_ref->{prolog}->{$key}."\n";
	}
	#$dl_ref->{prolog},
	print "------------------------\n";
	printf(" [%s]:  %8s  %8s  %-8s\n", 'P', 'size', 'offset', 'fstype');
	foreach my $part ('a' .. 'h') {
		printf(" [%s]:  %8d  %8d  %-8s\n", $part,
			$dl_ref->{part}->{$part}->{size},
			$dl_ref->{part}->{$part}->{offset},
			$dl_ref->{part}->{$part}->{fstype});
	}
}

1;