#!perl -w
#-----------------------------------------------------------------#
# webset.plx
# See POD below for more information
#-----------------------------------------------------------------#
# Initialize
#-----------------------------------------------------------------
require 5.004;
use DB_File;
use File::Copy;
use File::Find;
use Mac::Apps::PBar;
use Mac::Files;
use Mac::Processes;
use Net::Netrc 2.08;
use POSIX qw(strftime);use URI;
use strict;
my(
    $prefs_dir, $prefs_file, $main_dir, $new_dir, $upload_dir,
    @ext, $bar, $num, $num2, %files, @s, $default, %temp, %lib,
    $host, $user, $pass, $ftp, %log, %up, $time, $mkdir, $ftpapp,
    $process, $nav, $doall
);

#-----------------------------------------------------------------
# User Config section
#-----------------------------------------------------------------
$ftpapp     = 'Arch';  # Arch for Anarchie, FTCh for Fetch
                       # Arch works a bit better, IMO,
                       # but will munge Mac-specific characters
                       # in TEXT files
@s          = qw(targ onld titl crea omit type base);
@ext        = qw(html htm shtml NONE);
                                  # extensions to process
                                  # NONE is special, will process
                                  # files with no extension
$prefs_dir  = FindFolder(kOnSystemDisk(), kPreferencesFolderType())
                . ':webset prefs:';
$prefs_file = "${prefs_dir}filelog";
$main_dir   = "Bourque:Prog:src:Pudge.Net:Pudge.Net";
$new_dir    = "$main_dir Upload";
$upload_dir = '/http/home/www.pudge.net';
$host       = 'pudge.net';
$user       = '';
$pass       = '';
$default    = 'default';
$mkdir      = 0;   # try to create directories
$doall      = 0;   # upload everything (0 is just changed files)

#-----------------------------------------------------------------
# Main program
#-----------------------------------------------------------------
$nav = eval {require Mac::Navigation};
{
    tie(%log, 'DB_File', $prefs_file, O_RDWR|O_CREAT, 0755) or die $!;
    $time = $log{'time'} || 0;
    $process = MacPerl::Answer('Process files?', 'OK', 'Manual', 'Cancel');

    if ($process == 2) {
        process();
    } elsif ($process == 1) {
        $main_dir = get_folder('Select a start folder', $main_dir);
        $new_dir = get_folder('Select a destination folder', $new_dir);
        exit unless MacPerl::Answer(
            "Are you sure you want to use $main_dir and $new_dir?",
            'OK', 'Cancel'
        );
        process();
    }

    upload_files();
    $log{'time'} = time();
    untie(%log);
}

