#!/usr/local/bin/perl

use Getopt::Std;

getopts('m:f:l:');

if (! defined $opt_m || ! defined $opt_f) {
    &usage();
}

$modfile .= "$opt_m" . ".pm";
print "Module file : $modfile\n";
open(OUTPUT,"> $modfile") || die "Could not open output : $!\n";

eval {
require "$opt_f";
};

if ($@) {
    print STDERR "Reading of definitions file ($opt_f) failed : $@\n";
    exit(1);
}

if (! defined %hash || ! defined @fields_in_order) {
    print STDERR "The definitions file does not contain both of the following :\n\n";
    print STDERR "\%hash\t-\tDefines the field names and binary types\n";
    print STDERR "\texample : \%hash = (first_name => \"a50\");\n\n";
    print STDERR "\@fields_in_order\t-\tDefined the field names in the exact order they are packed.\n";
    print STDERR "\texample : \@fields_in_order = qw(first_name last_name)\n";
    exit(1);
}


$names = join(' ', @fields_in_order);
foreach $bar (@fields_in_order) {
    $pack_string .= "$hash{$bar}";
}


if (defined $opt_l) {
    ##-- user defined
    print "Using user defined size ...$opt_l\n";
} else {
    print "Generating record byte size ($pack_string) ...";
    eval {
    require sizeof;
    };
    if ($@) {
        #- usage
        print "FAILED : Specify -l\n";
        &usage();
    } else {
        #- use sizeof
        $opt_l = &sizeof_pack_string($pack_string);
        print "$opt_l\n";
    }
}


##- heading
print OUTPUT "#!/usr/local/bin/perl\n";
print OUTPUT "\n";
print OUTPUT "package $opt_m;\n";
print OUTPUT "\n";
print OUTPUT "\@EXPORT = qw($names);\n";
print OUTPUT "\$BIN_LENGTH = $opt_l;\n\n";

print "Building new method...";
print OUTPUT "sub new {\n";
print OUTPUT "    \$r_rec = {\n";
foreach $a (@fields_in_order) {
    print OUTPUT "        $a => undef,\n";
}
print OUTPUT "    };\n\n";
print OUTPUT "    bless \$r_rec;\n";
print OUTPUT "    return \$r_rec;\n";
print OUTPUT "}\n\n\n";
print "ok\n";

##-- read method
print "Building read method ...";
print OUTPUT "sub read {\n";
print OUTPUT "    my (\$object,\$fh) = \@_;\n";
print OUTPUT "    if (! defined \$object || ! defined \$fh) {\n";
print OUTPUT "        return undef;\n    }\n\n";
print OUTPUT "    my \$bytes = read(\$fh,\$record,\$BIN_LENGTH);\n";
print OUTPUT "    if (\$bytes != \$BIN_LENGTH) {\n";
print OUTPUT "        return undef;\n    }\n\n";
print OUTPUT "    my (\n";
$cnt = -1;
foreach $fnm (@fields_in_order) {
    print OUTPUT "    \$$fnm,\n";
}
print OUTPUT "    ) = unpack(\"$pack_string\",\$record);\n";
print OUTPUT "\n";
foreach $foo (@fields_in_order) {
    print OUTPUT "    \$object->{$foo} = \$$foo;\n";
}
print OUTPUT "return 1;\n";
print OUTPUT "}\n\n\n";
print "ok\n";

##-- dump method
print "Building dump method ...";
print OUTPUT "sub dump {\n";
print OUTPUT "    my (\$object) = shift;\n";
print OUTPUT "    my \$output = pack(\"$pack_string\",\n";
foreach $de (@fields_in_order) {
    print OUTPUT "        \$object->{$de},\n";
}
print OUTPUT "    );\n";
print OUTPUT "\n";
print OUTPUT "    return \$output\n";
print OUTPUT "\n";
print OUTPUT "}\n";
print OUTPUT "\n";
print "ok\n";

