#!/usr/bin/perl -w
#-----------------------------------------------------------------------------
#
#  Copyright (C) 2000 Ryan C. Gordon (icculus@icculus.org)
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307 USA
#
#-----------------------------------------------------------------------------

#-----------------------------------------------------------------------------
# Revision history:
#  1.0.0  : First release
#  1.0.2  : Minor bugfixes.
#  1.1.0  : Prints version in <title>, more customizable, optionally allows
#           fingering to arbitrary sites for use as a web interface to finger,
#           supports VirtualHost sites, better error output.
#  1.1.1  : Highlights URLs and email addresses.
#  1.2.0  : Changed email address. Moved script name to $script_link.
#            Reads [title], [url], and [img] tags.
#  1.2.1  : [center] and [font] tags added.
#  1.3.0  : (Yes, I went up two minors in one day.) Plain text output from
#            the command line.
#  1.3.1  : Added bold, italics, and underlines ([b][u][i][/i][/u][/b])
#            Text output gets the witty remark, etc, too.
#  1.3.2  : Added "?format=n" argument to the web interface, and fixed a
#            formatting bug with the [center] tag in Opera.
#  1.3.3  : [link] tags spit out URL in non HTML formatted version. Handles
#            newlines in [center] tags for Opera. Fixed bug where HTML
#            formatting was enabled in the regular finger interface.
#  1.3.4  : Bugfixes to the "&" -> "&amp;" substitution and the URL
#            highlighter. Added almost useless debugging facility.
#  1.3.5  : More debugging output, and randomized titles. Debugging can be
#            enabled/disabled in the URL.
#  1.3.6  : Added [wittyremark] tag at a user's request. [title] tags on a
#            line by themselves have the newline removed, so that 50 random
#            titles don't end up with 50 blank lines in the output; this is
#            true for [wittyremark], too. Email address auto-URLifying can
#            handle addresses with a '.' at the end, for example at the end
#            of a sentence. Changed the ending output, and made the credits
#            (formerly $script_link and hardcoded) more configurable.
#  1.3.7  : Removed '\r' chars from textmode footer.
#  1.3.8  : Fixes for Lynx text browser.
#  1.3.9  : Allows use of [defaultsection] and [section=""][/section] tags.
#            This is hacky right now. DO NOT USE THESE TAGS.
#  1.3.10 : Modified the URL-detecting regexp to be a little more accurate.
#-----------------------------------------------------------------------------

# TODO: Let [img] tags nest inside [link] tags.
# TODO: Make [center] tags attempt to format plain text.


use strict;  # don't touch this line, nootch.
use warnings;  # don't touch this line, either.



#-----------------------------------------------------------------------------#
#             CONFIGURATION VARIABLES: Change to suit your needs...           #
#-----------------------------------------------------------------------------#

# Version of IcculusFinger. Change this if you are forking the code.
my $version = "v1.3.10";


# This is the default title for the webpage. The user can override it with
#  the [title] tag in their .plan file.
my $title = "IcculusFinger $version";


# Alternately, you can populate this array with strings, and IcculusFinger
#  will randomly pick one at runtime. Note that the user's [title] tags also
#  land in here, so you are interfering with their ability to override the
#  title if you add to this array. The $title variable above is used only if
#  this array is empty, and thus gives you a comfortable default in case the
#  user doesn't supply her own title. Do as you will.
my @title_array;


# Location where the server can find the finger client it will be using
#  to get information. This string is executed and what it writes to stdout
#  is read in by this script.
my $fingerprog = "/usr/local/bin/afinger --portname=fingertags";


# Uncomment this to always do finger requests to the same host.
# Define which host the finger request goes to. If you don't define $host,
#  then users may finger any system on the internet by specifying a hostname:
#  user=dimwit@doofus.com, for example. Not setting $host at all like that
#  could leave a mild exploit available.
# This is ignored if run from the command line.
#my $host = undef;   # Makes this script work as a web interface to finger.
#my $host = "icculus.org";  # limit queries to users@icculus.org
my $host = $ENV{SERVER_NAME}; #  This is good for VirtualHost setups.


# This is printed after the credits at the bottom. Change it to whatever you
#  like. Do not use HTML. You can specify an empty string (""), but undef
#  doesn't fly here. The user can change this with [wittyremark] tags.
my $wittyremark = "Stick it in the camel and go.";


