#!/usr/bin/perl
#
# $Date: 2026-04-23 08:01:07-04 $
# $Source: /home/vogelke/projects/autoindex/local-cgi/perl/RCS/dirindex,v $
# $Host: furbag.my.domain $
# $UUID: dcffc0b0-7b17-3595-86e7-b43070d4f091 $
#
#<dirindex: generate an index for dated files if no index.htm found.

use Modern::Perl;
use File::Basename;
use CGI::Carp qw(fatalsToBrowser);
use POSIX qw(strftime);
use Cwd;

my $myname = basename($0);
$myname =~ s/\.\w*$//;    # strip any extension

# Current time.

my $now    = expires('now');
my $top    = $ENV{'DOCUMENT_ROOT'} . $ENV{'REQUEST_URI'};
my $dir    = $ENV{'REQUEST_URI'};
my $status = 'OK';
my $ok     = 1;
my $dot    = 0;
my $exten  = '';
my $str    = '';

# Sensible working directory.

if (-d "$top") {
    unless (chdir($top)) {
        $status = "$top: cannot cd: $!";
        $ok     = 0;
    }
}
else {
    $ok     = 0;
    $status = "$top not a directory";
}

# DEBUG ONLY
## environment();

# Print HTTP cache stuff and HTML header.
# This is where we exit if there's a problem with the directory.

print <<"EndHeader";
Expires: $now
Date: $now
Pragma: no-cache
Cache-Control: no-cache, max-age=0, must-revalidate
Content-type: text/html; charset=iso-8859-1

<!DOCTYPE html>
<html>
<head>
  <title>$dir</title>
  <title>Directory listing</title>
  <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
  <meta name="description" content="Directory listing for YYYY-MM-DD">
  <meta name="keywords" content="autoindex directory">
  <meta name="robots" content="index, follow">
  <link rel="stylesheet" href="/style/2col.css" type="text/css" media="screen">
  <style>
    table { table-layout: fixed; width: 100%; }
    th { padding-left: 2em; padding-top: 0; margin-top: 0; }
    td { padding-left: 1em; padding-top: 0.5em; }
    td.h1 { width: 40%; text-align: left; font-weight: bold;
            font-size: 1em; padding-left: 10px; }
    td.h2 { width: 60%; text-align: right; padding-right: 10px; }
    pre { display: block; }
    pre.calendar { padding: 0; margin: 0; }
  </style>
</head>

<body>
EndHeader

unless ($ok) {
    print "Sorry, $status\n";
    print "</body></html>\n";
    exit(0);
}

# If we get this far, we can set up file and directory icons, etc.
# ftpl is "file template" image; replace XXX with whatever matches in
# the %icons hash, or generic text if there are no matches.

my %icons;
my $dimg = '<img src="/ficons/folder.png" alt="[DIR]" />';
my $ftpl = '<img src="/ficons/XXX" alt="[TXT]" />';
my $fimg;

# Is there a list of directories?

my ($fh, $dirlist);

if (open($fh, '<', ".dirlist")   ||
    open($fh, '<', "../.dirlist") ||
    open($fh, '<', "../../.dirlist"))
{
    local $/;    # enable localized slurp mode
    $dirlist = <$fh>;
    close($fh);
}

# What's in the directory?

opendir(my $dh, ".") || die "opendir .: $!\n";
my @files = sort(readdir($dh));
my @dirs = grep(-d, @files);
my @other = grep(! -d, @files);
closedir($dh);

seticons();

# Print directory name, basic page setup.

my $cwd = getcwd;
my $info;

print <<"EndBC";
  <div id="header">
    <table>
      <tr>
        <td class="h1">$cwd</td>
        <td class="h2">$dirlist</td>
      </tr>
    </table>
  </div>

  <div class="colmask doublepage">
    <div class="colleft">
      <div class="col1">
        <!-- Column 1 start -->
<br><strong>Directories:</strong><pre>
EndBC

# Left side: print directories.

foreach (@dirs) {
    next if /^\./;
    $info = pathinfo($_);
    print "  $dimg $info <a href=\"$_\">$_</a>\n";
}

# Print regular files.

print "</pre>\n<strong>Files:</strong><pre>\n";

foreach (@other) {
    next if /^\./;
    $info = pathinfo($_);

    if ($dot = rindex($_, ".")) {
        $exten = substr($_, $dot);
        $str = defined($icons{$exten}) ? $icons{$exten} : $icons{'.txt'};
    } else {
        $str = $icons{'.unk'};
    }

    $fimg = $ftpl;
    $fimg =~ s/XXX/$str/;
    print "  $fimg $info <a href=\"$_\">$_</a>\n";
}

# Right side: print a calendar for this year if one's available.
# Look in parent directory for a file called .calendar.

print <<"EndLeft";
</pre>
<!-- Column 1 end -->
     </div>
     <div class="col2">
<!-- Column 2 start -->
EndLeft

my $calendar;

$calendar = dirname($cwd) . '/.calendar';
if (-f $calendar && open($fh, '<', $calendar)) {
    print while <$fh>;
    close($fh);
}

# Finish calendar, write page footer.

my $v = version($now);

print <<"EndRight";
        <!-- Column 2 end -->
      </div>
    </div> 
  </div>       

  <div id="footer">
    <em>Generated by $v</em>
  </div>
</body></html>
EndRight

exit(0);

#---------------------------------------------------------------------
# Slurp up a file, return UNDEF if not there.

sub slurp {
    my ($file) = shift;

    if (open(my $ifh, '<', "$file")) {
        local $/;    # enable localized slurp mode
        my $str = <$ifh>;
        close($ifh);
        return $str;
    }
    else {
        return undef;
    }
}

# -------------------------------------------------------------------------
# Size and modification date.

