#! /usr/bin/perl

use strict ;
use warnings ;

my @mode = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx') ;

my $MODE = 0755 & ~umask ;
my $default = sprintf "default mode: %o (%s)", $MODE, mode ( $MODE ) ;

my $prog = substr($0,rindex($0,'/')+1) ;
my $Usage = <<USAGE ;
Usage: $prog file [-o] [mode]
option o : write option handling only
option v : no -v option
option q : no -q option
option d : no -d option
option f : no -f option
argument mode : initial file mode [default $default]
USAGE
sub Usage { die "$_[0]$Usage" ; }
sub Error { die  "[error] $prog: $_[0]\n" ; }
sub Warn  { warn "$prog: $_[0]\n" ; }

# usage: &GetOptions(ARG,ARG,..) defines $opt_ID as 1 or user spec'ed value
# usage: &GetOptions(\%opt,ARG,ARG,..) defines $opt{ID} as 1 or user value
# ARG = 'ID' | 'ID=SPC' | 'ID:SPC' for no-arg, required-arg or optional-arg
# ID  = perl identifier
# SPC = i|f|s for integer, fixedpoint real or string argument

use Getopt::Long ;
Getopt::Long::config('no_ignore_case') ;
my %opt = () ; Usage('') unless GetOptions(\%opt,'o','v','q','d', 'f') ;
Usage "Arg count\n" unless $opt{o} || @ARGV > 0 ;

sub mode
  { my $m = shift ;
    my @res = () ;
    for my $x ( 6, 3, 0 )
      { push ( @res, $mode [ ( $m >> $x ) & 07 ] ) ; }
    return join '.', @res ;
  }

if ( @ARGV == 2 )
  { Usage "$ARGV[1] not octal\n" 
      unless $ARGV[1] =~ /^[0-7]+$/ ;
    $MODE = oct($ARGV[1]) ;
  }
elsif ( @ARGV > 2 ) 
  { Usage("\@ARGV > 2 (@ARGV)") ; }

my $PROG = shift ; $PROG = '-' if $opt{o} ;

Usage("$prog: file $PROG exists\n") if -e $PROG ;

my @opt_syn = () ;
push @opt_syn, '[-v]' unless $opt{v} ;
push @opt_syn, '[-q]' unless $opt{q} ;
push @opt_syn, '[-d]' unless $opt{d} ;
push @opt_syn, '[-f]' unless $opt{f} ;
my $opt_syn = join ' ', @opt_syn ;

my @opt_use = () ;
push @opt_use, "option v : be verbose"      unless $opt{v} ;
push @opt_use, "option q : be quiet"        unless $opt{q} ;
push @opt_use, "option d : show debug info" unless $opt{d} ;
push @opt_use, "option f : action ; otherwise dry-run" unless $opt{f} ;
my $opt_use = join "\n", @opt_use ;

my @opt_opt = () ;
push @opt_opt, 'v' unless $opt{v} ;
push @opt_opt, 'q' unless $opt{q} ;
push @opt_opt, 'd' unless $opt{d} ;
push @opt_opt, 'f' unless $opt{f} ;
my $opt_opt = sprintf 'qw(%s)', join " ", @opt_opt ;

open(NEW,">$PROG") || die "$prog: can't write file '$PROG'\n"  ;

my $PROG1 = <<'PROG1' ;
#! /usr/bin/perl

use strict ;
use warnings ;

my $prog = substr $0, rindex ( $0, '/' ) + 1 ;
my $Usage = <<USAGE ;
Usage: $prog OPT_SYN args
OPT_USE
USAGE
sub Usage { die "$_[0]$Usage" ; }
sub Error { die "[error] $prog: $_[0]\n" ; }
sub Warn  { warn "[warn] $prog: $_[0]\n" ; }

PROG1

my $PROG2 = <<'PROG2' ;
# usage: &GetOptions(ARG,ARG,..) defines $opt_ID as 1 or user spec'ed value
# usage: &GetOptions(\%opt,ARG,ARG,..) defines $opt{ID} as 1 or user value
# ARG = 'ID' | 'ID=SPC' | 'ID:SPC' for no-arg, required-arg or optional-arg
# ID  = perl identifier
# SPC = i|f|s for integer, fixedpoint real or string argument

use Getopt::Long ;
Getopt::Long::config ( 'no_ignore_case' ) ;
my %opt = () ; Usage '' unless GetOptions
  ( \%opt, OPT_OPT ) ;
Usage "Arg count\n" unless @ARGV >= 0 ;

$opt{v} ||= $opt{d} ;

my $TAG = $opt{f} ? 'DID' : 'WOULD' ;

END { printf "$prog : *** this is a DRY-RUN ***\n" unless $opt{f} ; }

PROG2

$PROG1 =~ s/OPT_USE/$opt_use/ ;
$PROG1 =~ s/OPT_SYN/$opt_syn/ ;
$PROG2 =~ s/OPT_OPT/$opt_opt/ ;

print NEW $PROG1 unless $opt{o};
print NEW $PROG2 ;

close NEW || Error "can't close '$PROG' ($!)"  ;

! -f $PROG or chmod $MODE, $PROG
  or Error "$prog: can't chmod '$PROG' to $MODE ($!)" ;