=PROGRAM TO write address labels

Revision history:

v1.  start from scratch

=cut




#global
my @LABELLIST;
my $LABELTOTAL=0;
my $NUMBERROWS=4;

#all the HTML templates are global
$PAGEHEADERSTUFF =<<'HTMLTEMPLATE';
%page header stuff

HTMLTEMPLATE


$PAGEFOOTERSTUFF =<<'HTMLTEMPLATE';
%page footer stuff

HTMLTEMPLATE


$ROWLEADER =<<'HTMLTEMPLATE';
%begin row

HTMLTEMPLATE


$ROWTRAILER =<<'HTMLTEMPLATE';
%end row

HTMLTEMPLATE



$LABEL =<<'HTMLTEMPLATE';
##1##
##2##
##3##
##4##
HTMLTEMPLATE




=think about:
#fix:

#s/##(\d+)##/$_[$1+1]/eg;

Explanation:
- the (\d+) matches any numeric sequence, and is stored as $1 for the rhs
- the $_[$1+1] then will be the third arg ($_[2]) for ##1##, etc.  I
  might be off by one here.
- the /e tells perl to interpret the rhs as an expression to execute
  rather than a string to substitute.
- the /g tells perl to do that for every occurrence of the lhs.
?This could substitute for a parameter that doesn't that doesn't have an argument in the call
=cut