##--main_loop method
print "Building main_loop method ...";
print OUTPUT "sub main_loop {\n";
print OUTPUT "    my (\$obj,\$fh,\$sub_ref) = \@_;\n";
print OUTPUT "    while ( \$obj->read(\$fh) ) {\n";
print OUTPUT "        \&{\$sub_ref}(\$obj);\n";
print OUTPUT "    }\n";
print OUTPUT "}\n";
print OUTPUT "\n";
print "ok\n";

##-- accessor methods
print "Building and writing accessor methods...started\n";
foreach $varname (@fields_in_order) {
    print "    Building accessor method for $varname ...";
    print OUTPUT "##- Usage : \$val = \$object->$varname()\n";
    print OUTPUT "##- Usage : \$val = \$object->$varname(value)\n";
    print OUTPUT "sub $varname {\n";
    print OUTPUT "    \$obj = shift;\n";
    print OUTPUT "    my \$in = shift;\n";
    print OUTPUT "    if (defined \$in) {\n";
    print OUTPUT "        \$obj->{$varname} = \$in;\n";
    print OUTPUT "    }\n";
    print OUTPUT "    return \$obj->{$varname}\n";
    print OUTPUT "}\n\n";
    print "ok\n";
}
print "Building and writting accessor methods...ended\n";

##-- trailing
print OUTPUT "\n\n1;\n";

print OUTPUT "__END__\n";

##-- pod document stub
print "Writing POD stub...started\n";
print "    Writing POD stub for NAME and SYNOPSIS...";
print OUTPUT "=head1 NAME\n\n";
print OUTPUT "$opt_m - [[What am i for?]]\n\n";
print OUTPUT "=head1 SYNOPSIS\n";
print OUTPUT "    use $opt_m\n";
print OUTPUT "    \$object = $opt_m" . "::new();\n\n";
print OUTPUT "    while ( \$object->read(\\*FH) ) {\n";
print OUTPUT "        #-- process data using \$object\n";
print OUTPUT "        #-- Example :\n";
print OUTPUT "        print STDOUT \$object->$fields_in_order[0]\n";
print OUTPUT "    }\n";
print OUTPUT "\n";
print OUTPUT " -- or --\n";
print OUTPUT "    use $opt_m\n\n";
print OUTPUT "    \$object = $opt_m" . "::new();\n\n";
print OUTPUT "    \$object->main_loop(\\*FH,\\\&process);\n\n";
print OUTPUT "    sub process {\n    my \$object = shift;\n";
print OUTPUT "        print STDOUT \$object->$fields_in_order[0]\n";
print OUTPUT "    }\n";
print OUTPUT "\n";
print OUTPUT " -- or --\n";
print OUTPUT "\n";
print OUTPUT "    use $opt_m\n\n";
print OUTPUT "    \$object = $opt_m" . "::new();\n\n";
print OUTPUT "    \$object->$fields_in_order[0](\"value_to_use\");\n";
print OUTPUT "    print OUTPUT \$object->dump();\n";
print OUTPUT "\n";
print OUTPUT "=head1 DESCRIPTION\n";
print OUTPUT "\n";
print OUTPUT "[[Description here]]\n";
print OUTPUT "\n";
print OUTPUT "\n"; 
print "ok\n";

print "    Writing POD stub for new, dump, main_loop and read ...";
  ##pod new, dump, main_loop, read