# Alternately, you can populate this array with strings, and IcculusFinger
#  will randomly pick one at runtime. Note that the user's [wittyremark] tags
#  also land in here, so you are interfering with their ability to override
#  if you add to this array. The $wittyremark variable above is used only if
#  this array is empty, and thus gives you a comfortable default in case the
#  user doesn't supply her own content. Do as you will.
my @wittyremark_array;


# you can screw up your output with this, if you like.
# in the web interface, you can use "?debug=1" to enable this without
# changing the source.
my $debugging = 0;


# This is the URL to where the script can be obtained. Feel free to change
#  it if you you are forking the code, but unless you've got a good reason,
#  I'd appreciate it if you'd leave my (ahem) official IcculusFinger webpage
#  in this variable. Set it to undef to not supply a link at all in the
#  final HTML output.
#my $scripturl = undef;
#my $scripturl = "/misc/finger.pl";
my $scripturl = "http://icculus.org/IcculusFinger/";


# This is only used in the HTML-formatted output.
# I'd prefer you leave this be, but change it if you must.
my $html_credits = (defined $scripturl) ?
              "Powered by <a href=\"$scripturl\">IcculusFinger $version</a>" :
              "Powered by IcculusFinger $version" ;

# This is only used in the plaintext-formatted output.
# I'd prefer you leave this be, but change it if you must.
my $text_credits = "Powered by IcculusFinger $version" .
                    ((defined $scripturl) ? " ($scripturl)" : "");

#-----------------------------------------------------------------------------#
#     The rest is probably okay without you laying yer dirty mits on it.      #
#-----------------------------------------------------------------------------#

my $is_web_interface = 0;
my $do_html_formatting = 0;
my $browser = "";
my $user;
my $dbgnl = "\n";
my $wanted_section = undef;


sub output_start {

    return if not $is_web_interface;

print <<__EOF__;
<html>
  <head>
    <title> $title </title>
  </head>

  <body>

__EOF__

}


sub output_ending {

    # TODO: Make that ------ line fit the length of the strings.
    if (not $is_web_interface) {
        print "-------------------------------------------------------------------------\n";
        print "$text_credits\n";
        print "$wittyremark\n\n";
        return;
    }

print <<__EOF__;

    <hr>
    <center>
      <font size="-3">
        $html_credits<br>
        <i>$wittyremark</i>
      </font>
    </center>

  </body>
</html>

__EOF__

}




# Mainline.

$host =~ tr/A-Z/a-z/ if defined $host;

if ((defined $ENV{GATEWAY_INTERFACE}) and ($ENV{GATEWAY_INTERFACE} ne "")) {
    $is_web_interface = 1;
    $do_html_formatting = 1;
    $dbgnl = "<br>\n";

    if ((defined $ENV{HTTP_USER_AGENT}) and ($ENV{HTTP_USER_AGENT} ne "")) {
        $browser = $ENV{HTTP_USER_AGENT};
    }

    my $QueryString = $ENV{QUERY_STRING};
    if ($QueryString =~ /user=(.*)/) {
        $user = $1;
        $user =~ s/&.*//;
        $user =~ tr/A-Z/a-z/;
    }

    if ($QueryString =~ /format=(.*)/) {
        $do_html_formatting = $1;
        $do_html_formatting =~ s/&.*//;
        $do_html_formatting =~ tr/A-Z/a-z/;
    }

    if ($QueryString =~ /debug=(.*)/) {
        $debugging = $1;
        $debugging =~ s/&.*//;
        $debugging =~ tr/A-Z/a-z/;
    }

    if ($QueryString =~ /section=(.*)/) {
        $wanted_section = $1;
        $wanted_section =~ s/&.*//;
        $wanted_section =~ tr/A-Z/a-z/;
    }

    # !!! FIXME: This is a pretty lame solution.
    if ($browser =~ /Lynx/) {
        $do_html_formatting = 0;
    }

} else {  # regular request over finger protocol; no HTML, etc.
    $dbgnl = "\n";
    $user = shift;
    if (not defined $user) {
        print("USAGE: $0 <username[\@hostname.dom]>\n");
        exit 42;
    }
    $user = "$user\@localhost" if (not $user =~ /\@/);
    $is_web_interface = 0;
    $do_html_formatting = 0;
}