# I need to go in and fix some problem with Mac::Apps::PBar ...
#END {$bar->close_window() if $bar}
#-----------------------------------------------------------------
# Subroutines
#-----------------------------------------------------------------
sub process {
    $bar = Mac::Apps::PBar->new('Progress Bar', '150, 250');
    $bar->data(Cap1 => 'Translating Files');
    SetFrontProcess(GetCurrentProcess());
    finddepth(\&delete_files, $new_dir);
    create_dir($new_dir);
    find(\&get_files, $main_dir);
    run_files(\%files);
}
#-----------------------------------------------------------------
sub delete_files {
    my($f) = $File::Find::name;
    if (-f $f) {
        unlink($f) or die "can't unlink <$f>: $!";
    } elsif (-d _) {
        rmdir($f) or die "can't rmdir <$f>: $!";
    }
}
#-----------------------------------------------------------------
sub get_files {
    my($f) = $File::Find::name;
    return if $_ eq "Icon\n";
    return if $_ eq 'filelog';  # you may not like this, i do :)
    if (-d $f) {
        create_dir($f, 1);
    } elsif (-f _) {
        $files{$f} = new_dir($f);
    }
}
#-----------------------------------------------------------------
sub run_files {
    $num2 = $num = scalar keys %files;
    $bar->data({MinV => '0', MaxV => $num});
    foreach my $f (sort keys %{$_[0]}) {
        if ($num2 % 10 == 0) {
            $bar->data({
                Cap2 => "$num2 Files Remaining",
                Valu => ($num - $num2)
            });
        }
        run_file($f, $files{$f});
        $num2--;
    }
    $bar->close_window();
}
#-----------------------------------------------------------------
sub run_file {
    my($main, $new) = @_;
    my($z, %d, $l, $x, $n, $c);
    local(*F);
    $c = 0;

    foreach my $ext (@ext) {
        if ($ext eq 'NONE') {
            $n = $ext;
            next;
        }
        $c++ if $main =~ /\.$ext$/;
    }

    if    ($n && $main !~ /\./) {
    } elsif (!$c) {
        copy($main, $new) or die "$main -> $new: $!";
        return;
    }

    open(F, "<$main") or die "$main: $!";
    
    # get directives
    while (defined($l = <F>)) {
        last if ($l !~ /^\#/ || $l =~ /^\#!\//);
        if ($l =~ /^#misc: (.*)$/) {
            $d{'misc'} .= $1."\n";
        } elsif ($l =~ /^#scrp:/) {
            while (defined($x = <F>)) {
                last if ($x =~ /^#/);
                $d{'scrp'} .= $x;
            }
        } elsif ($l =~ /^#(\w{4}): (.*)$/) {
            $d{$1} = $2;
        }
        $z++;
    }

    if (exists($d{'omit'})) {
        $d{'omit'} = {map({($_ => $_)} split(/:/, $d{'omit'}))};
    }

    if (!$z) {
        close(F);
        copy($main, $new) or die "$main -> $new: $!";
    } else {
        my($text) = join('', <F>);
        close(F);
        $d{'modi'} = strftime(
            '%A, %B %d, %Y', localtime((stat($main))[9])
        );

        open(F, ">$new") or die "$new: $!";
        my($oldfh) = select(F);

        print do_template($d{'type'} || $default, $text, $new, \%d);

        select($oldfh);
        close(F);
    }
}
#-----------------------------------------------------------------
sub get_template {
    my($temp, $page, $t) = @_;
    local(*T);
    open(T, "<${prefs_dir}${temp}:$page") or die "$temp $page: $!";
    $t = join('', <T>);
    close(T);
    $t;
}
#-----------------------------------------------------------------
sub final_process {
    my($temp, $h, $text, $f, $lib, $t) = @_;
    $lib = "${prefs_dir}${temp}:lib";
    if (!exists($lib{$temp}) && -e $lib) {
        local(*T);
        open(T, "<$lib") or die "$lib: $!";
        $t = join('', <T>);
        close(T);
        $lib{$temp}++;
    }
    return $h . $text . $f if !exists($lib{$temp});

    {
        local($^W) = 0;
        *process_it = eval($t);
        die $@ if $@;
    }
    return join('', process_it($h, $text, $f));
}
#-----------------------------------------------------------------
sub do_template {
    my($temp, $text, $new, $d, $h, $f) = @_;

    $d->{'filename'} = $new;
    $d->{'filename'} =~ s/^$new_dir//;
    $d->{'filename'} =~ s|:|/|g;

    $d->{'extra'} = $h = $f = '';

    $d->{'extra'} .= qq(<BASE TARGET="$$d{'targ'}">\n) if exists($d->{'targ'});
    if (exists($d->{'scrp'})) {
        $d->{'extra'} .= "<SCRIPT>\n<!--\n$$d{'scrp'}\n// -->\n</SCRIPT>\n";
    }

    $d->{'onld'} = qq[ onLoad="$$d{'onld'}"] if exists($d->{'onld'});

    # temporary
    $d->{'base'} = $d->{'base'} ? qq[<BASE HREF="$d->{'base'}">] : '';
    #'http://pudge.net/';

    if (!exists($d->{'omit'}{'head'})) {
        $temp{'head'}{$temp} = get_template($temp, 'head')
            if !exists($temp{'head'}{$temp});
        $h = $temp{'head'}{$temp};
        {
            local($^W) = 0;
            $h =~ s/%%(.*?)%%/ exists($d->{$1}) ? $d->{$1} : '' /gse;
        }
    } elsif (exists($d->{'extra'})) {
        print $d->{'extra'};
    }

    if (!exists($d->{'omit'}{'foot'})) {
        $temp{'foot'}{$temp} = get_template($temp, 'foot')
            if !exists($temp{'foot'}{$temp});
        $f = $temp{'foot'}{$temp};
        {
            local($^W) = 0;
            $f =~ s/%%(.*?)%%/ exists($d->{$1}) ? $d->{$1} : '' /gse;
        }
    }

    return final_process($temp, $h, $text, $f);
}
#-----------------------------------------------------------------
sub upload_files {
    SetFrontProcess(GetCurrentProcess());
    my($upload) = (MacPerl::Answer(
        'Upload files to remote server?', 'OK', 'Manual', 'Cancel'
    ));

    if ($upload) {
        if ($process == 1) {
            $upload_dir = MacPerl::Ask(
                'Please select the upload directory', $upload_dir
            );
        }
    }

    if (!$upload_dir) {
        MacPerl::Answer('Upload cancelled, no upload directory defined');
        return;
    }

    upload_ftp() if ($upload == 2);
    manual_ftp() if ($upload == 1);
}
#-----------------------------------------------------------------
sub start_ftp {
    require Mac::Apps::Anarchie;
    $ftp = Mac::Apps::Anarchie->new($ftpapp);
    $ftp->switchapp(0);
    SetFrontProcess(GetCurrentProcess());

    if (my($netrc) = Net::Netrc->lookup($host)) {
        ($user, $pass) = ($netrc->lpa)[0,1];
    }

    $ftp->user($user || MacPerl::Ask('User name?'));
    if (!$pass) {
        require Mac::Password;
        my $get = Mac::Password->new();
        $pass = $get->password;
        $get->DESTROY;
    }

    $ftp->host($host);
    $ftp->pass($pass);
    $ftp->switchapp(1);
}
#-----------------------------------------------------------------
sub manual_ftp {
    start_ftp();
    $ftp->list('a', $upload_dir, 1);
    MacPerl::DoAppleScript(<<EOS);
tell application "Finder"
    open alias "$new_dir"
end tell
EOS
}
#-----------------------------------------------------------------
sub upload_ftp {
    start_ftp();
    find(\&do_ftp_files, $new_dir);
}
#-----------------------------------------------------------------
sub do_ftp_files {
    my($lfile, $rfile, $file) = ($File::Find::name);
    ($rfile = $lfile) =~ s/$new_dir/$upload_dir/;
    ($file = $lfile) =~ s/$new_dir/$main_dir/;
    $rfile =~ s|:|/|g;
    my $stat = (stat($file))[9];
    if (    !-d $lfile
                &&
            (
                $doall
                    ||
                (
                    !exists($log{$file})
                        ||
                    $log{$file} < $stat
                )
            )
        ) {
        $ftp->store($lfile, $rfile, -T _ ? 0 : 1);
        $log{$file} = $stat;
    } elsif (-d _ && $mkdir) {
        # make new directory, close windows, suppress errors to STDERR
        local(*S);
        local($^W) = 0;
        my($tfile) = 'Dev:Null';  # add File::Spec->devnull
        open(S, ">&STDERR");
        close(STDERR);
        $ftp->mkdir($rfile);
        $ftp->close();
        open(STDERR, ">&S");
    }
}
#-----------------------------------------------------------------
sub create_dir {
    my($d, $x) = @_;
    $d = new_dir($d) if ($x && $x == 1);
    unless (-d $d) {
        mkdir($d, 0777) or die "$d: $!";
    }
}
#-----------------------------------------------------------------
sub new_dir {
    my($d) = $_[0];
    $d =~ s/^$main_dir/$new_dir/;
    return($d);
}
#-----------------------------------------------------------------
sub get_folder {
    my($prompt, $default) = @_;
    if ($nav) {
        my($opt, $fold, $file);
        Mac::Navigation->import();
        $opt = NavGetDefaultDialogOptions();
        $opt->message($prompt);
        $opt->windowTitle("Select Folder");
        $fold = NavChooseFolder($default, $opt) or die $^E;
        $file = $fold->file(1);
        $file =~ s/:$//;
        $file;
    } else {
        require 'GUSI.ph';
        MacPerl::Choose(
          GUSI::AF_FILE(), 0, $prompt, '',
          GUSI::CHOOSE_DIR() +
              ($default ? GUSI::CHOOSE_DEFAULT() : 0),
          $default
        );
    }
}
#-----------------------------------------------------------------
__END__

=head1 NAME

webset.plx

=head1 DESCRIPTION

This is a little program called webset.plx.

It processes HTML files, adding headers/footers/etc., and uploads them
to the site of your choice.

An HTML file to be processed would look like this:

    #type: default
    #crea: Monday, Jan 1, 1904
    #titl: My Page!
    #targ: Pad
    #onld: some_script();
    #omit: foot:head
    #misc: <META HTTP-EQUIV="Refresh" CONTENT=120>
    #scrp:
    function some_script () {
        alert('Alert!');
    }
    #

    <H2>This is my Page!</H2>

There we give a type (which templates to use), a file creation date,
a title, a default target for links, a script to load on page loading,
what to omit (foot and/or head), and a script to put in the HEAD.

In the Preferences folder of your System Folder, make a "webset prefs"
folder.  In that, make a directory for your template files, called foot 
and head.  A sample:

    <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2 Draft//EN">
    <HTML>
    <HEAD>
    <TITLE>Pudge's Pad: %%titl%%</TITLE>
    
    <!--
    Created on    : %%crea%%
    Last modified : %%modi%%
    by            : Pudge, pudge@pobox.com
    with          : BBEdit and MacPerl
    -->
    
    %%misc%%
    <BASE HREF="http://pudge.net/">
    %%extra%%
    </HEAD>
    
    <BODY BGCOLOR="FFFFFF"%%onld%%>
    <CENTER>
    <IMG SRC="/graphics/ppm.gif" WIDTH="237" HEIGHT="47"
        BORDER="0" ALT="Pudge's Pad">
    <H2>%%titl%%</H2>
    </CENTER>

If you can hack Perl at all, you can probably add new directives
to the list, which is at the top of the program.  Variables to 
be expanded are surrounded by C<%%> as in 
C<%%variable_to_be_expanded%%>.

Also, you can further customize by putting a file called F<lib> file in
your template folder, containing a subroutine to parse the head, body, 
and footer of each file for that template:

    sub {
        my($head, $body, $foot) = @_;
        # do stuff ...
        return($head, $body, $foot);
        # return scalar or list
        # return($head . $body . $foot) is OK too
    }

Before you start, be sure to edit the User Config section of the program.

And back up your work first!  I cannot be blamed for writing bad code; I
was dropped on my head as a child.

=head1 TODO

=over 4

=item *

Alternatively use C<Net::FTP> instead of C<Mac::Apps::Anarchie>, make rest
portable.

=item *

Only upload changed files.  (Done!)

=back

=head1 REQUIRED MODULES

In addition to the standard MacPerl modules, the following modules,
available on CPAN and at C<http://pudge.net/>, are required.

=over 4

=item Mac::Apps::Anarchie

If uploading files.

=item Mac::Apps::PBar

=item Mac::Apps::Launch

=item Mac::AppleEvents::Simple

=item Net::Netrc 2.08

Includes Mac changes.  You can remove this part and revert to putting
in your own username and password.

=back

=head1 AUTHOR

Chris Nandor E<lt>pudge@pobox.comE<gt>, http://pudge.net/

Copyright (c) 1999 Chris Nandor.  All rights reserved.  This program is
free software; you can redistribute it and/or modify it under the terms
of the Artistic License, distributed with Perl.

=head1 HISTORY

=over 4

=item 1.00 (14 March 1999)

Added Net::Netrc stuff.  Cool.

Fixed handling of Icon files.


=item 0.98 (10 February 1999)

Fix a few things up with password and switching.  Add $doall option.

=item 0.97 (29 October 1998)

Use Alan Fry's C<Mac::Password> to get password for FTPing.

=item 0.96 (12 August 1998)

Minor bug fix to Navigation routines, and duplicate calls to C<process()>.

=item 0.95 (12 August 1998)

Use L<Mac::Navigation> if available to get directories.

If directories chosen manually, prompt for different upload directory.

=item 0.94 (09 August 1998)

Use C<-T> to test if file is binary or text for upload mode.

Allow processing of subdirectories; will not give option to upload if this
is selected.

=item 0.93 (04 August 1998)

I think I got that part right now.  Only files changed since the last upload
should be uploaded.

Made user-defined variable C<$ftpapp> so users can choose Fetch or
Anarchie at the top of the program.

=item 0.92 (30 July 1998)

First attempt at only uploading changed files.

=item 0.91 (18 July 1998)

Fixed bug to process only files with certain extensions.

=item 0.90 (18 July 1998)

First public release.  Major changes from previous copy, started in
February 1997.

=back

=head1 VERSION

Version 1.00 (14 March 1999)

=cut