print OUTPUT "=head1 CONSTRUCTOR\n"; 
print OUTPUT "\n"; 
print OUTPUT "=over 4\n"; 
print OUTPUT "\n"; 
print OUTPUT "=item new()\n\n"; 
print OUTPUT "\n"; 
print OUTPUT "Used to create a new object. The C<new> method does not receive any arguments. On success an object of the calss $opt_m is returned. On failure, it returns undef.\n"; 
print OUTPUT "\n"; 
print OUTPUT "=item read(FH)\n\n"; 
print OUTPUT "\n"; 
print OUTPUT "Used to read from an input file. C<FH> represents a reference to the filehadle from which to read. This can be passed either as \$fh or \\*FH. This method internally uses perl's built-in C<read> function. The length read is storred within the module as the variable \$BIN_LENGTH. On success this method returns 1, but on failure undef is returned.\n"; 
print OUTPUT "\n"; 
print OUTPUT "=item dump()\n\n"; 
print OUTPUT "\n"; 
print OUTPUT "Used to pack the data held in the object into is binary equivelant. This method is normally used with the perl built-in C<print> or C<write> functions to generate a file in the correct format. This method takes no arguments. On success the pack data is returned, undef is returned on error.\n"; 
print OUTPUT "\n"; 
print OUTPUT "=item main_loop(FH,PROC)\n\n"; 
print OUTPUT "\n"; 
print OUTPUT "This is a short-cut method for data file processing. C<FH> represents a reference to the filehadle from which to read. This can be passed either as \$fh or \\*FH. PROC represents a reference to a subroutine which will receive the $opm_m object as it's first argument. This is normally pased usgine the \\\&name syntax.This method internally uses perl's built-in C<read> function. The length read is storred within the module as the variable \$BIN_LENGTH.\n"; 
print OUTPUT "\n"; 
print "ok\n";

  
  ##pod accessor methods
print "    Writing POD stub for accessor methods...started\n";
print OUTPUT "=head1 ACESSOR METHODS\n\n";
print OUTPUT "=over 4\n\n";
foreach $acc_meth (@fields_in_order) {
    print "        POD stub for $acc_meth ...";
    print OUTPUT "=item $acc_meth([ARG])\n";
    print OUTPUT "\n";
    print OUTPUT "This method is used to both set and get the value for $acc_meth in the object on which it is called. if C<ARG> is specified, the  the value of $acc_meth on the current object is set to C<ARG>. if C<ARG> is not specified, then this method returns the value of $acc_meth for the current object. On success, this method returns the value of $acc_meth for the current object regardless of if it is used to set or get the value. On failure, undef is returned.\n";
    print OUTPUT "\n";
    print OUTPUT "\n";
    print "ok\n";
}
print "    Writing POD stub for accessor methods...ended\n";
  ##pod trailer
    
print "Writing POD stub...ended\n";


sub usage {
    print STDERR "Usage : $0 -m <modulename> -f <def_file>\n";
    print STDERR "\n";
    print STDERR "Required :\n";
    print STDERR "    -m\tthe name of the module, no :: allowed in this version\n";
    print STDERR "    -f\tdefinitions file.\n";
    print STDERR "      The definitions file must contain both of the following :\n\n";
    print STDERR "      \%hash\t-\tDefines the field names and binary types\n";
    print STDERR "      example : \%hash = (first_name => \"a50\");\n\n";
    print STDERR "      \@fields_in_order\t-\tDefined the field names in the exact order they are packed.\n";
    print STDERR "      example : \@fields_in_order = qw(first_name last_name)\n";
    print STDERR "\nOptional :\n";
    print STDERR "    -l\tbinary record length\n";
    exit(-1);
}
exit(0);
__END__
=head1 NAME

binary_mod_maker.pl - given a definitions file, the program generates a module for the reading, writing, and processing of binary data.

=head1 DESCRIPTION

This script generates a .pm file for use as a stand alone module.

=head1 README

Usage :
Usage : $0 -m <modulename> -f <def_file>\n";

Required :\n";
    -m    the name of the module, no :: allowed in this version
    -f    definitions file.  (see description below)

Optional :
    -l    binary record length


The definitions file needs to contain both of the following :
%hash    -    Defines the field names and binary types
    example : %hash = (first_name => "a50",
                       last_name  => "a20",
                       age        =>  "s");
@fields_in_order    -    Defined the field names in the exact order they are packed.
    example : @fields_in_order = qw(first_name last_name age)

=head1 PREREQUISITES

This script requires the C<Getopt::Std> module. if -l is not specified, and attempt is made to include the sizeof module (to be released soon).

=head1 COREQUISITES

Perl 5, no modules

=pod OSNAMES

All

=pod SCRIPT CATEGORIES

UNIX/System_administration

=cut