sub Copytemplate { #routine to copy and template and fill in parameters
    #fix: figure out how to embed next line in BEGIN
    my @patt = qw(notused ##1## ##2## ##3## ##4## ##5## ##6## ##7## ##8## ##9##);
    my $length = @_; my $outfile = $_[0]; my $template = $_[1];
    my ($argcount, $toreplace, $replacement);
    unless ($length > 1) {die "too few arguments in call to Copytemplate -- need at least two";};
    for ($argcount = 2; $argcount < $length; $argcount++) #repeat for each arg to be substituted
         {$replacement = $_[$argcount]; #don't know if s/ can handle subscripts
          $toreplace=$patt[$argcount-1];
          $template =~ s/$toreplace/$replacement/g;
        };
    print($outfile $template); #print the template with its substitutions; outfile holds the output handle
}


#the previous and following subroutines could be combined and the following could be
#made to handle multple list-of-list parameters, but having separate routines and
#multiple calls to the following subroutine is actually sort of clear to use, albeit
#perhaps not so elegant; the following subroutine could also be changed so the repeat
#pattern to search does not have to be passed in as a parameter, but doing it this
#way was easier to debug and solves the problem of not having an escape mechanism
#for sequences that might be used for real in the template being copied

sub Rptovertemplate { #repeatedly replace arguments over the part of a template bracketed by [[ ]]
    my @patt = qw(notused !!1!! !!2!! !!3!! !!4!! !!5!! !!6!! !!7!! !!8!! !!9!!);
    my $length = @_;
    unless ($length > 1) {die "too few arguments in call to Rptovertemplate -- need at least two";}; #fix later
    my $intemplate = shift;
    my $rptpattern = shift;
    if ($intemplate !~ m/$rptpattern/s) {return $intemplate}; #nothing to replace
    #before stuff is in $1, after stuff is in $3, stuff to be repeated minus delimitors is in $2
                                                            #print "\n",$1,"\n",$2,"\n",$3,"\n12345";exit;
    my $temptemplate = "";
    my $outtemplate;
    my ($listref) = @_; #assumes only a third argument
    my $listcnt = @$listref;                                #print "\n listcnt=",$listcnt," ",$listref;
    for ($i=0; $i<$listcnt; $i++) {
         my $recref = $$listref[$i];                        #print "\n record ref=",$recref;
         my $argscnt = @recref;                             #print "\n arg count:", $argcnt;
         my @args = @$recref;
         my $replacetemplate = $2; #get ready to do replace on stuff within the square brackets
         $length = @args;
                                                            #print "\n#args=",$length," ",$args[0]," ",$args[1]," ",$args[2];
         my ($argcount, $toreplace, $replacement);
         for ($argcount = 0; $argcount < $length; $argcount++) #repeat for each arg to be substituted
            {$replacement = $args[$argcount]; #don't know if s/ can handle subscripts
             $toreplace=$patt[$argcount+1];
             $replacetemplate =~ s/$toreplace/$replacement/g;
                                                            #print "\n",$replacetemplate," ",$toreplace," ",$replacement;
            };
                                                            #print "\n",$i," ",$replacetemplate;
         $temptemplate = $temptemplate.$replacetemplate."\n"; #add on the next bit of repeated stuff
         };
    $outtemplate = $1.$temptemplate.$3; #add the rest of the stuff before and after the part being repeated
                                                            #print $outtemplate; exit;
    return $outtemplate;
}


sub Todaysdate { #routine to generate a printable version of today's date (at Greenwich)
   my $formatswitch = $_[0];
   my $month = (qw(January
                   February
                   March
                   April
                   May
                   June
                   July
                   August
                   September
                   October
                   November
                   December)
                )[(gmtime)[4]];
   my $date = (gmtime)[3];
   my $year = (gmtime)[5]+1900;
   if ($formatswitch eq 'european') {return($date.' '.$month.' '.$year)}
   else {return($month.' '.$date.', '.$year)};
}

sub Preprocessfilelines { #reads an entire file, strips comments, blank lines, handles continuations,
                     #and returns all the interesting lines as a list.
   my $infilehandle = $_[0]; my $inputline; my @listoflines;
   while ($inputline = <$infilehandle>) {
        $inputline =~ s/\r?\n$//;
        next if $inputline =~ m/^\s*(#.*)?$/; # skip blank lines and comments
        chomp ($inputline); #print "\n",$inputline;
        my $inputlinecontuation;
        while (substr ($inputline, -1) eq '\\') {
            chop ($inputline);
            $inputlinecontinuation = <$infilehandle>;
            $inputlinecontinuation =~ s/\r?\n$//;
            $inputlinecontinuation =~ m/^\s*(.*)$/;
            $inputline = $inputline.$1;
        }
        push @listoflines,$inputline;}
   return @listoflines;
}

sub Andnamestocommanames { #takes a string of author names separated by " and " and turns all but last into ", "
   my $inputstring = $_[0];
   $inputstring =~ s/ and /\, /g;
   $inputstring = reverse $inputstring;
   $inputstring =~ s/ \,/ dna /;
   $inputstring = reverse $inputstring;
   return $inputstring
}

#test Andnamestocommanames
#print "\n",Andnamestocommanames("David Walden and Karl Berry");
#print "\n",Andnamestocommanames("David Walden");
#print "\n",Andnamestocommanames("David Walden and Karl Berry and Tim Null");
#print "\n",Andnamestocommanames("David Walden and Karl Berry and Tim Null and Lance Carnes");






sub Genlabel{
    my $inputline = $_[0];
    if ($inputline =~ m/^\-.*/) {return;}; #don't print this line if -
    if ($inputline =~ m/^\~.*/) {return;}; #don't print this line if ~
    if ($inputline =~ m/^\*.*/) {return;}; #don't print this line if *
    if ($inputline =~ m/^\?.*/) {return;}; #don't print this line if *
    $inputline =~ s/\[.*?\]//g;  #remove bracketed text
    print "\n$inputline";
    # need to remove double spaces
    $fields[0]=" ";$fields[1]=" ";$fields[2]=" ";$fields[3]=" ";
    my @fields = split(/\\/,$inputline);
    my $i;
    for ($i=0; $i < $NUMBERROWS; $i++)
        {
        if ($fields[$i] ne '')
            {$fields[$i]=$fields[$i].'\\\\';
            $fields[$i] =~ s/\#/\\\#/;   #escape in sharp signs
            $fields[$i] =~ s/\&/\\\&/;    #escape in ampersands
            }
        };
    Copytemplate(OUT,$LABEL,'\lb{'.$fields[0], $fields[1], $fields[2], $fields[3].'}');
    $LABELTOTAL++;
}


#start here
    #scan address list
    print "\n reading address list file";
    open(OUT,">test.txt");
    #open(IN,"converted-mothers-address-list.txt") or die "Can't open input address list";
    open(IN,"our-address-list-12-27-06.txt") or die "Can't open input address list";
L1: $inputline = <IN>;
L5: chomp ($inputline); print "\n$inputline";
    goto L1 if $inputline !~ m/^\*AAAAA.*$/; # skip to AAAAA
L6: Genlabel($inputline);
L2: unless ($inputline = <IN>) {goto L3;};
    chomp ($inputline); #print "\n L2: $inputline";
    if ($inputline !~ m/^\s*$/) {goto L2;}; # skip to blank line
L4: $inputline = <IN>;
    chomp ($inputline); #print "\n L4: $inputline";
    if ($inputline =~ m/^\s*$/) {goto L4;}; #skip past blank lines
    goto L6;
L3: close(IN);
    close(OUT);



#END OF PROGRAM