#!/usr/athena/bin/perl
# For documentation:
#     drawer_labels.pl -h 

use strict;
use warnings;
use Getopt::Std;

# Untainted path for shell and filehandling commands
$ENV{PATH} = "/usr/athena/bin:/usr/bin:/bin";

sub untaint_glob {
# Untaint filename expansions
# $glob = untaint_glob($tainted);
    my ($glob) = @_;
    # Allow only acceptable characters
    if ($glob =~ m(^		   # Beginning of string
		   ([		   # Acceptable:
		     \w\-.\s	   #   filename characters
		     ~/		   #   directory characters
		     \*\?	   #   quantifiers
		     \[\]\^	   #   character classes
		     \{\},	   #   alternations
		    ]+)		   #   one or more of the above characters
		   $		   # End of string
		  )x		   # Allow comments in match
	) {
	$glob = $1;
    } else {
	die "Bad filename expansion $glob.\n";
    }
    return $glob;
}

# Parse options
my %options;
getopts('hd:u:s:o:p:', \%options); # See documentation on option flags

# Display help
if (exists $options{h}) {
    system("perldoc " . untaint_glob($0));
    exit;
}

# Display usage message
unless (exists $options{p}) {
    print <<EOF;
For help:     $0 -h
Single label: $0 [-u username] [-s style] [-o options] -p file
All labels:   $0 [-d user_db] [-s style] [-o options] -p file
EOF
    exit;
}

# Input file for drawer label preferences for each user
my $db_filename =
    $options{d} ? untaint_glob($options{d}) : "drawer_labels.db";
# Output file for printing drawer labels
my $ps_filename =
    $options{p} ? untaint_glob($options{p}) : "drawer_labels.ps";
# Default label style file if none is specified
my $default_label_style =
    $options{s} ? untaint_glob($options{s}) : "plain_label.ps";
# Default label options if none are specified
my $default_label_options =
    $options{o} ? untaint_glob($options{o}) : "% Default options";

# Load label preferences for each user
open DB, "$db_filename" or
    die "Filename $db_filename not found,";
my $labels = {};
while (my $line = <DB>) {
    my ($username, $style, $options) = split(/[,\n]/, $line);
    next unless $username =~ /^\w{1,8}$/;              # Skip invalid usernames
    $style = $default_label_style unless $style;      # Set default label
    $options = $default_label_options unless $options; # Set default options
    $labels->{$username} = {style => $style, options => $options};
}
close DB;

# Choose usernames for which to create labels
my @usernames;
if (exists $options{u}) {
    # Produce label for single user
    @usernames = ($options{u});
    unless (exists $labels->{$options{u}}) {
	print "User $options{u} is not in the database $db_filename.\n";
	$labels->{$options{u}} = {style => $default_label_style,
				  options => $default_label_options};
    }
} else {
    # Produce label for all users
    @usernames = (sort keys %$labels);
}

# Save label file
open OUTPUT, ">$ps_filename" or
    die "Output filename $ps_filename could not be opened for writing,";
foreach my $username (@usernames) {
    my $options = $labels->{$username}->{options};
    my $style = $labels->{$username}->{style};
    if (not -e $style) {
	# Allow shortened style names
	$style .= "_label.ps" if (-e "${style}_label.ps");
	$style .= ".ps" if (-e "${style}.ps");
    }
    open FILE, $style or
	die "Style filename $style could not be opened for writing,";
    # Print label style file
    print OUTPUT while <FILE>;
    # Print customization for individual user
    print OUTPUT <<EOF;

%%% PostScript label for $username %%%
72 72 moveto
/username ($username) def
$options
label
showpage

EOF
    close FILE;
    print "Generated label for $username.\n";
}
close OUTPUT;

exit;
__END__
######################################################################

=head1 NAME

drawer_labels.pl

=head1 SUMMARY

Generates customizable drawer labels for users.

=head1 SYNOPSIS

B<drawer_labels.pl> [B<-h>]

B<drawer_labels.pl> [B<-u> username] [B<-s> style] [B<-o> options] B<-p> printfile

B<drawer_labels.pl> [B<-d> user_db] [B<-s> style] [B<-o> options] B<-p> printfile

=head1 DESCRIPTION

This program generates customizable drawer labels for users.

By default, it will use the text file "drawer_labels.db" as a database of user preferences for their labels, and generate PostScript code in the file "drawer_labels.ps" based on those preferences for each user listed in the database.

=head1 OPTIONS

=over 5

=item B<-h> help

Displays this help documentation.

=item B<-u> username

Generates a single label for the specified username.

=item B<-d> user_db

Generates labels for the every username specified in the file user_db.  This database defaults to the file "drawer_labels.db".

This database must be a plain text file with one line per user, in the format "username,style,options", where username is the member's username, style is the filename of the label style file they desire, and options are any PostScript code that will be correctly interpreted by the label style file.  The style and options are not required; a simple default label style will be used if these are not provided.

=item B<-s> style

Uses the specified file as the default style for users, which might be overwritten by their own preferences in the user_db.  This style defaults to the file "plain_label.ps".  If the filename ends in "_label.ps" or just ".ps", then that extension can be left off.

This style must be a PostScript file.  The label style file should define a "label" function.  Other options may be provided.

=item B<-o> options

Uses the specified string as the default options for users, which might be overwritten by their own preferences in the user_db.  These options default to a comment.

These options must be valid PostScript code that works with the label style file.  They might consist, for example, of font specifications.  See the particular file for details.

=item B<-p> printfile

Specifies the output file for printing drawer labels.  This output file defaults to "drawer_labels.ps".  The file should be previewed to test for validity before printing.

=back

=head1 SEE ALSO

perl, PostScript manuals, included README file

=head1 VERSION

This is drawer_labels version 0.1, 13 April 2005.

=head1 AUTHOR

Richard J. Barbalace E<lt>rjbarbal@mit.eduE<gt>

=head1 COPYRIGHT

Copyright 2005 Richard J. Barbalace.  All Rights Reserved.

This program is free software.  You may copy or redistribute it under
the same terms as Perl itself.