sub pathinfo {
    my $file = shift;
    my ($size, $mtime) = (stat ("$file"))[7,9];

    if (defined($size)) {
        return sprintf("%9d", $size)
               . "  "
               .  strftime("%Y-%m-%d %T", localtime($mtime));
    } else {
        return '?   ?';
    }
}

# -------------------------------------------------------------------------
# Icon list.

sub seticons {
    %icons = (
        '.1'     => 'file-man.png',
        '.2'     => 'file-man.png',
        '.3'     => 'file-man.png',
        '.4'     => 'file-man.png',
        '.5'     => 'file-man.png',
        '.6'     => 'file-man.png',
        '.7'     => 'file-man.png',
        '.8'     => 'file-man.png',
        '.9'     => 'file-man.png',
        '.aiff'  => 'file-sound.png',
        '.avi'   => 'video-x-generic.png',
        '.bz2'   => 'package-x-generic.png',
        '.c'     => 'file-source.png',
        '.conf'  => 'text-x-generic.png',
        '.core'  => 'file-core.png',
        '.cpp'   => 'file-source.png',
        '.css'   => 'css.png',
        '.deb'   => 'file-deb.png',
        '.doc'   => 'x-office-document.png',
        '.dvi'   => 'file-dvi.png',
        '.exe'   => 'application-x-executable.png',
        '.flac'  => 'file-sound.png',
        '.fon'   => 'file-font-bitmap.png',
        '.gif'   => 'image-x-generic.png',
        '.gz'    => 'package-x-generic.png',
        '.h'     => 'file-source.png',
        '.hpp'   => 'file-source.png',
        '.htm'   => 'text-html.png',
        '.html'  => 'text-html.png',
        '.info'  => 'file-info.png',
        '.ini'   => 'text-x-generic.png',
        '.jpg'   => 'image-x-generic.png',
        '.key'   => 'x-office-presentation.png',
        '.ksh'   => 'file-shellscript.png',
        '.lnk'   => 'file-link.png',
        '.log'   => 'file-log.png',
        '.m3u'   => 'file-sound.png',
        '.m4a'   => 'file-sound.png',
        '.m4p'   => 'file-sound.png',
        '.mak'   => 'file-make.png',
        '.mid'   => 'file-midi.png',
        '.midi'  => 'file-midi.png',
        '.mov'   => 'video-x-generic.png',
        '.mp3'   => 'file-sound.png',
        '.mpg'   => 'video-x-generic.png',
        '.nef'   => 'image-x-generic.png',
        '.nfo'   => 'text-x-generic.png',
        '.odp'   => 'x-office-presentation.png',
        '.ods'   => 'x-office-presentation.png',
        '.odt'   => 'x-office-document.png',
        '.ogg'   => 'file-sound.png',
        '.otf'   => 'font-x-generic.png',
        '.pdf'   => 'file-pdf.png',
        '.php'   => 'text-html.png',
        '.pl'    => 'file-source.png',
        '.png'   => 'image-x-generic.png',
        '.pps'   => 'x-office-presentation.png',
        '.ppt'   => 'x-office-presentation.png',
        '.ps'    => 'file-postscript.png',
        '.py'    => 'file-source.png',
        '.rar'   => 'package-x-generic.png',
        '.rpm'   => 'file-rpm.png',
        '.rtf'   => 'x-office-document.png',
        '.sh'    => 'file-shellscript.png',
        '.shtml' => 'text-html.png',
        '.srt'   => 'text-x-generic.png',
        '.svg'   => 'file-vectorgfx.png',
        '.sxw'   => 'x-office-document.png',
        '.tar'   => 'package-x-generic.png',
        '.tgz'   => 'package-x-generic.png',
        '.tif'   => 'image-x-generic.png',
        '.tiff'  => 'image-x-generic.png',
        '.ttf'   => 'font-x-generic.png',
        '.txt'   => 'text-x-generic.png',
        '.unk'   => 'unknown.png',
        '.url'   => 'file-link.png',
        '.wav'   => 'file-sound.png',
        '.wma'   => 'file-sound.png',
        '.wmv'   => 'video-x-generic.png',
        '.xhtml' => 'text-html.png',
        '.xls'   => 'x-office-presentation.png',
        '.zip'   => 'package-x-generic.png'
    );
}

# -------------------------------------------------------------------------
sub version {
    my $when = shift;
    my $VERSION = sprintf("%d.%02d", q$Revision: 3.3 $ =~ /(\d+)\.(\d+)/);
    return "$myname $VERSION $when\n";
}

# -------------------------------------------------------------------------
# Return an "Expires" header for a given time.
# Stolen from CGI/Util.pm

sub expires {
    my ($time) = @_;

    my (@MON)  = qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
    my (@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/;

    # if user specifies "now" or "0", get system time.
    if (!defined($time) || !$time || (lc($time) eq 'now')) {
        $time = time();
    }

    # make HTTP date string from GMT'ed time
    my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($time);
    $year += 1900;
    return sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT",
        $WDAY[$wday], $mday, $MON[$mon], $year, $hour, $min, $sec);
}

# -------------------------------------------------------------------------
# DEBUG ONLY: Print the environment to a file.

sub environment {
    open (my $fh, '>', "/tmp/$myname.env") or return;

    my $user = getpwuid($<);
    my $cwd  = getcwd();

    foreach my $k (sort keys %ENV) {
        $_ = $ENV{$k};
        s|"|\\"|g;

        if ($k eq "SERVER_SIGNATURE") {
            tr/\n\r//cs;
            chomp;
        }
        printf $fh "%30s = %s\n", $k, $_;
    }

    print $fh "\nArguments: [@ARGV]\n";
    return;
}