my $requested_host = undef;
if ((defined $user) && ($user =~ s/\@(.*)//)) {
    $requested_host = $1;
    $requested_host =~ tr/A-Z/a-z/;
}

my $errormsg = undef;
if (not defined $user) {
    $errormsg = "No user specified.";
} elsif ((not defined $host) and (not defined $requested_host)) {
    $errormsg = "No host specified.";
} elsif ((defined $host) and (defined $requested_host)) {
    if (($is_web_interface) and ($host ne $requested_host)) {
        $errormsg = "You aren't permitted to specify a hostname, just a user.";
    }
} elsif (length($user) > 20) {
    # The 20 char limit is just for safety against potential buffer overflows
    #  in finger servers, but it's more or less arbitrary.
    # !!! TODO FIXME: Check for bogus characters in username/host.
    $errormsg = "Bogus user specified.";
}

if (defined $errormsg) {
    output_start();
    print "    <center><h1>" if $is_web_interface;
    print "$errormsg";
    print "</h1></center>" if $is_web_interface;
    print "\n";
} else {

    print("Content-type: text/html\n\n\n") if $is_web_interface;

    $host = $requested_host if not defined $host;

    if ($debugging) {
        print("WARNING: Debugging is enabled in this finger request!$dbgnl");
        print("fingering $user at $host ...$dbgnl");
        print("HTML formatting: $do_html_formatting ...$dbgnl");
        print("Is web interface: $is_web_interface ...$dbgnl");
        print("Browser: $browser ...$dbgnl");
    }

    if (not open(FINGER, "$fingerprog $user\@$host |")) {
        output_start();
        print("    <center><h1>Couldn't run finger program: $!.</h1></center>\n\n");
    } else {
        my $output_text = "";
        while (<FINGER>) {
            $output_text = $output_text . $_;
        }
        close(FINGER);

        if ($is_web_interface) {
            # HTMLify some common characters...
            1 while ($output_text =~ s/</&lt;/s);
            1 while ($output_text =~ s/>/&gt;/s);
        }

        # Select a section.
        # !!! FIXME: Filter out all [defaultsection] tags and take the last
        # !!! FIXME:  one...or maybe a random one? Hhm.
        if (not defined $wanted_section) {
            if ($output_text =~ s/\[defaultsection=\"(\w*)\"\](\r\n|\n|\b)//) {
                $wanted_section = $1;
                if ($debugging) {
                    print("default section: $wanted_section ...$dbgnl");
                }
            }
        } else {
            # ditch this tag...
            $output_text =~ s/\[defaultsection=\"(\w*)\"\](\r\n|\n|\b)//is;
        }

        if (defined $wanted_section) {
            if ($debugging) {
                print("Using specific section: $wanted_section ...$dbgnl");
            }

            # !!! FIXME: Why isn't the substitution working? I need to assign $2 directly for some reason...
            if ($output_text =~ s/\[section=\"$wanted_section\"\](\r\n|\n|\b)(.*?)\[\/section\](\r\n|\n|\b)/$2/is) {
                $output_text = $2;
            } else {
                $output_text = "section \"$wanted_section\" not found.\n";
            }
        } else {
            1 while ($output_text =~ s/\[section=\".*?\"\](.*?)\[\/section\](\r\n|\n|\b)/$1/is);
        }


        while ($output_text =~ s/\[title\](.*?)\[\/title\](\r\n|\n|\b)//is) {
            push @title_array, $1;
        }

        # Change [title][/title] tags.
        while ($output_text =~ s/\[title\](.*?)\[\/title\](\r\n|\n|\b)//is) {
            push @title_array, $1;
        }

        # Change [wittyremark][/wittyremark] tags.
        while ($output_text =~ s/\[wittyremark\](.*?)\[\/wittyremark\](\r\n|\n|\b)//is) {
            push @wittyremark_array, $1;
        }

        # Change [b][/b] tags.
        if ($do_html_formatting) {
            1 while ($output_text =~ s/\[b](.*?)\[\/b\]/<b>$1<\/b>/is);
        } else {
            1 while ($output_text =~ s/\[b](.*?)\[\/b\]/$1/is);
        }

        # Change [i][/i] tags.
        if ($do_html_formatting) {
            1 while ($output_text =~ s/\[i](.*?)\[\/i\]/<i>$1<\/i>/is);
        } else {
            1 while ($output_text =~ s/\[i](.*?)\[\/i\]/$1/is);
        }

        # Change [u][/u] tags.
        if ($do_html_formatting) {
            1 while ($output_text =~ s/\[u](.*?)\[\/u\]/<u>$1<\/u>/is);
        } else {
            1 while ($output_text =~ s/\[u](.*?)\[\/u\]/$1/is);
        }

        # Change [center][/center] tags.
        if ($do_html_formatting) {
            if ($browser =~ /Opera/) {
                while ($output_text =~ /\[center](.*?)\[\/center\]/is) {
                    my $buf = $1;
                    1 while ($buf =~ s/\n/<br>/s);
                    $output_text =~ s/\[center](.*?)\[\/center\]/<\/pre><center><code>$buf<\/code><\/center><pre>/is;
                }
            } else {
                1 while ($output_text =~ s/\[center](.*?)\[\/center\]/<center>$1<\/center>/is);
            }
        } else {
            1 while ($output_text =~ s/\[center](.*?)\[\/center\]/$1/is);
        }

        # Change [font][/font] tags.
        if ($do_html_formatting) {
            1 while ($output_text =~ s/\[font (.*?)](.*?)\[\/font\]/<font $1>$2<\/font>/is);
        } else {
            1 while ($output_text =~ s/\[font (.*?)](.*?)\[\/font\]/$2/is);
        }

        # Change [link][/link] tags.
        if ($do_html_formatting) {
            1 while ($output_text =~ s/\[link=\"(.*?)\"\](.*?)\[\/link\]/<a href=\"$1\">$2<\/a>/is);
        } else {
            1 while ($output_text =~ s/\[link=\"(.*?)\"\](.*?)\[\/link\]/$2 \[$1\]/is);
        }

        # Change [img][/img] tags.
        if ($do_html_formatting) {
            1 while ($output_text =~ s/\[img=\"(.*?)\"\](.*?)\[\/img\]/<img src=\"$1\" alt=\"$2\">/is);
        } else {
            1 while ($output_text =~ s/\[img=\"(.*?)\"\](.*?)\[\/img\]/$2/is);
        }

        if ($do_html_formatting) {
            # try to make URLs into hyperlinks in the HTML output.
            1 while ($output_text =~ s/(?<!href=")(?<!src=")(?<!">)\b([a-zA-Z]+?:\/\/[-~=\w&\.\/?]+)/<a href="$1">$1<\/a>/);

            # try to make email addresses into hyperlinks in the HTML output.
            1 while ($output_text =~ s/\b(?<!href="mailto:)(?<!">)\b([\w\.]+?\@[\w\.]+)(\b|\.)/<a href=\"mailto:$1\">$1<\/a>/);

            # HTMLify newlines.
            #1 while ($output_text =~ s/\r//s);
            #1 while ($output_text =~ s/(?<!<br>)\n/<br>\n/s);

            # this has to be done after any possible URL detection...
            #   convert ampersands for the browser.
            1 while ($output_text =~ s/(?<!">)\&(?!amp)/&amp;/s);
        }

        # Pick a random title...
        if ($debugging) {
            my $x;
            $x = $#title_array + 1;
            print("Number of titles: $x ...$dbgnl");
            print(" titles:$dbgnl");
            foreach (@title_array) {
                print("  -  [$_]$dbgnl");
            }

            $x = $#wittyremark_array + 1;
            print("Number of witty remarks: $x ...$dbgnl");
            print(" witty remarks:$dbgnl");
            foreach (@wittyremark_array) {
                print("  -  [$_]$dbgnl");
            }
        }

        if ($debugging) {
            print("Actual finger output begins below line...$dbgnl");
            print("---------------------------------------------------$dbgnl");
        }

        if ($#title_array >= 0) {
            $title = $title_array[int(rand($#title_array + 1))];
        }

        if ($#wittyremark_array >= 0) {
            $wittyremark = $wittyremark_array[int(rand($#wittyremark_array + 1))];
        }

        output_start();

        if ($is_web_interface) {
            print("    <center><h1>Finger info for $user\@$host...</h1></center>\n");
            #print("    <hr><code>\n\n");
            print("    <hr>\n\n<pre>\n\n");
            print("$output_text");
            #print("</code>\n\n");
            print("\n</pre>\n");
        } else {
            print("$title\n\n");
            print("$output_text\n");
        }
    }
}

output_ending();

exit 0;

# end of finger.pl ...