The system relies on a SQL Server database. The relevant tables look like this

person
Column_name	Type	Length	Comment
person_id	char	10	Primary key
name	varchar	40	Perons's name
title	varchar	100	Person's title
Discipline	varchar	20	Examples include 'development', 'test', 'product', etc

contract
Column_name	Type	Length	Comment
person_id	char	10	References person.person_id
DoA	smalldatetime	4	Date of Arrival, not nullable
DoL	smalldatetime	4	Date of Leaving, NULL signifies permanent employee
Employer	varchar	50

And now for the code that produces the HTML. It relies on a templating system that was originally based on everything code (a long time ago) but now resembles nothing to be proud of. I haven't included it due to embarassment at my subsequent hacks, but I'm sure you could easily find a replacement. I've also edited out bits that are specific to the environment in which it runs, just a few lines.

use strict;
use warnings;

use CGI qw(:standard);
use Date::Simple;

sub NiceDateFormat {
    Date::Simple->new($_[0])->format("%d %b %Y"); 
}

my ($fday,$fmonth,$fyear) = (param('fday'),param('fmonth'),param('fyea
+r'));
my ($tday,$tmonth,$tyear) = (param('tday'),param('tmonth'),param('tyea
+r'));

die &Template("DevMgr/GenericError",{message => 'missing some or all o
+f the FROM date'}) 
    unless ($fday and $fmonth and $fyear);
die &Template("DevMgr/GenericError",{message => 'missing some or all o
+f the TO date'}) 
    unless ($tday and $tmonth and $tyear);

my $start = "$fyear-$fmonth-$fday"; 
my $end   = "$tyear-$tmonth-$tday";

my $s = &db_Staff_On_Site_Between_Two_Dates($start,$end);

my (%days, $hc, @previnits, $thisline, $from, @people, @prevpeople, $p
+revdate);

push @{$days{$$_[1]}}, $$_[2] for @$s;

# loop through each date (up to the end of range)
# looking for changes in head count
for my $date (sort keys %days) {

    @people = sort @{$days{$date}}; 

    # initialise values for the 'previous' day
    @prevpeople = @people unless @prevpeople;
    $from     ||= $date;
    $prevdate ||= $date;

    if ("@prevpeople" ne "@people") {

        # work out who has arrived, who has departed
        my (@arriving,@departing);

        my %prevpeople = map {$_ => undef} @prevpeople;
        my %people     = map {$_ => undef} @people;

        for (@people) { push @arriving, $_ unless exists $prevpeople{$
+_}; }
            
        for (@prevpeople) { push @departing, $_ unless exists $people{
+$_}; }

        # then deal with arrivals and departures
        my $arriving = @arriving ? &Template("DevMgr/SingleHeadCountAr
+rivalLine",{ 
            date   => NiceDateFormat($date), 
            change => join(", ", sort @arriving)}) : ' ';
            
        my $departing = @departing ? &Template("DevMgr/SingleHeadCount
+DepartureLine",{ 
            date   => NiceDateFormat($prevdate), 
            change => join(", ", sort @departing)}) : ' ';
            
        # output the headcount as at the previous day
        $hc .= &Template("DevMgr/SingleHeadCountLine", {
                datefrom    => NiceDateFormat($from),
                dateto      => NiceDateFormat($prevdate),
                headcount   => scalar(@prevpeople),
                staffonsite => join (', ', sort values %{UniqInits(@pr
+evpeople)}),
                arriving    => $arriving,
                departing   => $departing
            }
        );

            
        $from = $date;
        @prevpeople = @people;
    } 

    $prevdate = $date;
}

# we drop out of the loop when we hit the end of the range,
# so it is now necessary to output a final line of head count
$hc .= &Template("DevMgr/SingleHeadCountLine", {
        datefrom    => NiceDateFormat($from),
        dateto      => NiceDateFormat((reverse sort keys %days)[0]),
        headcount   => scalar(@people),
        staffonsite => join(', ', sort values %{UniqInits(@people)}),
        arriving    => ' ',
        departing   => ' '
    }
);

print &Template("DevMgr/ShowHeadCount",{ headcount_html => $hc });
[download]

If you are still with me, you might have noticed that there is a critical function that returns a reference to an AoA containing the range of days and the people present on each day. Here it is -

sub db_Staff_On_Site_Between_Two_Dates {
    my ($start,$end) = @_;

    die &Template
    (
        "DevMgr/GenericError",
        {message => 'Missing start and/or end date in db_Staff_On_Site
+_Between_Two_Dates()'}
    ) unless ($start and $end);

    RunSQLReturnArrayRef(
        " 
            declare \@start smalldatetime
            declare \@end   smalldatetime

            set \@start = '$start'
            set \@end = '$end'

            create table #dates ([date] smalldatetime not null)
            declare \@datecount smalldatetime
            set \@datecount = \@start
            while (\@datecount <= \@end) 
            begin
                insert into #dates values (\@datecount)
                set \@datecount = \@datecount + 1
            end

            select p.person_id,convert(char(8),d.date,112),p.name
            from contract c 
            inner join person p on c.person_id = p.person_id

            inner join #dates d  -- cartesian join to date range, cons
+trained only by contract DoA and DoL
            on d.date between isnull(c.doa,\@start) and isnull(c.dol,\
+@end)

            where  p.discipline = 'development'
            order by d.date,p.name

            drop table #dates
        "
    );
    
}
[download]

You'll have to pardon my use of a SQL Server temporary table. If someone can show me an efficient and portable equivalent I'd be very appreciative!

And for the sake of completeness, here's the code that uses DBI to get the actual results

sub RunSQLReturnArrayRef {
    my $SQL = shift or exit;

    my $dbh = Get_database_handle or exit;
   
    my $resultArrayRef=$dbh->selectall_arrayref($SQL); 
    
    if ($dbh->err) {
    print &Template("DevMgr/GenericError",{message=>"Couldn't prepare 
+statement : $DBI::errstr"});
    exit;
    }

    $dbh->disconnect;

    return $resultArrayRef;
}
[download]

Get_database_handle() does what the name implies. You don't want mine :)

I hope this helps, or maybe inspires, someone else.

Oh, and one more function I almost forgot to include; UniqInits(). This is based on code written by Limbic~Region over in this node.

sub UniqInits {

    # takes an array of unique names and returns a hashref { 'a man' =
+> [ 'a', 'm'], ... }
    
    my %data;
    my $maxnames = 0;
    for my $name (@_) {
        chomp $name;
        my @names = split /[^\w]+/,$name;
        $maxnames = @names if @names > $maxnames;
        $_ = ucfirst lc $_ for @names;
        $data{ "@names" } = \@names;
    }

    for my $index ( 0 .. $maxnames ) {
        for my $person ( keys %data ) {
            next if ! $data{$person}[$index];
            my $old_name = $data{$person}[$index];
            for my $length ( 1 .. length $old_name ) {
                $data{$person}[$index] = substr( $old_name, 0, $length
+ );
                my $match = 0;
                for ( keys %data ) {
                    next if $_ eq $person || @{$data{$_}} != @{$data{$
+person}};
                    my $test_name = $data{$_}[$index];
                    $data{$_}[$index] = substr( $test_name, 0, $length
+ );
                    my ($s_name , $s_test) = ("@{$data{$person}}", "@{
+$data{$_}}");
                    $data{$_}[$index] = $test_name;
                    if ( $s_name eq $s_test ) {
                        $match = 1;
                        last;
                    }
                }
                last if ! $match;
            }
        }
    }

    for my $name (keys %data) {
        $data{$name} = join '',@{$data{$name}};
    }

    \%data;
}
[download]