filemorph

<plist version="1.0">
<dict>
	<key>CFBundleDevelopmentRegion</key>
	<string>English</string>
	<key>CFBundleExecutable</key>
	<string>FileMorph</string>
	<key>CFBundleGetInfoString</key>
	<string>FileMorph $1 (c) 2015 WordTech Communications LLC</string>
 <key>NSPrincipalClass</key>
        <string>NSApplication</string>
<key>NSHighResolutionCapable</key>
	<true/>
	<key>LSMinimumSystemVersionByArchitecture</key>
	<dict>
	<key>x86_64</key>
................................................................................
	<key>LSArchitecturePriority</key>
<array>
<string>x86_64</string>
</array>
	<key>LSApplicationCategoryType</key>
	<string>public.app-category.utilities</string>
	<key>NSHumanReadableCopyright</key>
	<string>(c) 2015 WordTech Communications LLC</string>
	<key>CFBundleIconFile</key>
	<string>FileMorph.icns</string>
	<key>CFBundleInfoDictionaryVersion</key>
	<string>6.0</string>
	<key>CFBundleDocumentTypes</key>
	<array>
		<dict>

<plist version="1.0">
<dict>
	<key>CFBundleDevelopmentRegion</key>
	<string>English</string>
	<key>CFBundleExecutable</key>
	<string>FileMorph</string>
	<key>CFBundleGetInfoString</key>
	<string>FileMorph $1 (c) 2016 WordTech Communications LLC</string>
 <key>NSPrincipalClass</key>
        <string>NSApplication</string>
<key>NSHighResolutionCapable</key>
	<true/>
	<key>LSMinimumSystemVersionByArchitecture</key>
	<dict>
	<key>x86_64</key>
................................................................................
	<key>LSArchitecturePriority</key>
<array>
<string>x86_64</string>
</array>
	<key>LSApplicationCategoryType</key>
	<string>public.app-category.utilities</string>
	<key>NSHumanReadableCopyright</key>
	<string>(c) 2016 WordTech Communications LLC</string>
	<key>CFBundleIconFile</key>
	<string>FileMorph.icns</string>
	<key>CFBundleInfoDictionaryVersion</key>
	<string>6.0</string>
	<key>CFBundleDocumentTypes</key>
	<array>
		<dict>

# FileMorph: Rename files, edit attributes

#Copyright (C) 2016 WordTech Communications LLC

#MIT license

#let's get started

use FindBin qw($Bin);
use Config;
................................................................................
use File::Copy::Recursive qw(dircopy );
use Env qw(HOME);
use File::Path qw(remove_tree);
use File::Copy::Recursive qw (rmove);

BEGIN {

    if ($Config{osname} eq "darwin") {
        my $frameworkpath = "$Bin/Contents/Frameworks/Tcl.framework/Tcl";
        $ENV{'PERL_TCL_DL_PATH'} = $frameworkpath;
    }
    if ($Config{osname} eq "MSWin32") {
        my $frameworkpath = "$Bin/Tcl/bin/tcl86.dll";
        $ENV{'PERL_TCL_DL_PATH'} = $frameworkpath;
    }

}

#use strict;
................................................................................
use Time::Local;
use POSIX qw( strftime );
use File::Basename qw(fileparse basename dirname);
use LWP::Simple;
use Config::IniFiles;
use File::Temp qw(tempfile);

Tkx::set('::argv0', $ARGV[0] || "");
Tkx::catch('console hide');

Tkx::package_require('tkdnd');
Tkx::package_require('Img');
Tkx::package_require('regproc');
Tkx::package_require('machelp');
Tkx::package_require('softwareupdate');
................................................................................
our $clocktime;
our $modtime;
our $timeofday;
our $icon;
our $fileimage;
our $folderimage;

$datetime = strftime("% m/%d/ % Y", localtime);

#initialize the app
&startUp;
&makeImage;

@filelist = ();

if ($IS_AQUA) {
    Tkx::interp_alias("", "::tk::mac::OpenDocument", "", [\&openDoc]);
    Tkx::interp_alias("", "::tk::mac::ShowHelp",     "", [\&showHelp]);
    Tkx::interp_alias("", "bgerror",                 "", [\&errlog]);
}

if ($IS_WINDOWS) {
    Tkx::package_require("twapi");
}

#draw the GUI
our $mw = Tkx::widget->new(".");
Tkx::wm_title($mw, "FileMorph");
$mw->g_wm_withdraw;
if ($IS_WINDOWS) {
    $mw->g_wm_protocol(WM_DELETE_WINDOW => \&shutdown);
    $mw->g_wm_iconphoto(-default => $icon);
}

#menubar code
my $menubar = $mw->new_menu();
Tkx::option_add("*tearOff", 0);
our $applemenu;
if ($IS_AQUA) {
    $applemenu = $menubar->new_menu(-name => "apple");
}
my $searchmenu = $menubar->new_menu();
my $helpmenu = $menubar->new_menu(-name => "help");

if ($IS_AQUA) {
    $menubar->add_cascade(
        -label => "FileMorph",
        -menu  => $applemenu,
    );

................................................................................
    );
    $helpmenu->add_command(
        -label   => "Check for Updates",
        -command => \&checkUpdate,
    );
}

$mw->configure(-menu => $menubar);

#bindings
if ($IS_AQUA) {
    $mw->g_bind("<Command-W>", sub {$mw->g_wm_state("withdrawn");});
    $mw->g_bind("<Command-w>", sub {$mw->g_wm_state("withdrawn");});
}

#main window frame, listbox and notebook

my $toolbar = $mw->new_ttk__frame(-padding => 5);
$toolbar->g_pack(
    -fill   => "both",
    -expand => "no",
    -side   => "top",
);

my $folderbutton = $toolbar->new_ttk__button(
................................................................................
);
$folderbutton->g_pack(
    -expand => "no",
    -fill   => "both",
    -side   => "left"
);

Tkx::DynamicHelp__register($folderbutton, "balloon", "Select the directory");

my $filebutton = $toolbar->new_ttk__button(
    -image     => $fileimage,
    -style     => "Toolbutton",
    -takefocus => 0,
    -command   => \&setFile,
);
................................................................................

$filebutton->g_pack(
    -expand => "no",
    -fill   => "both",
    -side   => "left"
);

Tkx::DynamicHelp__register($filebutton, "balloon", "Select the file");

my $sep = $toolbar->new_ttk__separator(-orient => "vertical");
$sep->g_pack(
    -fill   => "both",
    -expand => "no",
    -side   => "top",
);

my $frame = $mw->new_ttk__frame;
................................................................................

$frame->g_pack(
    -fill   => "both",
    -expand => "yes",
    -side   => "bottom",
);

my $topsep = $frame->new_ttk__separator(-orient => "vertical");
$topsep->g_pack(
    -fill   => "both",
    -expand => "no",
    -side   => "top",
);

my $textframe = $frame->new_ttk__panedwindow(-orient => "horizontal",);

$textframe->g_pack(
    -fill   => "both",
    -expand => "yes",
    -side   => "top",
);

................................................................................
);
$listbox->g_pack(
    -fill   => "both",
    -expand => "yes",
    -side   => "left",
);

Tkx::tkdnd__drop___target_register($listbox, "*");
Tkx::bind($listbox, "<<Drop:DND_Files>>",
    [sub {&selectFileSystem;}, Tkx::Ev("%D")]);

my $noteframe = $textframe->new_ttk__frame;
$noteframe->g_pack(
    -fill   => "both",
    -expand => "yes",
    -side   => "right",
);
................................................................................
my $scrollhouse = $boxframe->new_ttk__frame;
$scrollhouse->g_pack(
    -fill   => "y",
    -expand => "no",
    -side   => "right",
);

my $scrollbar = $scrollhouse->new_ttk__scrollbar(-orient => 'vertical');
$scrollbar->configure(-command => [$listbox, "yview"]);
$scrollbar->g_pack(
    -fill   => "y",
    -expand => "no",
    -side   => "right",
);

$listbox->configure(-yscrollcommand => [$scrollbar, "set"]);

#notebook components
my $extension   = $notebook->new_ttk__frame;
my $replacement = $notebook->new_ttk__frame;
my $text        = $notebook->new_ttk__frame;
my $date        = $notebook->new_ttk__frame;
my $case        = $notebook->new_ttk__frame;
my $attributes  = $notebook->new_ttk__frame;

#UI to modify file extensions
$notebook->add($extension, -text => "Extension");
my $exsrclabel = $extension->new_ttk__label(-text => "Extension:");
my $exsrcentry = $extension->new_ttk__entry(-textvar => \$sourceext);
my $extargetlabel =$extension->new_ttk__label(-text => "New Extension Name:");

my $extargetentry = $extension->new_ttk__entry(-textvar => \$targetext);
my $extchange = $extension->new_ttk__button(
    -text    => "Change",
    -command => \&changeExtension
);
my $extundo = $extension->new_ttk__button(
    -text    => "Undo",
    -command => \&undoExtension
);
my $extclear = $extension->new_ttk__button(
    -text    => "Clear",
    -command => sub {$sourceext = ""; $targetext = "";}
);

our @extarray = (
    $exsrclabel, $exsrcentry, $extargetlabel, $extargetentry,
    $extchange, $extundo, $extclear
);

................................................................................
        -fill   => "both",
        -expand => "no",
        -side   => "top",
    );
}

#UI to replace text in file name
$notebook->add($replacement, -text => "Replace Text");
my $repsrclabel = $replacement->new_ttk__label(-text => "Text:");
my $repsrcentry = $replacement->new_ttk__entry(-textvar => \$srcstring);

my $reptargetlabel =$replacement->new_ttk__label(-text => "Replacement Text:");
my $reptargetentry = $replacement->new_ttk__entry(-textvar => \$targetstring);
my $repbutton = $replacement->new_ttk__button(
    -text    => "Change",
    -command => \&replaceString
);
my $repundo = $replacement->new_ttk__button(
    -text    => "Undo",
    -command => \&undoReplaceString
);
my $repclear = $replacement->new_ttk__button(
    -text    => "Clear",
    -command => sub {$srcstring = ""; $targetstring = "";},
);

our @reparray = (
    $repsrclabel, $repsrcentry, $reptargetlabel, $reptargetentry,
    $repbutton, $repundo, $repclear
);

................................................................................
        -fill   => "both",
        -expand => "no",
        -side   => "top",
    );
}

#UI to add text to file name
$notebook->add($text, -text => "Add Text");
my $txtsrclabel = $text->new_ttk__label(-text => "Text:");
my $txtsrcentry = $text->new_ttk__entry(-textvar => \$prependstring);
my $txtbefore = $text->new_ttk__radiobutton(
    -text     => "Before",
    -variable => \$prepend,
    -value    => 0
);
my $txtafter = $text->new_ttk__radiobutton(
    -text     => "After",
    -variable => \$prepend,
    -value    => 1
);
my $txtbutton =
  $text->new_ttk__button(-text => "Change", -command => \&addString);
my $txtundo = $text->new_ttk__button(
    -text    => "Undo",
    -command => \&undoAddString
);
my $txtclear = $text->new_ttk__button(
    -text    => "Clear",
    -command => sub {$prependstring = "";}
);

$prepend = 1;

our @txtarray = (
    $txtsrclabel, $txtsrcentry, $txtbefore, $txtafter,
    $txtbutton,   $txtundo,     $txtclear
................................................................................
        -fill   => "both",
        -expand => "no",
        -side   => "top",
    );
}

#UI to modify file attributes
$notebook->add($attributes, -text => "Date");

my $todaylabel = $attributes->new_ttk__label(-text => "Date:",);
my $today = $attributes->new_widget__dateentry(
    -textvariable => \$datetime,
    -font         => \&Tkx::TkDefaultFont
);
my $timelabel = $attributes->new_ttk__label(
    -text => "Time (enter HH:MM, military-style, i.e. 23:00 for 11:00 PM)",);

my $timeentry = $attributes->new_ttk__entry(-textvariable => \$clocktime,);
my $attbutton = $attributes->new_ttk__button(
    -text    => "Change",
    -command => \&changeTime
);

our @attarray = ($todaylabel, $today, $timelabel, $timeentry, $attbutton);

foreach (@attarray) {
    $_->g_pack(
        -fill   => "both",
        -expand => "no",
        -side   => "top",
    );
................................................................................

if ($IS_AQUA) {
    Tkx::fullscreen__fullscreen($mw);
}

Tkx::after(50);

Tkx::regproc__readLic($appname, $appversion);

#This is necessary to get the listbox to draw; sometimes it does not render until the mouse hovers over it
Tkx::focus(-force => $listbox);

if ($IS_AQUA) {
    &createAppleScriptCommands;
}

Tkx::MainLoop();
exit;
................................................................................
LPn+DvFm3yEO1npKvqflTPvelmAHwH8AtJzPuEp4NAYnVANOnPZumzGjcr1ZO0/y
XSdBwFlx+1vFy0ID8NPX1dmx50yw85lDcigCT6nHgReJoM3TBHjQD4w7OeMR2WFe
w6c9HzQ/0nLBeuDObzRqZvaMONzMzHYFtpXt6/ONT9/8qPvl7Xu7CJ4ptvks8vzn
Rh7MMzQfd+eHMVWayECoHnd4B5/gLNmx+X7r++u+1tnW2X/6VEv3/46cOHdi/9Hm
5s/Odl9CG36qy3+n7cNBwLT/cZc0xhw2TSQBG/FY/qKh68eX3Db72Nybao/vOdDc
iv8jJFiCpmSL1XvYCU504f8ByyY/CIX5bZoAAAAASUVORK5CYII=
";
    $icon = Tkx::image_create_photo(-data => $data);

    my $folderdata = "
                R0lGODlhGAAYAPABAAAAAP///yH5BAEKAAEAIf4aQ3JlYXRlZCB3aXRoIEdJTVAg
b24gYSBNYWMALAAAAAAYABgAAAI1hI8Wy70JgZshJurOtFzmHm0ghJXVZVJkKo7u
C8cr28z0g944ojP2/aMFWcNU0SRLxk5KSQEAOw==
";
    $folderimage = Tkx::image_create_photo(-data => $folderdata);

    my $filedata = "
                R0lGODlhEgAYAPABAAAAAP///yH5BAEKAAEAIf4aQ3JlYXRlZCB3aXRoIEdJTVAg
b24gYSBNYWMALAAAAAASABgAAAI1hI8Qy5GvmoNJHjkv0+1tg0EL93nkSJ1ZioVV
270wisyl6tb2Cu6eL5v9bENhEJZKKpdMQwEAOw==
                ";
    $fileimage = Tkx::image_create_photo(-data => $filedata);

}

#check filelist for error handling
sub checkfilelist {

    if (scalar(@filelist) == 0) {

        errlog("Please select a file or directory to run this operation.");

    }
}

#"about application"command
sub Tkx::tkAboutDialog {

    our $about = $mw->new_toplevel;

    Tkx::wm_title($about, "About FileMorph");

    my $aboutframe  = $about->new_frame;
    my $buttonframe = $about->new_frame;

    $aboutframe->g_pack(
        -fill   => "both",
        -expand => "yes",
        -side   => "top",
    );

    $buttonframe->g_pack(
        -fill   => "both",
        -expand => "yes",
        -side   => "bottom",
    );

    my $logolabel = $aboutframe->new_label(
        -image => $icon,
        -bg    => "gray95",
        -pady  => "2"
    );

    $logolabel->g_pack(
        -fill   => "both",
        -expand => "yes",
        -side   => "top",
    );

    my $label1 = $aboutframe->new_label(
        -text => "FileMorph $appversion",
        -font => "-weight bold",
        -pady => "2"
    );

    $label1->g_pack(
        -fill   => "both",
        -expand => "no",
        -side   => "top",
    );

    my $label2 = $aboutframe->new_label(
        -text => "Easy File Modification",
        -pady => "2"
    );

    $label2->g_pack(
        -fill   => "both",
        -expand => "no",
        -side   => "top",
    );

    my $label3 = $aboutframe->new_label(
        -text => "Copyright (c) 2016 WordTech Communications LLC",
        -pady => "5",
    );

    $label3->g_pack(
        -fill   => "both",
        -expand => "no",
        -side   => "top",
    );

    my $label4 = $aboutframe->new_label(
        -text => "http://www.codebykevin.com/FileMorph.html",
        -fg   => "blue",
        -pady => "2"
    );

    $label4->g_pack(
        -fill   => "both",
        -expand => "no",
        -side   => "top",
    );

    my $label5 = $aboutframe->new_label(
        -text =>
"See Acknowledgements in FileMorph Help\nfor additional credits\nand see History in FileMorph Help\nfor changes in this version",
        -pady => "2",
    );

    $label5->g_pack(
        -fill   => "both",
        -expand => "no",
        -side   => "top",
    );

    $label4->g_bind(
        "<Button-1>",
        sub {
            Tkx::xplat__launch("http://www.codebykevin.com/filemorph.html");
        }
    );

}

#handle errors in Tk
sub errlog {
    my $msg = shift;
    if ($IS_AQUA) {
        system("syslog -s -l Error FileMorph: An error occurred: $msg\n");
    }
................................................................................
"Cannot run operation without text.Please enter text into the appropriate entry field to run this operation."
    );
}

#update display of files
sub updateFileDisplay {

    $listbox->delete(0, "end");
    if (scalar(@filelist) > 1) {
        @filelist = <"$folder/*">;
    }
    foreach (@filelist) {
        $listbox->insert("end", "$_");
    }
}

#set search directory
sub setDir {
    $listbox->delete(0, "end");
    $folder = Tkx::tk___chooseDirectory(-parent => $mw);
    return unless $folder;
    @filelist = <"$folder/*">;
    foreach (@filelist) {
        $listbox->insert("end", "$_");
    }
    return "$folder";
}

#set file to change
sub setFile {

    $listbox->delete(0, "end");
    my $filename = Tkx::tk___getOpenFile(-parent => $mw);
    return unless $filename;
    @filelist = ();
    push(@filelist, $filename);
    foreach (@filelist) {
        $listbox->insert("end", "$_");
    }
    return @filelist;
}

#change all file extensions in a directory
sub changeExtension {

    &checkfilelist;

    return if (scalar(@filelist) == 0);

    if (scalar(@filelist) == 1) {

        &fileErrMsg;
        return;
    }

    if ($exsrcentry->get() eq "" || $extargetentry->get() eq "") {
        &dataErrMsg;
        return;
    }

    $sourceext = $exsrcentry->get();
    $targetext = $extargetentry->get();

................................................................................
}

#undo operation of change file extension
sub undoExtension {

    &checkfilelist;

    return if (scalar(@filelist) == 0);

    if (scalar(@filelist) == 1) {

        &fileErrMsg;
        return;
    }

    if ($exsrcentry->get() eq "" || $extargetentry->get() eq "") {
        &dataErrMsg;
        return;
    }

    $sourceext = $exsrcentry->get();
    $targetext = $extargetentry->get();

................................................................................
}

#replace string in file name
sub replaceString {

    &checkfilelist;

    return if (scalar(@filelist) == 0);

    if (scalar(@filelist) == 1) {

        &fileErrMsg;
        return;
    }

    if ($repsrcentry->get() eq "") {
        &dataErrMsg;
        return;
    }

    $srcstring    = $repsrcentry->get();
    $targetstring = $reptargetentry->get();

    if ($reptargetentry->get() eq "") {
        my $changeQuestion;
        $changeQuestion = Tkx::tk___messageBox(
            -parent => $mw,
            -title  => "Confirm Removal of Text",
            -type   => "yesno",
            -icon   => "info",
            -message =>
              "Do you want to strip out \"$srcstring\"with no replacement?",
            -detail => "This operation cannot be undone.",
        );

        if ($changeQuestion eq "no") {
            return;
        }
    }

    foreach (@filelist) {
        next unless -f $_;
        my $filename    = $_;
................................................................................
}

#undo replace string in filename
sub undoReplaceString {

    &checkfilelist;

    return if (scalar(@filelist) == 0);

    if (scalar(@filelist) == 1) {

        &fileErrMsg;
        return;
    }

    if ($repsrcentry->get() eq "") {
        &dataErrMsg;
        return;
    }

    if ($reptargetentry->get() eq "") {
        my $sorryQuestion;
        $sorryQuestion = Tkx::tk___messageBox(
            -parent  => $mw,
            -title   => "Removal Operation Cannot Be Undone",
            -icon    => "info",
            -message => "You confirmed removing the string \"$srcstring.\"",
            -detail  => "This operation cannot be undone.",
................................................................................
}

#replace string in file name
sub addString {

    &checkfilelist;

    return if (scalar(@filelist) == 0);

    if (scalar(@filelist) == 1) {

        &fileErrMsg;
        return;
    }

    if ($txtsrcentry->get() eq "") {
        &dataErrMsg;
        return;
    }

    $prependstring = $txtsrcentry->get();

    foreach (@filelist) {
        next unless -f $_;
        if ($prepend == 0) {

            my $filename    = $_;
            my $newname     = $filename;
            my $basename    = basename($filename);
            my $dirname     = dirname($filename);
            my $newbasename = $basename;
            $newbasename = $prependstring . $basename;
            $newname =~ s/$basename/$newbasename/i;
            move $filename, $newname;
        }

        if ($prepend == 1) {
            my $filename = $_;

            my @components = split(/\./, $filename);
            my $newname =
              $components[0] . $prependstring . "\." . $components[1];
            move $filename, $newname;
        }
    }
    &updateFileDisplay;
}

#replace string in file name
sub undoAddString {

    &checkfilelist;

    return if (scalar(@filelist) == 0);

    if (scalar(@filelist) == 1) {

        &fileErrMsg;
        return;
    }

    if ($txtsrcentry->get() eq "") {
        &dataErrMsg;
        return;
    }

    $prependstring = $txtsrcentry->get();

    foreach (@filelist) {
................................................................................
}

#change modification time of files
sub changeTime {

    &checkfilelist;
    my $validation = &validateTime;
    return if ($validation == 0);
    return if (scalar(@filelist) == 0);

    my $changeQuestion;
    $changeQuestion = Tkx::tk___messageBox(
        -parent  => $mw,
        -title   => "Change Modification Time",
        -type    => "yesno",
        -icon    => "info",
        -message => "Do you want to change the file modification time?",
        -detail  => "This operation cannot be undone.",
    );

    if ($changeQuestion eq "no") {
        return;
    }
    if ($changeQuestion eq "yes") {
        my @datearray  = split(/\//, $datetime);
        my @clockarray = split(/\:/, $clocktime);
        my $hour;
        my $second = "00";
        if ($timeofday == 1) {
            $hour = $clockarray[0] + 12;
        }
        else {
            $hour = $clockarray[0];
        }

        $modtime =
          timelocal($second, $clockarray[1], $hour,
            $datearray[1], ($datearray[0] - 1),
            $datearray[2]);
        print $modtime;

        foreach (@filelist) {

            utime $modtime, $modtime, $_;
        }

................................................................................
    }
}

#make sure time is formatted properly
sub validateTime {

    my $time = $timeentry->get();
    if ($time =~ (/\d\d:\d\d/)) {
        return 1;
    }
    else {
        $timeentry->delete(0, "end");

        Tkx::tk___messageBox(
            -parent  => $mw,
            -title   => "Incorrect Time Format",
            -icon    => "info",
            -message => "Incorrect Time Format",
            -detail  => "Please enter the time in HH:MM format, i.e. 12:30.",
................................................................................
sub selectFileSystem {

    my $fname = shift;
    my @name  = Tkx::SplitList($fname);
    my $path  = join "", @name;
    $folder = $path;

    if (-f $folder) {
        $listbox->delete(0, "end");
        @filelist = ();
        push(@filelist, $folder);
        foreach (@filelist) {
            $listbox->insert("end", "$_");
        }
    }

    if (-d $folder) {

        $listbox->delete(0, "end");
        @filelist = <"$folder/*">;
        foreach (@filelist) {
            $listbox->insert("end", "$_");
        }

        return $folder;
    }

    return $folder;
}
................................................................................
}

#initialize the app
sub startUp {

    $appname    = 'FileMorph';
    $appversion = '2.7';
    &Tkx::machelp__setAppName($appname, $appversion);
    &Tkx::softwareupdate__setAppName($appname);
    &Tkx::softwareupdate__setVersion($appname, $appversion);

    #check for app support directory
    our $prefdir = Tkx::xplat__appconfig("FileMorph");
    mkdir $prefdir unless (-d $prefdir);
}

#check version of installed software
sub checkUpdate {

    &Tkx::softwareupdate__setIcon($icon);
    &Tkx::softwareupdate__checkingForUpdates;

    my $url    = "http://www.codebykevin.com/filemorph.ini";
    my $tmp    = new File::Temp(UNLINK => 1, SUFFIX => ".ini");
    my $parser = get($url);
    print $tmp $parser;
    close $tmp;

    my $cfg = Config::IniFiles->new(
        -file          => $tmp,
        -allowcontinue => 1
      )
      or sub {

        Tkx::tk___messageBox(
            -parent  => $mw,
            -title   => "Error",
            -type    => "ok",
            -icon    => "warning",
            -message => "Cannot run operation on file",
            -detail =>
"An error occurred in retrieving update information.\nPlease try again later",
        );
        return;

      };

    my $versionnumber = $cfg->val('application', 'version');
    $versionnumber = substr($versionnumber, 0, -2);
    my $minOS     = $cfg->val('application', 'osversion');
    my $changelog = $cfg->val('application', 'changelog');

    if ($IS_AQUA) {

        my $hostOS = `sw_vers -productVersion`;

        if ($hostOS < $minOS) {
            Tkx::tk___messageBox(
                -parent  => $mw,
                -title   => "Error",
                -type    => "ok",
                -icon    => "warning",
                -message => "Error!",
                -detail =>
"FileMorph is not supported on Mac OS X $hostOS. The minimum supported OS version is $minOS.",
            );
        }
    }

    if ($appversion < $versionnumber) {
        if ($IS_AQUA) {
            &Tkx::softwareupdate__updatePitchPerl($appname,
                $versionnumber, $appversion, $changelog);
        }
        if ($IS_WINDOWS) {
            &Tkx::softwareupdate__winPitch($appname, $versionnumber,
                $appversion);
        }

    }
    else {
        &Tkx::softwareupdate__upToDate();
    }
}

#-----AppleScript handlers------$

if ($IS_AQUA) {

    sub createAppleScriptCommands {
        Tkx::aem__installeventhandler("CoKv", "fMdr", \&scriptSetDir);
        Tkx::aem__installeventhandler("CoKv", "fMfl", \&scriptSetFile);
        Tkx::aem__installeventhandler("CoKv", "oExt", \&scriptOldExt);
        Tkx::aem__installeventhandler("CoKv", "nExt", \&scriptNewExt);
        Tkx::aem__installeventhandler("CoKv", "rExt", \&scriptChangeExt);
        Tkx::aem__installeventhandler("CoKv", "oTxt", \&scriptOldText);
        Tkx::aem__installeventhandler("CoKv", "nTxt", \&scriptNewText);
        Tkx::aem__installeventhandler("CoKv", "cTxt", \&scriptChangeText);
        Tkx::aem__installeventhandler("CoKv", "beTx", \&scriptAddedText);
        Tkx::aem__installeventhandler("CoKv", "afTx", \&scriptPrefixOrSuffix);
        Tkx::aem__installeventhandler("CoKv", "adTx", \&scriptAddText);
        Tkx::aem__installeventhandler("CoKv", "tmDa", \&scriptSetTime);
        Tkx::aem__installeventhandler("CoKv", "cTme", \&scriptFileTime);
    }
}

sub scriptSetDir {
    my $path = shift;

    #join with spaces
    foreach (@_) {
        $path = $_ . ' ';
    }

    $folder = $path;

    if (-f $folder) {
        $listbox->delete(0, "end");
        @filelist = ();
        push(@filelist, $folder);
        foreach (@filelist) {
            $listbox->insert("end", "$_");
        }
    }

    if (-d $folder) {

        $listbox->delete(0, "end");
        @filelist = <"$folder/*">;
        foreach (@filelist) {
            $listbox->insert("end", "$_");
        }

        return $folder;
    }

    return $folder;
}
................................................................................
sub scriptAddText {
    &addString;
}

sub scriptSetTime {
    my $time;
    $time = shift;
    my @datearray = split(/\//, $time);

    $modtime =timelocal("00", "00", "00", $datearray[1], ($datearray[0] - 1),
        $datearray[2]);
}

sub scriptFileTime {
    return if (scalar(@filelist) == 0);
    foreach (@filelist) {
        utime $modtime, $modtime, $_;
    }
}

#------end of subroutines---------

# FileMorph: Rename files, edit attributes

#Copyright (C) 2017 WordTech Communications LLC

#MIT license

#let's get started

use FindBin qw($Bin);
use Config;
................................................................................
use File::Copy::Recursive qw(dircopy );
use Env qw(HOME);
use File::Path qw(remove_tree);
use File::Copy::Recursive qw (rmove);

BEGIN {

    if ( $Config{osname} eq "darwin" ) {
        my $frameworkpath = "$Bin/Contents/Frameworks/Tcl.framework/Tcl";
        $ENV{'PERL_TCL_DL_PATH'} = $frameworkpath;
    }
    if ( $Config{osname} eq "MSWin32" ) {
        my $frameworkpath = "$Bin/Tcl/bin/tcl86.dll";
        $ENV{'PERL_TCL_DL_PATH'} = $frameworkpath;
    }

}

#use strict;
................................................................................
use Time::Local;
use POSIX qw( strftime );
use File::Basename qw(fileparse basename dirname);
use LWP::Simple;
use Config::IniFiles;
use File::Temp qw(tempfile);

Tkx::set( '::argv0', $ARGV[0] || "" );
Tkx::catch('console hide');

Tkx::package_require('tkdnd');
Tkx::package_require('Img');
Tkx::package_require('regproc');
Tkx::package_require('machelp');
Tkx::package_require('softwareupdate');
................................................................................
our $clocktime;
our $modtime;
our $timeofday;
our $icon;
our $fileimage;
our $folderimage;

$datetime = strftime( "% m/%d/ % Y", localtime );

#initialize the app
&startUp;
&makeImage;

@filelist = ();

if ($IS_AQUA) {
    Tkx::interp_alias( "", "::tk::mac::OpenDocument", "", [ \&openDoc ] );
    Tkx::interp_alias( "", "::tk::mac::ShowHelp",     "", [ \&showHelp ] );
    Tkx::interp_alias( "", "bgerror",                 "", [ \&errlog ] );
}

if ($IS_WINDOWS) {
    Tkx::package_require("twapi");
}

#draw the GUI
our $mw = Tkx::widget->new(".");
Tkx::wm_title( $mw, "FileMorph" );
$mw->g_wm_withdraw;
if ($IS_WINDOWS) {
    $mw->g_wm_protocol( WM_DELETE_WINDOW => \&shutdown );
    $mw->g_wm_iconphoto( -default => $icon );
}

#menubar code
my $menubar = $mw->new_menu();
Tkx::option_add( "*tearOff", 0 );
our $applemenu;
if ($IS_AQUA) {
    $applemenu = $menubar->new_menu( -name => "apple" );
}
my $searchmenu = $menubar->new_menu();
my $helpmenu = $menubar->new_menu( -name => "help" );

if ($IS_AQUA) {
    $menubar->add_cascade(
        -label => "FileMorph",
        -menu  => $applemenu,
    );

................................................................................
    );
    $helpmenu->add_command(
        -label   => "Check for Updates",
        -command => \&checkUpdate,
    );
}

$mw->configure( -menu => $menubar );

#bindings
if ($IS_AQUA) {
    $mw->g_bind( "<Command-W>", sub { $mw->g_wm_state("withdrawn"); } );
    $mw->g_bind( "<Command-w>", sub { $mw->g_wm_state("withdrawn"); } );
}

#main window frame, listbox and notebook

my $toolbar = $mw->new_ttk__frame( -padding => 5 );
$toolbar->g_pack(
    -fill   => "both",
    -expand => "no",
    -side   => "top",
);

my $folderbutton = $toolbar->new_ttk__button(
................................................................................
);
$folderbutton->g_pack(
    -expand => "no",
    -fill   => "both",
    -side   => "left"
);

Tkx::DynamicHelp__register( $folderbutton, "balloon", "Select the directory" );

my $filebutton = $toolbar->new_ttk__button(
    -image     => $fileimage,
    -style     => "Toolbutton",
    -takefocus => 0,
    -command   => \&setFile,
);
................................................................................

$filebutton->g_pack(
    -expand => "no",
    -fill   => "both",
    -side   => "left"
);

Tkx::DynamicHelp__register( $filebutton, "balloon", "Select the file" );

my $sep = $toolbar->new_ttk__separator( -orient => "vertical" );
$sep->g_pack(
    -fill   => "both",
    -expand => "no",
    -side   => "top",
);

my $frame = $mw->new_ttk__frame;
................................................................................

$frame->g_pack(
    -fill   => "both",
    -expand => "yes",
    -side   => "bottom",
);

my $topsep = $frame->new_ttk__separator( -orient => "vertical" );
$topsep->g_pack(
    -fill   => "both",
    -expand => "no",
    -side   => "top",
);

my $textframe = $frame->new_ttk__panedwindow( -orient => "horizontal", );

$textframe->g_pack(
    -fill   => "both",
    -expand => "yes",
    -side   => "top",
);

................................................................................
);
$listbox->g_pack(
    -fill   => "both",
    -expand => "yes",
    -side   => "left",
);

Tkx::tkdnd__drop___target_register( $listbox, "*" );
Tkx::bind( $listbox, "<<Drop:DND_Files>>",
    [ sub { &selectFileSystem; }, Tkx::Ev("%D") ] );

my $noteframe = $textframe->new_ttk__frame;
$noteframe->g_pack(
    -fill   => "both",
    -expand => "yes",
    -side   => "right",
);
................................................................................
my $scrollhouse = $boxframe->new_ttk__frame;
$scrollhouse->g_pack(
    -fill   => "y",
    -expand => "no",
    -side   => "right",
);

my $scrollbar = $scrollhouse->new_ttk__scrollbar( -orient => 'vertical' );
$scrollbar->configure( -command => [ $listbox, "yview" ] );
$scrollbar->g_pack(
    -fill   => "y",
    -expand => "no",
    -side   => "right",
);

$listbox->configure( -yscrollcommand => [ $scrollbar, "set" ] );

#notebook components
my $extension   = $notebook->new_ttk__frame;
my $replacement = $notebook->new_ttk__frame;
my $text        = $notebook->new_ttk__frame;
my $date        = $notebook->new_ttk__frame;
my $case        = $notebook->new_ttk__frame;
my $attributes  = $notebook->new_ttk__frame;

#UI to modify file extensions
$notebook->add( $extension, -text => "Extension" );
my $exsrclabel = $extension->new_ttk__label( -text => "Extension:" );
my $exsrcentry = $extension->new_ttk__entry( -textvar => \$sourceext );
my $extargetlabel =
  $extension->new_ttk__label( -text => "New Extension Name:" );
my $extargetentry = $extension->new_ttk__entry( -textvar => \$targetext );
my $extchange = $extension->new_ttk__button(
    -text    => "Change",
    -command => \&changeExtension
);
my $extundo = $extension->new_ttk__button(
    -text    => "Undo",
    -command => \&undoExtension
);
my $extclear = $extension->new_ttk__button(
    -text    => "Clear",
    -command => sub { $sourceext = ""; $targetext = ""; }
);

our @extarray = (
    $exsrclabel, $exsrcentry, $extargetlabel, $extargetentry,
    $extchange, $extundo, $extclear
);

................................................................................
        -fill   => "both",
        -expand => "no",
        -side   => "top",
    );
}

#UI to replace text in file name
$notebook->add( $replacement, -text => "Replace Text" );
my $repsrclabel = $replacement->new_ttk__label( -text => "Text:" );
my $repsrcentry = $replacement->new_ttk__entry( -textvar => \$srcstring );
my $reptargetlabel =
  $replacement->new_ttk__label( -text => "Replacement Text:" );
my $reptargetentry = $replacement->new_ttk__entry( -textvar => \$targetstring );
my $repbutton = $replacement->new_ttk__button(
    -text    => "Change",
    -command => \&replaceString
);
my $repundo = $replacement->new_ttk__button(
    -text    => "Undo",
    -command => \&undoReplaceString
);
my $repclear = $replacement->new_ttk__button(
    -text    => "Clear",
    -command => sub { $srcstring = ""; $targetstring = ""; },
);

our @reparray = (
    $repsrclabel, $repsrcentry, $reptargetlabel, $reptargetentry,
    $repbutton, $repundo, $repclear
);

................................................................................
        -fill   => "both",
        -expand => "no",
        -side   => "top",
    );
}

#UI to add text to file name
$notebook->add( $text, -text => "Add Text" );
my $txtsrclabel = $text->new_ttk__label( -text => "Text:" );
my $txtsrcentry = $text->new_ttk__entry( -textvar => \$prependstring );
my $txtbefore = $text->new_ttk__radiobutton(
    -text     => "Before",
    -variable => \$prepend,
    -value    => 0
);
my $txtafter = $text->new_ttk__radiobutton(
    -text     => "After",
    -variable => \$prepend,
    -value    => 1
);
my $txtbutton =
  $text->new_ttk__button( -text => "Change", -command => \&addString );
my $txtundo = $text->new_ttk__button(
    -text    => "Undo",
    -command => \&undoAddString
);
my $txtclear = $text->new_ttk__button(
    -text    => "Clear",
    -command => sub { $prependstring = ""; }
);

$prepend = 1;

our @txtarray = (
    $txtsrclabel, $txtsrcentry, $txtbefore, $txtafter,
    $txtbutton,   $txtundo,     $txtclear
................................................................................
        -fill   => "both",
        -expand => "no",
        -side   => "top",
    );
}

#UI to modify file attributes
$notebook->add( $attributes, -text => "Date" );

my $todaylabel = $attributes->new_ttk__label( -text => "Date:", );
my $today = $attributes->new_widget__dateentry(
    -textvariable => \$datetime,
    -font         => \&Tkx::TkDefaultFont
);
my $timelabel = $attributes->new_ttk__label(
    -text => "Time (enter HH:MM, military-style, i.e. 23:00 for 11:00 PM)", );

my $timeentry = $attributes->new_ttk__entry( -textvariable => \$clocktime, );
my $attbutton = $attributes->new_ttk__button(
    -text    => "Change",
    -command => \&changeTime
);

our @attarray = ( $todaylabel, $today, $timelabel, $timeentry, $attbutton );

foreach (@attarray) {
    $_->g_pack(
        -fill   => "both",
        -expand => "no",
        -side   => "top",
    );
................................................................................

if ($IS_AQUA) {
    Tkx::fullscreen__fullscreen($mw);
}

Tkx::after(50);

Tkx::regproc__readLic( $appname, $appversion );

#This is necessary to get the listbox to draw; sometimes it does not render until the mouse hovers over it
Tkx::focus( -force => $listbox );

if ($IS_AQUA) {
    &createAppleScriptCommands;
}

Tkx::MainLoop();
exit;
................................................................................
LPn+DvFm3yEO1npKvqflTPvelmAHwH8AtJzPuEp4NAYnVANOnPZumzGjcr1ZO0/y
XSdBwFlx+1vFy0ID8NPX1dmx50yw85lDcigCT6nHgReJoM3TBHjQD4w7OeMR2WFe
w6c9HzQ/0nLBeuDObzRqZvaMONzMzHYFtpXt6/ONT9/8qPvl7Xu7CJ4ptvks8vzn
Rh7MMzQfd+eHMVWayECoHnd4B5/gLNmx+X7r++u+1tnW2X/6VEv3/46cOHdi/9Hm
5s/Odl9CG36qy3+n7cNBwLT/cZc0xhw2TSQBG/FY/qKh68eX3Db72Nybao/vOdDc
iv8jJFiCpmSL1XvYCU504f8ByyY/CIX5bZoAAAAASUVORK5CYII=
";
    $icon = Tkx::image_create_photo( -data => $data );

    my $folderdata = "
                R0lGODlhGAAYAPABAAAAAP///yH5BAEKAAEAIf4aQ3JlYXRlZCB3aXRoIEdJTVAg
b24gYSBNYWMALAAAAAAYABgAAAI1hI8Wy70JgZshJurOtFzmHm0ghJXVZVJkKo7u
C8cr28z0g944ojP2/aMFWcNU0SRLxk5KSQEAOw==
";
    $folderimage = Tkx::image_create_photo( -data => $folderdata );

    my $filedata = "
                R0lGODlhEgAYAPABAAAAAP///yH5BAEKAAEAIf4aQ3JlYXRlZCB3aXRoIEdJTVAg
b24gYSBNYWMALAAAAAASABgAAAI1hI8Qy5GvmoNJHjkv0+1tg0EL93nkSJ1ZioVV
270wisyl6tb2Cu6eL5v9bENhEJZKKpdMQwEAOw==
                ";
    $fileimage = Tkx::image_create_photo( -data => $filedata );

}

#check filelist for error handling
sub checkfilelist {

    if ( scalar(@filelist) == 0 ) {

        errlog("Please select a file or directory to run this operation.");

    }
}

#"about application"command
sub Tkx::tkAboutDialog {

  Tkx::tk___messageBox(
		       -parent  => $mw,
		       -title   => "About FileMorph",


















		       -icon    => "info",

































		       -message => "FileMorph: File Modification Tool", -detail=>"(c) 2016 WordTech Communications LLC");


}







































#handle errors in Tk
sub errlog {
    my $msg = shift;
    if ($IS_AQUA) {
        system("syslog -s -l Error FileMorph: An error occurred: $msg\n");
    }
................................................................................
"Cannot run operation without text.Please enter text into the appropriate entry field to run this operation."
    );
}

#update display of files
sub updateFileDisplay {

    $listbox->delete( 0, "end" );
    if ( scalar(@filelist) > 1 ) {
        @filelist = <"$folder/*">;
    }
    foreach (@filelist) {
        $listbox->insert( "end", "$_" );
    }
}

#set search directory
sub setDir {
    $listbox->delete( 0, "end" );
    $folder = Tkx::tk___chooseDirectory( -parent => $mw );
    return unless $folder;
    @filelist = <"$folder/*">;
    foreach (@filelist) {
        $listbox->insert( "end", "$_" );
    }
    return "$folder";
}

#set file to change
sub setFile {

    $listbox->delete( 0, "end" );
    my $filename = Tkx::tk___getOpenFile( -parent => $mw );
    return unless $filename;
    @filelist = ();
    push( @filelist, $filename );
    foreach (@filelist) {
        $listbox->insert( "end", "$_" );
    }
    return @filelist;
}

#change all file extensions in a directory
sub changeExtension {

    &checkfilelist;

    return if ( scalar(@filelist) == 0 );

    if ( scalar(@filelist) == 1 ) {

        &fileErrMsg;
        return;
    }

    if ( $exsrcentry->get() eq "" || $extargetentry->get() eq "" ) {
        &dataErrMsg;
        return;
    }

    $sourceext = $exsrcentry->get();
    $targetext = $extargetentry->get();

................................................................................
}

#undo operation of change file extension
sub undoExtension {

    &checkfilelist;

    return if ( scalar(@filelist) == 0 );

    if ( scalar(@filelist) == 1 ) {

        &fileErrMsg;
        return;
    }

    if ( $exsrcentry->get() eq "" || $extargetentry->get() eq "" ) {
        &dataErrMsg;
        return;
    }

    $sourceext = $exsrcentry->get();
    $targetext = $extargetentry->get();

................................................................................
}

#replace string in file name
sub replaceString {

    &checkfilelist;

    return if ( scalar(@filelist) == 0 );

    if ( scalar(@filelist) == 1 ) {

        &fileErrMsg;
        return;
    }

    if ( $repsrcentry->get() eq "" ) {
        &dataErrMsg;
        return;
    }

    $srcstring    = $repsrcentry->get();
    $targetstring = $reptargetentry->get();

    if ( $reptargetentry->get() eq "" ) {
        my $changeQuestion;
        $changeQuestion = Tkx::tk___messageBox(
            -parent => $mw,
            -title  => "Confirm Removal of Text",
            -type   => "yesno",
            -icon   => "info",
            -message =>
              "Do you want to strip out \"$srcstring\"with no replacement?",
            -detail => "This operation cannot be undone.",
        );

        if ( $changeQuestion eq "no" ) {
            return;
        }
    }

    foreach (@filelist) {
        next unless -f $_;
        my $filename    = $_;
................................................................................
}

#undo replace string in filename
sub undoReplaceString {

    &checkfilelist;

    return if ( scalar(@filelist) == 0 );

    if ( scalar(@filelist) == 1 ) {

        &fileErrMsg;
        return;
    }

    if ( $repsrcentry->get() eq "" ) {
        &dataErrMsg;
        return;
    }

    if ( $reptargetentry->get() eq "" ) {
        my $sorryQuestion;
        $sorryQuestion = Tkx::tk___messageBox(
            -parent  => $mw,
            -title   => "Removal Operation Cannot Be Undone",
            -icon    => "info",
            -message => "You confirmed removing the string \"$srcstring.\"",
            -detail  => "This operation cannot be undone.",
................................................................................
}

#replace string in file name
sub addString {

    &checkfilelist;

    return if ( scalar(@filelist) == 0 );

    if ( scalar(@filelist) == 1 ) {

        &fileErrMsg;
        return;
    }

    if ( $txtsrcentry->get() eq "" ) {
        &dataErrMsg;
        return;
    }

    $prependstring = $txtsrcentry->get();

    foreach (@filelist) {
        next unless -f $_;
        if ( $prepend == 0 ) {

            my $filename    = $_;
            my $newname     = $filename;
            my $basename    = basename($filename);
            my $dirname     = dirname($filename);
            my $newbasename = $basename;
            $newbasename = $prependstring . $basename;
            $newname =~ s/$basename/$newbasename/i;
            move $filename, $newname;
        }

        if ( $prepend == 1 ) {
            my $filename = $_;

            my @components = split( /\./, $filename );
            my $newname =
              $components[0] . $prependstring . "\." . $components[1];
            move $filename, $newname;
        }
    }
    &updateFileDisplay;
}

#replace string in file name
sub undoAddString {

    &checkfilelist;

    return if ( scalar(@filelist) == 0 );

    if ( scalar(@filelist) == 1 ) {

        &fileErrMsg;
        return;
    }

    if ( $txtsrcentry->get() eq "" ) {
        &dataErrMsg;
        return;
    }

    $prependstring = $txtsrcentry->get();

    foreach (@filelist) {
................................................................................
}

#change modification time of files
sub changeTime {

    &checkfilelist;
    my $validation = &validateTime;
    return if ( $validation == 0 );
    return if ( scalar(@filelist) == 0 );

    my $changeQuestion;
    $changeQuestion = Tkx::tk___messageBox(
        -parent  => $mw,
        -title   => "Change Modification Time",
        -type    => "yesno",
        -icon    => "info",
        -message => "Do you want to change the file modification time?",
        -detail  => "This operation cannot be undone.",
    );

    if ( $changeQuestion eq "no" ) {
        return;
    }
    if ( $changeQuestion eq "yes" ) {
        my @datearray  = split( /\//, $datetime );
        my @clockarray = split( /\:/, $clocktime );
        my $hour;
        my $second = "00";
        if ( $timeofday == 1 ) {
            $hour = $clockarray[0] + 12;
        }
        else {
            $hour = $clockarray[0];
        }

        $modtime =
          timelocal( $second, $clockarray[1], $hour,
            $datearray[1], ( $datearray[0] - 1 ),
            $datearray[2] );
        print $modtime;

        foreach (@filelist) {

            utime $modtime, $modtime, $_;
        }

................................................................................
    }
}

#make sure time is formatted properly
sub validateTime {

    my $time = $timeentry->get();
    if ( $time =~ (/\d\d:\d\d/) ) {
        return 1;
    }
    else {
        $timeentry->delete( 0, "end" );

        Tkx::tk___messageBox(
            -parent  => $mw,
            -title   => "Incorrect Time Format",
            -icon    => "info",
            -message => "Incorrect Time Format",
            -detail  => "Please enter the time in HH:MM format, i.e. 12:30.",
................................................................................
sub selectFileSystem {

    my $fname = shift;
    my @name  = Tkx::SplitList($fname);
    my $path  = join "", @name;
    $folder = $path;

    if ( -f $folder ) {
        $listbox->delete( 0, "end" );
        @filelist = ();
        push( @filelist, $folder );
        foreach (@filelist) {
            $listbox->insert( "end", "$_" );
        }
    }

    if ( -d $folder ) {

        $listbox->delete( 0, "end" );
        @filelist = <"$folder/*">;
        foreach (@filelist) {
            $listbox->insert( "end", "$_" );
        }

        return $folder;
    }

    return $folder;
}
................................................................................
}

#initialize the app
sub startUp {

    $appname    = 'FileMorph';
    $appversion = '2.7';
    &Tkx::machelp__setAppName( $appname, $appversion );
    &Tkx::softwareupdate__setAppName($appname);
    &Tkx::softwareupdate__setVersion( $appname, $appversion );

    #check for app support directory
    our $prefdir = Tkx::xplat__appconfig("FileMorph");
    mkdir $prefdir unless ( -d $prefdir );
}

#check version of installed software
sub checkUpdate {

    &Tkx::softwareupdate__setIcon($icon);
    &Tkx::softwareupdate__checkVersion( $appname, $appversion );












}



















































#-----AppleScript handlers------$

if ($IS_AQUA) {

    sub createAppleScriptCommands {
        Tkx::aem__installeventhandler( "CoKv", "fMdr", \&scriptSetDir );
        Tkx::aem__installeventhandler( "CoKv", "fMfl", \&scriptSetFile );
        Tkx::aem__installeventhandler( "CoKv", "oExt", \&scriptOldExt );
        Tkx::aem__installeventhandler( "CoKv", "nExt", \&scriptNewExt );
        Tkx::aem__installeventhandler( "CoKv", "rExt", \&scriptChangeExt );
        Tkx::aem__installeventhandler( "CoKv", "oTxt", \&scriptOldText );
        Tkx::aem__installeventhandler( "CoKv", "nTxt", \&scriptNewText );
        Tkx::aem__installeventhandler( "CoKv", "cTxt", \&scriptChangeText );
        Tkx::aem__installeventhandler( "CoKv", "beTx", \&scriptAddedText );
        Tkx::aem__installeventhandler( "CoKv", "afTx", \&scriptPrefixOrSuffix );
        Tkx::aem__installeventhandler( "CoKv", "adTx", \&scriptAddText );
        Tkx::aem__installeventhandler( "CoKv", "tmDa", \&scriptSetTime );
        Tkx::aem__installeventhandler( "CoKv", "cTme", \&scriptFileTime );
    }
}

sub scriptSetDir {
    my $path = shift;

    #join with spaces
    foreach (@_) {
        $path = $_ . ' ';
    }

    $folder = $path;

    if ( -f $folder ) {
        $listbox->delete( 0, "end" );
        @filelist = ();
        push( @filelist, $folder );
        foreach (@filelist) {
            $listbox->insert( "end", "$_" );
        }
    }

    if ( -d $folder ) {

        $listbox->delete( 0, "end" );
        @filelist = <"$folder/*">;
        foreach (@filelist) {
            $listbox->insert( "end", "$_" );
        }

        return $folder;
    }

    return $folder;
}
................................................................................
sub scriptAddText {
    &addString;
}

sub scriptSetTime {
    my $time;
    $time = shift;
    my @datearray = split( /\//, $time );
    $modtime =
      timelocal( "00", "00", "00", $datearray[1], ( $datearray[0] - 1 ),
        $datearray[2] );
}

sub scriptFileTime {
    return if ( scalar(@filelist) == 0 );
    foreach (@filelist) {
        utime $modtime, $modtime, $_;
    }
}

#------end of subroutines---------

package ifneeded tdom 0.8.3 "load [list [file join $dir libtdom0.8.3.dylib]];         source [list [file join $dir tdom.tcl]]"

#----------------------------------------------------------------------------
#   Copyright (c) 1999 Jochen Loewer (loewerj@hotmail.com)
#----------------------------------------------------------------------------
#
#   $Id: tdom.tcl,v 1.19 2005/01/11 15:57:19 rolf Exp $
#
#
#   The higher level functions of tDOM written in plain Tcl.
#
#
#   The contents of this file are subject to the Mozilla Public License
#   Version 1.1 (the "License"); you may not use this file except in
#   compliance with the License. You may obtain a copy of the License at
#   http://www.mozilla.org/MPL/
#
#   Software distributed under the License is distributed on an "AS IS"
#   basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
#   License for the specific language governing rights and limitations
#   under the License.
#
#   The Original Code is tDOM.
#
#   The Initial Developer of the Original Code is Jochen Loewer
#   Portions created by Jochen Loewer are Copyright (C) 1998, 1999
#   Jochen Loewer. All Rights Reserved.
#
#   Contributor(s):
#       Rolf Ade (rolf@pointsman.de):   'fake' nodelists/live childNodes
#
#   written by Jochen Loewer
#   April, 1999
#
#----------------------------------------------------------------------------

package require tdom 

#----------------------------------------------------------------------------
#   setup namespaces for additional Tcl level methods, etc.
#
#----------------------------------------------------------------------------
namespace eval ::dom {
    namespace eval  domDoc {
    }
    namespace eval  domNode {
    }
    namespace eval  DOMImplementation {
    }
    namespace eval  xpathFunc {
    }
    namespace eval  xpathFuncHelper {
    }
}

namespace eval ::tDOM { 
    variable extRefHandlerDebug 0
    variable useForeignDTD ""

    namespace export xmlOpenFile xmlReadFile extRefHandler baseURL
}

#----------------------------------------------------------------------------
#   hasFeature (DOMImplementation method)
#
#
#   @in  url    the URL, where to get the XML document
#
#   @return     document object
#   @exception  XML parse errors, ...
#
#----------------------------------------------------------------------------
proc ::dom::DOMImplementation::hasFeature { dom feature {version ""} } {

    switch $feature {
        xml -
        XML {
            if {($version == "") || ($version == "1.0")} {
                return 1
            }
        }
    }
    return 0

}

#----------------------------------------------------------------------------
#   load (DOMImplementation method)
#
#       requests a XML document via http using the given URL and
#       builds up a DOM tree in memory returning the document object
#
#
#   @in  url    the URL, where to get the XML document
#
#   @return     document object
#   @exception  XML parse errors, ...
#
#----------------------------------------------------------------------------
proc ::dom::DOMImplementation::load { dom url } {

    error "Sorry, load method not implemented yet!"

}

#----------------------------------------------------------------------------
#   isa (docDoc method, for [incr tcl] compatibility)
#
#
#   @in  className
#
#   @return         1 iff inherits from the given class
#
#----------------------------------------------------------------------------
proc ::dom::domDoc::isa { doc className } {

    if {$className == "domDoc"} {
        return 1
    }
    return 0
}

#----------------------------------------------------------------------------
#   info (domDoc method, for [incr tcl] compatibility)
#
#
#   @in  subcommand
#   @in  args
#
#----------------------------------------------------------------------------
proc ::dom::domDoc::info { doc subcommand args } {

    switch $subcommand {
        class {
            return "domDoc"
        }
        inherit {
            return ""
        }
        heritage {
            return "domDoc {}"
        }
        default {
            error "domDoc::info subcommand $subcommand not yet implemented!"
        }
    }
}

#----------------------------------------------------------------------------
#   importNode (domDoc method)
#
#       Document Object Model (Core) Level 2 method
#
#
#   @in  subcommand
#   @in  args
#
#----------------------------------------------------------------------------
proc ::dom::domDoc::importNode { doc importedNode deep } {

    if {$deep || ($deep == "-deep")} {
        set node [$importedNode cloneNode -deep]
    } else {
        set node [$importedNode cloneNode]
    }
    return $node
}

#----------------------------------------------------------------------------
#   isa (domNode method, for [incr tcl] compatibility)
#
#
#   @in  className
#
#   @return         1 iff inherits from the given class
#
#----------------------------------------------------------------------------
proc ::dom::domNode::isa { doc className } {

    if {$className == "domNode"} {
        return 1
    }
    return 0
}

#----------------------------------------------------------------------------
#   info (domNode method, for [incr tcl] compatibility)
#
#
#   @in  subcommand
#   @in  args
#
#----------------------------------------------------------------------------
proc ::dom::domNode::info { doc subcommand args } {

    switch $subcommand {
        class {
            return "domNode"
        }
        inherit {
            return ""
        }
        heritage {
            return "domNode {}"
        }
        default {
            error "domNode::info subcommand $subcommand not yet implemented!"
        }
    }
}

#----------------------------------------------------------------------------
#   isWithin (domNode method)
#
#       tests, whether a node object is nested below another tag
#
#
#   @in  tagName  the nodeName of an elment node
#
#   @return       1 iff node is nested below a element with nodeName tagName
#                 0 otherwise
#
#----------------------------------------------------------------------------
proc ::dom::domNode::isWithin { node tagName } {

    while {[$node parentNode] != ""} {
        set node [$node parentNode]
        if {[$node nodeName] == $tagName} {
            return 1
        }
    }
    return 0
}

#----------------------------------------------------------------------------
#   tagName (domNode method)
#
#       same a nodeName for element interface
#
#----------------------------------------------------------------------------
proc ::dom::domNode::tagName { node } {

    if {[$node nodeType] == "ELEMENT_NODE"} {
        return [$node nodeName]
    }
    return -code error "NOT_SUPPORTED_ERR not an element!"
}

#----------------------------------------------------------------------------
#   simpleTranslate (domNode method)
#
#       applies simple translation rules similar to Cost's simple
#       translations to a node
#
#
#   @in  output_var
#   @in  trans_specs
#
#----------------------------------------------------------------------------
proc ::dom::domNode::simpleTranslate { node output_var trans_specs } {

    upvar $output_var output

    if {[$node nodeType] == "TEXT_NODE"} {
        append output [cgiQuote [$node nodeValue]]
        return
    }
    set found 0

    foreach {match action} $trans_specs {

        if {[catch {
            if {!$found && ([$node selectNode self::$match] != "") } {
              set found 1
            }
        } err]} {
            if {![string match "NodeSet expected for parent axis!" $err]} {
                error $err
            }
        }
        if {$found && ($action != "-")} {
            set stop 0
            foreach {type value} $action {
                switch $type {
                    prefix { append output [subst $value] }
                    tag    { append output <$value>       }
                    start  { append output [eval $value]  }
                    stop   { set stop 1                   }
                }
            }
            if {!$stop} {
                foreach child [$node childNodes] {
                    simpleTranslate  $child output $trans_specs
                }
            }
            foreach {type value} $action {
                switch $type {
                    suffix { append output [subst $value] }
                    end    { append output [eval $value]  }
                    tag    { append output </$value>      }
                }
            }
            return
        }
    }
    foreach child [$node childNodes] {
        simpleTranslate $child output $trans_specs
    }
}

#----------------------------------------------------------------------------
#   a DOM conformant 'live' childNodes
#
#   @return   a 'nodelist' object (it is just the normal node)
#
#----------------------------------------------------------------------------
proc ::dom::domNode::childNodesLive { node } {

    return $node
}

#----------------------------------------------------------------------------
#   item method on a 'nodelist' object
#
#   @return   a 'nodelist' object (it is just a normal
#
#----------------------------------------------------------------------------
proc ::dom::domNode::item { nodeListNode index } {

    return [lindex [$nodeListNode childNodes] $index]
}

#----------------------------------------------------------------------------
#   length method on a 'nodelist' object
#
#   @return   a 'nodelist' object (it is just a normal
#
#----------------------------------------------------------------------------
proc ::dom::domNode::length { nodeListNode } {

    return [llength [$nodeListNode childNodes]]
}

#----------------------------------------------------------------------------
#   appendData on a 'CharacterData' object
#
#----------------------------------------------------------------------------
proc ::dom::domNode::appendData { node  arg } {

    set type [$node nodeType]
    if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") &&
        ($type != "COMMENT_NODE")
    } {
        return -code error "NOT_SUPPORTED_ERR: node is not a cdata node"
    }
    set oldValue [$node nodeValue]
    $node nodeValue [append oldValue $arg]
}

#----------------------------------------------------------------------------
#   deleteData on a 'CharacterData' object
#
#----------------------------------------------------------------------------
proc ::dom::domNode::deleteData { node offset count } {

    set type [$node nodeType]
    if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") &&
        ($type != "COMMENT_NODE")
    } {
        return -code error "NOT_SUPPORTED_ERR: node is not a cdata node"
    }
    incr offset -1
    set before [string range [$node nodeValue] 0 $offset]
    incr offset
    incr offset $count
    set after  [string range [$node nodeValue] $offset end]
    $node nodeValue [append before $after]
}

#----------------------------------------------------------------------------
#   insertData on a 'CharacterData' object
#
#----------------------------------------------------------------------------
proc ::dom::domNode::insertData { node  offset arg } {

    set type [$node nodeType]
    if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") &&
        ($type != "COMMENT_NODE")
    } {
        return -code error "NOT_SUPPORTED_ERR: node is not a cdata node"
    }
    incr offset -1
    set before [string range [$node nodeValue] 0 $offset]
    incr offset
    set after  [string range [$node nodeValue] $offset end]
    $node nodeValue [append before $arg $after]
}

#----------------------------------------------------------------------------
#   replaceData on a 'CharacterData' object
#
#----------------------------------------------------------------------------
proc ::dom::domNode::replaceData { node offset count arg } {

    set type [$node nodeType]
    if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") &&
        ($type != "COMMENT_NODE")
    } {
        return -code error "NOT_SUPPORTED_ERR: node is not a cdata node"
    }
    incr offset -1
    set before [string range [$node nodeValue] 0 $offset]
    incr offset
    incr offset $count
    set after  [string range [$node nodeValue] $offset end]
    $node nodeValue [append before $arg $after]
}

#----------------------------------------------------------------------------
#   substringData on a 'CharacterData' object
#
#   @return   part of the node value (text)
#
#----------------------------------------------------------------------------
proc ::dom::domNode::substringData { node offset count } {

    set type [$node nodeType]
    if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") &&
        ($type != "COMMENT_NODE")
    } {
        return -code error "NOT_SUPPORTED_ERR: node is not a cdata node"
    }
    set endOffset [expr $offset + $count - 1]
    return [string range [$node nodeValue] $offset $endOffset]
}

#----------------------------------------------------------------------------
#   coerce2number
#
#----------------------------------------------------------------------------
proc ::dom::xpathFuncHelper::coerce2number { type value } {
    switch $type {
        empty      { return 0 }
        number -
        string     { return $value }
        attrvalues { return [lindex $value 0] }
        nodes      { return [[lindex $value 0] selectNodes number()] }
        attrnodes  { return [lindex $value 1] }
    }
}

#----------------------------------------------------------------------------
#   coerce2string
#
#----------------------------------------------------------------------------
proc ::dom::xpathFuncHelper::coerce2string { type value } {
    switch $type {
        empty      { return "" }
        number -
        string     { return $value }
        attrvalues { return [lindex $value 0] }
        nodes      { return [[lindex $value 0] selectNodes string()] }
        attrnodes  { return [lindex $value 1] }
    }
}

#----------------------------------------------------------------------------
#   function-available
#
#----------------------------------------------------------------------------
proc ::dom::xpathFunc::function-available { ctxNode pos
                                            nodeListType nodeList args} {

    if {[llength $args] != 2} {
        error "function-available(): wrong # of args!"
    }
    foreach { arg1Typ arg1Value } $args break
    set str [::dom::xpathFuncHelper::coerce2string $arg1Typ $arg1Value ]
    switch $str {
        boolean -
        ceiling -
        concat -
        contains -
        count -
        current -
        document -
        element-available -
        false -
        floor -
        format-number -
        generate-id -
        id -
        key -
        last -
        lang -
        local-name -
        name -
        namespace-uri -
        normalize-space -
        not -
        number -
        position -
        round -
        starts-with -
        string -
        string-length -
        substring -
        substring-after -
        substring-before -
        sum -
        translate -
        true -
        unparsed-entity-uri {
            return [list bool true]
        }
        default {
            set TclXpathFuncs [info procs ::dom::xpathFunc::*]
            if {[lsearch -exact $TclXpathFuncs $str] != -1} {
                return [list bool true]
            } else {
                return [list bool false]
            }
        }
    }
}

#----------------------------------------------------------------------------
#   element-available
#
#   This is not strictly correct. The XSLT namespace may be bound
#   to another prefix (and the prefix 'xsl' may be bound to another
#   namespace). Since the expression context isn't available at the
#   moment at tcl coded XPath functions, this couldn't be done better
#   than this "works in the 'normal' cases" version.
#----------------------------------------------------------------------------
proc ::dom::xpathFunc::element-available { ctxNode pos
                                            nodeListType nodeList args} {

    if {[llength $args] != 2} {
        error "element-available(): wrong # of args!"
    }
    foreach { arg1Typ arg1Value } $args break
    set str [::dom::xpathFuncHelper::coerce2string $arg1Typ $arg1Value ]
    switch $str {
        xsl:stylesheet -
        xsl:transform -
        xsl:include -
        xsl:import -
        xsl:strip-space -
        xsl:preserve-space -
        xsl:template -
        xsl:apply-templates -
        xsl:apply-imports -
        xsl:call-template -
        xsl:element -
        xsl:attribute -
        xsl:attribute-set -
        xsl:text -
        xsl:processing-instruction -
        xsl:comment -
        xsl:copy -
        xsl:value-of -
        xsl:number -
        xsl:for-each -
        xsl:if -
        xsl:choose -
        xsl:when -
        xsl:otherwise -
        xsl:sort -
        xsl:variable -
        xsl:param -
        xsl:copy-of -
        xsl:with-param -
        xsl:key -
        xsl:message -
        xsl:decimal-format -
        xsl:namespace-alias -
        xsl:output -
        xsl:fallback {
            return [list bool true]
        }
        default {
            return [list bool false]
        }
    }
}

#----------------------------------------------------------------------------
#   system-property
#
#   This is not strictly correct. The XSLT namespace may be bound
#   to another prefix (and the prefix 'xsl' may be bound to another
#   namespace). Since the expression context isn't available at the
#   moment at tcl coded XPath functions, this couldn't be done better
#   than this "works in the 'normal' cases" version.
#----------------------------------------------------------------------------
proc ::dom::xpathFunc::system-property { ctxNode pos
                                         nodeListType nodeList args } {

    if {[llength $args] != 2} {
        error "system-property(): wrong # of args!"
    }
    foreach { arg1Typ arg1Value } $args break
    set str [::dom::xpathFuncHelper::coerce2string $arg1Typ $arg1Value ]
    switch $str {
        xsl:version {
            return [list number 1.0]
        }
        xsl:vendor {
            return [list string "Jochen Loewer (loewerj@hotmail.com), Rolf Ade (rolf@pointsman.de) et. al."]
        }
        xsl:vendor-url {
            return [list string "http://www.tdom.org"]
        }
        default {
            return [list string ""]
        }
    }
}

#----------------------------------------------------------------------------
#   IANAEncoding2TclEncoding
#
#----------------------------------------------------------------------------

# As of version 8.3.4 tcl supports 
# cp860 cp861 cp862 cp863 tis-620 cp864 cp865 cp866 gb12345 cp949
# cp950 cp869 dingbats ksc5601 macCentEuro cp874 macUkraine jis0201
# gb2312 euc-cn euc-jp iso8859-10 macThai jis0208 iso2022-jp
# macIceland iso2022 iso8859-13 iso8859-14 jis0212 iso8859-15 cp737
# iso8859-16 big5 euc-kr macRomania macTurkish gb1988 iso2022-kr
# macGreek ascii cp437 macRoman iso8859-1 iso8859-2 iso8859-3 ebcdic
# macCroatian koi8-r iso8859-4 iso8859-5 cp1250 macCyrillic iso8859-6
# cp1251 koi8-u macDingbats iso8859-7 cp1252 iso8859-8 cp1253
# iso8859-9 cp1254 cp1255 cp850 cp1256 cp932 identity cp1257 cp852
# macJapan cp1258 shiftjis utf-8 cp855 cp936 symbol cp775 unicode
# cp857
# 
# Just add more mappings (and mail them to the tDOM mailing list, please).

proc tDOM::IANAEncoding2TclEncoding {IANAName} {
    
    # First the most widespread encodings with there
    # preferred MIME name, to speed lookup in this
    # usual cases. Later the official names and the
    # aliases.
    #
    # For "official names for character sets that may be
    # used in the Internet" see 
    # http://www.iana.org/assignments/character-sets
    # (that's the source for the encoding names below)
    # 
    # Matching is case-insensitive

    switch [string tolower $IANAName] {
        "us-ascii"    {return ascii}
        "utf-8"       {return utf-8}
        "utf-16"      {return unicode; # not sure about this}
        "iso-8859-1"  {return iso8859-1}
        "iso-8859-2"  {return iso8859-2}
        "iso-8859-3"  {return iso8859-3}
        "iso-8859-4"  {return iso8859-4}
        "iso-8859-5"  {return iso8859-5}
        "iso-8859-6"  {return iso8859-6}
        "iso-8859-7"  {return iso8859-7}
        "iso-8859-8"  {return iso8859-8}
        "iso-8859-9"  {return iso8859-9}
        "iso-8859-10" {return iso8859-10}
        "iso-8859-13" {return iso8859-13}
        "iso-8859-14" {return iso8859-14}
        "iso-8859-15" {return iso8859-15}
        "iso-8859-16" {return iso8859-16}
        "iso-2022-kr" {return iso2022-kr}
        "euc-kr"      {return euc-kr}
        "iso-2022-jp" {return iso2022-jp}
        "koi8-r"      {return koi8-r}
        "shift_jis"   {return shiftjis}
        "euc-jp"      {return euc-jp}
        "gb2312"      {return gb2312}
        "big5"        {return big5}
        "cp866"       {return cp866}
        "cp1250"      {return cp1250}
        "cp1253"      {return cp1253}
        "cp1254"      {return cp1254}
        "cp1255"      {return cp1255}
        "cp1256"      {return cp1256}
        "cp1257"      {return cp1257}

        "windows-1251" -
        "cp1251"      {return cp1251}

        "windows-1252" -
        "cp1252"      {return cp1252}    

        "iso_8859-1:1987" -
        "iso-ir-100" -
        "iso_8859-1" -
        "latin1" -
        "l1" -
        "ibm819" -
        "cp819" -
        "csisolatin1" {return iso8859-1}
        
        "iso_8859-2:1987" -
        "iso-ir-101" -
        "iso_8859-2" -
        "iso-8859-2" -
        "latin2" -
        "l2" -
        "csisolatin2" {return iso8859-2}

        "iso_8859-5:1988" -
        "iso-ir-144" -
        "iso_8859-5" -
        "iso-8859-5" -
        "cyrillic" -
        "csisolatincyrillic" {return iso8859-5}

        "ms_kanji" -
        "csshiftjis"  {return shiftjis}
        
        "csiso2022kr" {return iso2022-kr}

        "ibm866" -
        "csibm866"    {return cp866}
        
        default {
            # There are much more encoding names out there
            # It's only laziness, that let me stop here.
            error "Unrecognized encoding name '$IANAName'"
        }
    }
}

#----------------------------------------------------------------------------
#   xmlOpenFile
#
#----------------------------------------------------------------------------
proc tDOM::xmlOpenFile {filename {encodingString {}}} {

    set fd [open $filename]

    if {$encodingString != {}} {
        upvar $encodingString encString
    }

    # The autodetection of the encoding follows
    # XML Recomendation, Appendix F

    fconfigure $fd -encoding binary
    if {![binary scan [read $fd 4] "H8" firstBytes]} {
        # very short (< 4 Bytes) file
        seek $fd 0 start
        set encString UTF-8
        return $fd
    }
    
    # First check for BOM
    switch [string range $firstBytes 0 3] {
        "feff" -
        "fffe" {
            # feff: UTF-16, big-endian BOM
            # ffef: UTF-16, little-endian BOM
            seek $fd 0 start
            set encString UTF-16            
            fconfigure $fd -encoding identity
            return $fd
        }
    }

    # If the entity has a XML Declaration, the first four characters
    # must be "<?xm".
    switch $firstBytes {
        "3c3f786d" {
            # UTF-8, ISO 646, ASCII, some part of ISO 8859, Shift-JIS,
            # EUC, or any other 7-bit, 8-bit, or mixed-width encoding which 
            # ensures that the characters of ASCII have their normal positions,
            # width and values; the actual encoding declaration must be read to
            # detect which of these applies, but since all of these encodings
            # use the same bit patterns for the ASCII characters, the encoding
            # declaration itself be read reliably.

            # First 300 bytes should be enough for a XML Declaration
            # This is of course not 100 percent bullet-proof.
            set head [read $fd 296]

            # Try to find the end of the XML Declaration
            set closeIndex [string first ">" $head]
            if {$closeIndex == -1} {
                error "Weird XML data or not XML data at all"
            }

            seek $fd 0 start
            set xmlDeclaration [read $fd [expr {$closeIndex + 5}]]
            # extract the encoding information
            set pattern {^[^>]+encoding=[\x20\x9\xd\xa]*["']([^ "']+)['"]}
            # emacs: "
            if {![regexp $pattern $head - encStr]} {
                # Probably something like <?xml version="1.0"?>. 
                # Without encoding declaration this must be UTF-8
                set encoding utf-8
                set encString UTF-8
            } else {
                set encoding [IANAEncoding2TclEncoding $encStr]
                set encString $encStr
            }
        }
        "0000003c" -
        "0000003c" -
        "3c000000" -
        "00003c00" {
            # UCS-4
            error "UCS-4 not supported"
        }
        "003c003f" -
        "3c003f00" {
            # UTF-16, big-endian, no BOM
            # UTF-16, little-endian, no BOM
            seek $fd 0 start
            set encoding identity
            set encString UTF-16
        }
        "4c6fa794" {
            # EBCDIC in some flavor
            error "EBCDIC not supported"
        }
        default {
            # UTF-8 without an encoding declaration
            seek $fd 0 start
            set encoding identity
            set encString "UTF-8"
        }
    }
    fconfigure $fd -encoding $encoding
    return $fd
}

#----------------------------------------------------------------------------
#   xmlReadFile
#
#----------------------------------------------------------------------------
proc tDOM::xmlReadFile {filename {encodingString {}}} {

    if {$encodingString != {}} {
        upvar $encodingString encString
    }
    
    set fd [xmlOpenFile $filename encString]
    set data [read $fd [file size $filename]]
    close $fd 
    return $data
}

#----------------------------------------------------------------------------
#   extRefHandler
#   
#   A very simple external entity resolver, included for convenience.
#   Depends on the tcllib package uri and resolves only file URLs. 
#
#----------------------------------------------------------------------------

if {![catch {package require uri}]} {
    proc tDOM::extRefHandler {base systemId publicId} {
        variable extRefHandlerDebug
        variable useForeignDTD

        if {$extRefHandlerDebug} {
            puts stderr "tDOM::extRefHandler called with:"
            puts stderr "\tbase:     '$base'"
            puts stderr "\tsystemId: '$systemId'"
            puts stderr "\tpublicId: '$publicId'"
        }
        if {$systemId == ""} {
            if {$useForeignDTD != ""} {
                set systemId $useForeignDTD
            } else {
                error "::tDOM::useForeignDTD does\
                        not point to the foreign DTD"
            }
        }
        set absolutURI [uri::resolve $base $systemId]
        array set uriData [uri::split $absolutURI]
        switch $uriData(scheme) {
            file {
                return [list string $absolutURI [xmlReadFile $uriData(path)]]
            }
            default {
                error "can only handle file URI's"
            }
        }
    }
}

#----------------------------------------------------------------------------
#   baseURL
#   
#   A simple convenience proc which returns an absolute URL for a given
#   filename.
#
#----------------------------------------------------------------------------

proc tDOM::baseURL {path} {
    switch [file pathtype $path] {
        "relative" {
            return "file://[pwd]/$path"
        }
        default {
            return "file://$path"
        }
    }
}

# EOF

if { $::tcl_platform(os) ne "Darwin" } {
     return;
   }

package ifneeded tls 1.6.1     "[list source [file join $dir tls.tcl]] ;      [list tls::initlib $dir libtls1.6.1.dylib]"

#
# Copyright (C) 1997-2000 Matt Newman <matt@novadigm.com> 
#
# $Header: /cvsroot/tls/tls/tls.tcl,v 1.12 2010/07/27 17:15:47 hobbs2 Exp $
#
namespace eval tls {
    variable logcmd tclLog
    variable debug 0
 
    # Default flags passed to tls::import
    variable defaults {}

    # Maps UID to Server Socket
    variable srvmap
    variable srvuid 0

    # Over-ride this if you are using a different socket command
    variable socketCmd
    if {![info exists socketCmd]} {
        set socketCmd [info command ::socket]
    }
}

proc tls::initlib {dir dll} {
    # Package index cd's into the package directory for loading.
    # Irrelevant to unixoids, but for Windows this enables the OS to find
    # the dependent DLL's in the CWD, where they may be.
    set cwd [pwd]
    catch {cd $dir}
    if {[string equal $::tcl_platform(platform) "windows"] &&
	![string equal [lindex [file system $dir] 0] "native"]} {
	# If it is a wrapped executable running on windows, the openssl
	# dlls must be copied out of the virtual filesystem to the disk
	# where Windows will find them when resolving the dependency in
	# the tls dll. We choose to make them siblings of the executable.
	package require starkit
	set dst [file nativename [file dirname $starkit::topdir]]
	foreach sdll [glob -nocomplain -directory $dir -tails *eay32.dll] {
	    catch {file delete -force            $dst/$sdll}
	    catch {file copy   -force $dir/$sdll $dst/$sdll}
	}
    }
    set res [catch {uplevel #0 [list load [file join [pwd] $dll]]} err]
    catch {cd $cwd}
    if {$res} {
	namespace eval [namespace parent] {namespace delete tls}
	return -code $res $err
    }
    rename tls::initlib {}
}

#
# Backwards compatibility, also used to set the default
# context options
#
proc tls::init {args} {
    variable defaults

    set defaults $args
}
#
# Helper function - behaves exactly as the native socket command.
#
proc tls::socket {args} {
    variable socketCmd
    variable defaults
    set idx [lsearch $args -server]
    if {$idx != -1} {
	set server 1
	set callback [lindex $args [expr {$idx+1}]]
	set args [lreplace $args $idx [expr {$idx+1}]]

	set usage "wrong # args: should be \"tls::socket -server command ?options? port\""
	set options "-cadir, -cafile, -certfile, -cipher, -command, -keyfile, -myaddr, -password, -request, -require, -ssl2, -ssl3, or -tls1"
    } else {
	set server 0

	set usage "wrong # args: should be \"tls::socket ?options? host port\""
	set options "-async, -cadir, -cafile, -certfile, -cipher, -command, -keyfile, -myaddr, -myport, -password, -request, -require, -ssl2, -ssl3, or -tls1"
    }
    set argc [llength $args]
    set sopts {}
    set iopts [concat [list -server $server] $defaults]	;# Import options

    for {set idx 0} {$idx < $argc} {incr idx} {
	set arg [lindex $args $idx]
	switch -glob -- $server,$arg {
	    0,-async	{lappend sopts $arg}
	    0,-myport	-
	    *,-type	-
	    *,-myaddr	{lappend sopts $arg [lindex $args [incr idx]]}
	    *,-cadir	-
	    *,-cafile	-
	    *,-certfile	-
	    *,-cipher	-
	    *,-command	-
	    *,-keyfile	-
	    *,-password	-
	    *,-request	-
	    *,-require	-
	    *,-ssl2	-
	    *,-ssl3	-
	    *,-tls1	{lappend iopts $arg [lindex $args [incr idx]]}
	    -*		{return -code error "bad option \"$arg\": must be one of $options"}
	    default	{break}
	}
    }
    if {$server} {
	if {($idx + 1) != $argc} {
	    return -code error $usage
	}
	set uid [incr ::tls::srvuid]

	set port [lindex $args [expr {$argc-1}]]
	lappend sopts $port
	#set sopts [linsert $sopts 0 -server $callback]
	set sopts [linsert $sopts 0 -server [list tls::_accept $iopts $callback]]
	#set sopts [linsert $sopts 0 -server [list tls::_accept $uid $callback]]
    } else {
	if {($idx + 2) != $argc} {
	    return -code error $usage
	}
	set host [lindex $args [expr {$argc-2}]]
	set port [lindex $args [expr {$argc-1}]]
	lappend sopts $host $port
    }
    #
    # Create TCP/IP socket
    #
    set chan [eval $socketCmd $sopts]
    if {!$server && [catch {
	#
	# Push SSL layer onto socket
	#
	eval [list tls::import] $chan $iopts
    } err]} {
	set info ${::errorInfo}
	catch {close $chan}
	return -code error -errorinfo $info $err
    }
    return $chan
}

# tls::_accept --
#
#   This is the actual accept that TLS sockets use, which then calls
#   the callback registered by tls::socket.
#
# Arguments:
#   iopts	tls::import opts
#   callback	server callback to invoke
#   chan	socket channel to accept/deny
#   ipaddr	calling IP address
#   port	calling port
#
# Results:
#   Returns an error if the callback throws one.
#
proc tls::_accept { iopts callback chan ipaddr port } {
    log 2 [list tls::_accept $iopts $callback $chan $ipaddr $port]

    set chan [eval [list tls::import $chan] $iopts]

    lappend callback $chan $ipaddr $port
    if {[catch {
	uplevel #0 $callback
    } err]} {
	log 1 "tls::_accept error: ${::errorInfo}"
	close $chan
	error $err $::errorInfo $::errorCode
    } else {
	log 2 "tls::_accept - called \"$callback\" succeeded"
    }
}
#
# Sample callback for hooking: -
#
# error
# verify
# info
#
proc tls::callback {option args} {
    variable debug

    #log 2 [concat $option $args]

    switch -- $option {
	"error"	{
	    foreach {chan msg} $args break

	    log 0 "TLS/$chan: error: $msg"
	}
	"verify"	{
	    # poor man's lassign
	    foreach {chan depth cert rc err} $args break

	    array set c $cert

	    if {$rc != "1"} {
		log 1 "TLS/$chan: verify/$depth: Bad Cert: $err (rc = $rc)"
	    } else {
		log 2 "TLS/$chan: verify/$depth: $c(subject)"
	    }
	    if {$debug > 0} {
		return 1;	# FORCE OK
	    } else {
		return $rc
	    }
	}
	"info"	{
	    # poor man's lassign
	    foreach {chan major minor state msg} $args break

	    if {$msg != ""} {
		append state ": $msg"
	    }
	    # For tracing
	    upvar #0 tls::$chan cb
	    set cb($major) $minor

	    log 2 "TLS/$chan: $major/$minor: $state"
	}
	default	{
	    return -code error "bad option \"$option\":\
		    must be one of error, info, or verify"
	}
    }
}

proc tls::xhandshake {chan} {
    upvar #0 tls::$chan cb

    if {[info exists cb(handshake)] && \
	$cb(handshake) == "done"} {
	return 1
    }
    while {1} {
	vwait tls::${chan}(handshake)
	if {![info exists cb(handshake)]} {
	    return 0
	}
	if {$cb(handshake) == "done"} {
	    return 1
	}
    }
}

proc tls::password {} {
    log 0 "TLS/Password: did you forget to set your passwd!"
    # Return the worlds best kept secret password.
    return "secret"
}

proc tls::log {level msg} {
    variable debug
    variable logcmd

    if {$level > $debug || $logcmd == ""} {
	return
    }
    set cmd $logcmd
    lappend cmd $msg
    uplevel #0 $cmd
}

# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

package ifneeded softwareupdate 1.4 [list source [file join $dir softwareupdate.tcl]]

# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

package ifneeded softwareupdate 1.5 [list source [file join $dir softwareupdate.tcl]]

#softwareupdate.tcl  routines to manage spoftware updates

#  Copyright (C) 2014  WordTech Communications LLC

#MIT license

package provide softwareupdate 1.4
package require http
package require tdom



namespace eval softwareupdate {

    if {![info exists library]} {
	variable library [file dirname [info script]]
    }

................................................................................

    #check version of installed software
    proc checkVersion {app version} {
	variable appversion
	variable appname
	variable currentversion
	variable versionnumber
	variable appcast
	variable sparkledata
	variable changedata


	set appname $app


	softwareupdate::checkingForUpdates

	set appcast http://www.codebykevin.com/[string tolower $appname].xml
	http::config -useragent "$appname Update Check"

	set xml [http::data [http::geturl $appcast]]

	if [catch {http::geturl $appcast} msg] {
	    puts "error: $msg"
	    tk_messageBox -icon info -title "" -message "Update Error!" -detail "An error occurred in retrieving update information.\nPlease try again later."

	    return
	} 



	dom parse $xml sparkledata
	set versionnumber [string trim [$sparkledata selectNodes -namespaces [list x "http://www.andymatuschak.org/xml-namespaces/sparkle"] {string(//enclosure/@x:version)}] .0]

	set changedata [$sparkledata selectNodes {string(//description/text())}]

	set minOS [$sparkledata selectNodes -namespaces [list x "http://www.andymatuschak.org/xml-namespaces/sparkle"] {string(//x:minimumSystemVersion)}]


	if {[tk windowingsystem] eq "aqua"] {
	    set hostOS [exec sw_vers -productVersion]

	    if {![package vsatisfies $hostOS $minOS]} {
		tk_messageBox -icon warning -message "Error!" -detail "$appname is not supported on Mac OS X $hostOS. The minimum supported OS version is $minOS." 
		return
	    }
	}
	
	if {[expr $currentversion < $versionnumber]} {
	    softwareupdate::updatePitch
	} else {
	    softwareupdate::upToDate
	}
    }
}

#define the current version of the software
proc setVersion {app number} {
    variable currentversion
    variable appname
    set currentversion $number
................................................................................
	}
    }
    
    return $currentinstall

}

#prompt user to update: for Perl, which chokes on XML parsing from Tcl
proc updatePitchPerl {apptitle appnumber currentapp changelog} {
    variable appname
    variable icon
    variable changedata
    variable currentversion
    variable versionnumber
    variable changelist

    catch {destroy .updateprogress}

    catch {destroy .update}


    toplevel .update
    wm title .update "Software Update"

    wm withdraw .update

    frame .update.f -bg gray95
    pack .update.f -fill both -expand yes

    frame .update.f.top -bg gray95
    pack .update.f.top -fill both -expand yes

    label .update.f.top.i -image $icon -bg gray95 -relief flat -highlightthickness 0
    pack .update.f.top.i -side left -fill both -expand yes

    frame .update.f.top.r -bg gray95
    pack .update.f.top.r -side right -fill both -expand yes

    label .update.f.top.r.title -text "A new version of $apptitle is available!" -font {-weight bold} -bg gray95 -relief flat -highlightthickness 0
    pack .update.f.top.r.title -fill both -expand yes -side top

    label .update.f.top.r.msg -text "$apptitle $appnumber is available--you have $currentapp. Would you like to download it now?" -bg gray95 -relief flat -highlightthickness 0
    pack .update.f.top.r.msg -fill both -expand yes -side top

    label .update.f.top.r.release -text "Release Notes:" -font {-weight bold} -relief flat -highlightthickness 0 -bg gray95 
    pack .update.f.top.r.release -side top -fill both -expand yes

    text .update.f.top.r.text -font TkDefaultFont
    pack .update.f.top.r.text -side top -fill both -expand yes

    ttk::frame .update.f.top.r.bottom -padding 5
    pack .update.f.top.r.bottom -side bottom -fill both -expand yes

    ttk::button .update.f.top.r.bottom.skip -text "Skip This Version" -command {destroy .update}

    ttk::button .update.f.top.r.bottom.install -text "Install Update" -default active -command softwareupdate::installUpdate
    
    pack .update.f.top.r.bottom.install .update.f.top.r.bottom.skip  -side right  -fill both -expand yes

    set changetext [split $changelog *]

    set changetext [lrange $changetext 1 end]

    foreach item $changetext {
	
	.update.f.top.r.text insert end "* $item\n"

    }

    .update.f.top.r.text configure -state disabled

    wm resizable .update 0 0
    wm deiconify .update
    raise .update
    wm transient .update .

}


#prompt user to update
proc updatePitch {} {
    variable appname
    variable icon
    variable changedata
................................................................................
    variable currentversion
    variable versionnumber

    catch {destroy .updateprogress}

    catch {destroy .update}
    


    toplevel .update
    wm title .update "Software Update"

    wm withdraw .update


    frame .update.f -bg gray95
    pack .update.f -fill both -expand yes

    frame .update.f.top -bg gray95
    pack .update.f.top -fill both -expand yes

    label .update.f.top.i -image $icon -bg gray95 -relief flat -highlightthickness 0
    pack .update.f.top.i -side left -fill both -expand yes

    frame .update.f.top.r -bg gray95
    pack .update.f.top.r -side right -fill both -expand yes


    label .update.f.top.r.title -text "A new version of $appname is available!" -font {-weight bold} -bg gray95 -relief flat -highlightthickness 0
    pack .update.f.top.r.title -fill both -expand yes -side top

    label .update.f.top.r.msg -text "$appname $versionnumber is available--you have $currentversion. Would you like to download it now?" -font {-size 10} -bg gray95 -relief flat -highlightthickness 0
    pack .update.f.top.r.msg -fill both -expand yes -side top

    label .update.f.top.r.release -text "Release Notes:" -font {-size 10 -weight bold} -relief flat -highlightthickness 0 -bg gray95 
    pack .update.f.top.r.release -side top -fill both -expand yes

    text .update.f.top.r.text -font TkDefaultFont
    pack .update.f.top.r.text -side top -fill both -expand yes

    ttk::frame .update.f.top.r.bottom -padding 5
    pack .update.f.top.r.bottom -side bottom -fill both -expand yes

    ttk::button .update.f.top.r.bottom.skip -text "Skip This Version" -command {destroy .update}




    ttk::button .update.f.top.r.bottom.install -text "Install Update" -default active -command softwareupdate::installUpdate
    
    pack .update.f.top.r.bottom.install .update.f.top.r.bottom.skip  -side right  -fill both -expand yes




    .update.f.top.r.text insert end $changedata

    .update.f.top.r.text configure -state disabled

    wm resizable .update 0 0
    wm deiconify .update
    raise .update
    wm transient .update .

}

proc winPitch {name newversion oldversion} {
    set answer [tk_messageBox  -icon info -title "New Version Available" -message "New Version Available" -detail "$name $newversion is available--you have $oldversion. Would you like to download it now?" -type yesno
	       ]

    switch -- $answer {
	yes {

	    xplat::launch http://www.codebykevin.com/$name.html
	}
	no {
	    return
	}
    }
}
#"busy" dialog
................................................................................

    softwareupdate::progressDialog
    set status "Downloading update for $appname"
    
    switch [tk windowingsystem] {

	"aqua" {
	    http::geturl http://www.codebykevin.com/updates/[list $appname].tgz -channel [open $tmpdir/[list $appname].tgz w] 
	    update
	    after 1000
	    cd $tmpdir
	    set status "Unpacking update for $appname"
	    update
	    after 1000
	    catch {exec tar xvfz [list $appname].tgz}
	}
	
	"win32" {
	    
	    http::geturl http://www.codebykevin.com/updates/[list $appname].exe -channel [open $tmpdir/[list $appname].exe w] 

	}
	
	"x11" {
	    tk_messageBox -icon info -parent . -message "Please ask the maintainer of $appname on your platform to prepare a release of the latest version."
	    return
	}
................................................................................
    variable currentinstall
    variable appname
    variable tmpdir
    
    switch [tk windowingsystem] {

	"aqua" {
	    if {[catch {exec codesign -v $tmpdir/$appname.app} msg]} {
		bgerror $msg
		tk_messageBox -icon warning -message "Error!" -detail "An error occurred in the installation of $appname. Please try again later."
		return
	    } else {

		file rename -force $currentinstall [file join /Users [exec whoami] .Trash [file tail $currentinstall]]

		file rename -force /tmp/$appname.app $currentinstall

		exec $currentinstall/Contents/MacOS/$appname &

		exit
	    }

	}
	
	"win32" {
	    
	    softwareupdate::writeBatch $appname
	    eval exec [auto_execok start]  /b "" cmd /c [file join $tmpdir deleteapp.bat] &
	}
	
	"x11" {
	    tk_messageBox -icon info -parent . -message "Please ask the maintainer of $appname on your platform to prepare a release of the latest version."
	    return
	}
    }
................................................................................
    catch {destroy .downloadprogress}

    

}


proc writeBatch {appname} {

    variable tmpdir
    variable currentinstall

    set script {
	cd  $currentinstall 
	taskkill /IM $appname.exe /F
	rename $appname.exe ${appname}-tmp.exe 
	cd $tmpdir
	copy [file nativename [file join $tmpdir $appname.exe]] [file nativename [file join $currentinstall $appname.exe]]
	cd $currentinstall
	start $appname.exe
	del ${appname}-tmp.exe
	cd $tmpdir
	::del deleteapp.bat
    }

    set batchscript [subst $script]
    set delscript [open [file join $tmpdir deleteapp.bat] w]
    puts $delscript $batchscript
    close $delscript


}

namespace export *

}

#softwareupdate.tcl  routines to manage spoftware updates

#  Copyright (C) 2014  WordTech Communications LLC

#MIT license

package provide softwareupdate 1.5
package require http
package require tls

http::register https 443 [list ::tls::socket -tls1 1]   ;# "-tls1 1" is required since [POODLE]

namespace eval softwareupdate {

    if {![info exists library]} {
	variable library [file dirname [info script]]
    }

................................................................................

    #check version of installed software
    proc checkVersion {app version} {
	variable appversion
	variable appname
	variable currentversion
	variable versionnumber





	set appname $app


	softwareupdate::checkingForUpdates

	set versionurl https://www.codebykevin.com/version.tcl
	http::config -useragent "$appname Update Check"



	if [catch {http::geturl $versionurl} msg] {
	    puts "error: $msg"

	    tk_messageBox -icon warning -title "Unable to Connect to Server" -message "Unable to Connect to Server" -detail "Unable to connect to www.codebykevin.com to check for updates. Please make sure you are connected to the Internet." -parent .
	    return
	} 

	array set appversion [http::data [http::geturl $versionurl]]
	set versionnumber $appversion([string tolower $appname])
	puts $version
















	if {$currentversion < $versionnumber} {
	    softwareupdate::updatePitch
	} else {
	    softwareupdate::upToDate
	}

}

#define the current version of the software
proc setVersion {app number} {
    variable currentversion
    variable appname
    set currentversion $number
................................................................................
	}
    }
    
    return $currentinstall

}









































































#prompt user to update
proc updatePitch {} {
    variable appname
    variable icon
    variable changedata
................................................................................
    variable currentversion
    variable versionnumber

    catch {destroy .updateprogress}

    catch {destroy .update}
    
	variable appname


	set changeurl https://www.codebykevin.com/$appname-changes.tcl

        if [catch {http::geturl $changeurl} msg] {

	    puts "error: $msg"
	    tk_messageBox -icon warning -title "Unable to Connect to Server" -message "Unable to Connect to Server" -detail "Unable to connect to www.codebykevin.com to check for updates. Please make sure you are connected to the Internet." -parent .
	    return
	} 








	set changelist [http::data [http::geturl $changeurl]]


















	set updateanswer [tk_messageBox -title "Update" -icon info -message "Update Available" -detail "A new version ($softwareupdate::versionnumber) of $appname is available.\n\nThis new version features the following updates and changes:\n\n$changelist\n\nWould you like to install it? " -type yesno -parent .]
	switch -- $updateanswer {
	    yes {
		softwareupdate::installUpdate
	    }

	    no {
		destroy $updateanswer
		return
	    }

	    

	}





}

proc winPitch {name newversion oldversion} {
    set answer [tk_messageBox  -icon info -title "New Version Available" -message "New Version Available" -detail "$name $newversion is available--you have $oldversion. Would you like to download it now?" -type yesno
	       ]

    switch -- $answer {
	yes {

	    xplat::launch https://www.codebykevin.com/$name.html
	}
	no {
	    return
	}
    }
}
#"busy" dialog
................................................................................

    softwareupdate::progressDialog
    set status "Downloading update for $appname"
    
    switch [tk windowingsystem] {

	"aqua" {
	    http::geturl https://www.codebykevin.com/updates/[list $appname].dmg -channel [open $tmpdir/[list $appname].dmg w] 
	    update
	    after 1000
	    cd $tmpdir
	    set status "Attaching [list $appname].dmg"
	    update

	    exec hdiutil attach [list $appname].dmg
	}
	
	"win32" {
	    
	    http::geturl https://www.codebykevin.com/updates/[list $appname]_Setup.exe -channel [open $tmpdir/[list $appname]_Setup.exe w]

	}
	
	"x11" {
	    tk_messageBox -icon info -parent . -message "Please ask the maintainer of $appname on your platform to prepare a release of the latest version."
	    return
	}
................................................................................
    variable currentinstall
    variable appname
    variable tmpdir
    
    switch [tk windowingsystem] {

	"aqua" {






		file rename -force $currentinstall [file join /Users [exec whoami] .Trash [file tail $currentinstall]]

		file copy -force /Volumes/[list $appname]/[list $appname].app $currentinstall

		exec $currentinstall/Contents/MacOS/$appname &

		exec hdiutil detach /Volumes/[list $appname]

		exit
	    }
	
	"win32" {
	    
	    eval exec [auto_execok start] $tmpdir/[list $appname]_Setup.exe &
	    exit
	}
	
	"x11" {
	    tk_messageBox -icon info -parent . -message "Please ask the maintainer of $appname on your platform to prepare a release of the latest version."
	    return
	}
    }
................................................................................
    catch {destroy .downloadprogress}

    

}




























namespace export *

}

package ifneeded tdom 0.8.3  "load [list [file join $dir tdom083.dll]]; source [list [file join $dir tdom.tcl]]"

#----------------------------------------------------------------------------
#   Copyright (c) 1999 Jochen Loewer (loewerj@hotmail.com)
#----------------------------------------------------------------------------
#
#   $Id$
#
#
#   The higher level functions of tDOM written in plain Tcl.
#
#
#   The contents of this file are subject to the Mozilla Public License
#   Version 1.1 (the "License"); you may not use this file except in
#   compliance with the License. You may obtain a copy of the License at
#   http://www.mozilla.org/MPL/
#
#   Software distributed under the License is distributed on an "AS IS"
#   basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
#   License for the specific language governing rights and limitations
#   under the License.
#
#   The Original Code is tDOM.
#
#   The Initial Developer of the Original Code is Jochen Loewer
#   Portions created by Jochen Loewer are Copyright (C) 1998, 1999
#   Jochen Loewer. All Rights Reserved.
#
#   Contributor(s):
#       Rolf Ade (rolf@pointsman.de):   'fake' nodelists/live childNodes
#
#   written by Jochen Loewer
#   April, 1999
#
#----------------------------------------------------------------------------

package require tdom 

#----------------------------------------------------------------------------
#   setup namespaces for additional Tcl level methods, etc.
#
#----------------------------------------------------------------------------
namespace eval ::dom {
    namespace eval  domDoc {
    }
    namespace eval  domNode {
    }
    namespace eval  DOMImplementation {
    }
    namespace eval  xpathFunc {
    }
    namespace eval  xpathFuncHelper {
    }
}

namespace eval ::tDOM { 
    variable extRefHandlerDebug 0
    variable useForeignDTD ""

    namespace export xmlOpenFile xmlReadFile extRefHandler baseURL
}

#----------------------------------------------------------------------------
#   hasFeature (DOMImplementation method)
#
#
#   @in  url    the URL, where to get the XML document
#
#   @return     document object
#   @exception  XML parse errors, ...
#
#----------------------------------------------------------------------------
proc ::dom::DOMImplementation::hasFeature { dom feature {version ""} } {

    switch $feature {
        xml -
        XML {
            if {($version == "") || ($version == "1.0")} {
                return 1
            }
        }
    }
    return 0

}

#----------------------------------------------------------------------------
#   load (DOMImplementation method)
#
#       requests a XML document via http using the given URL and
#       builds up a DOM tree in memory returning the document object
#
#
#   @in  url    the URL, where to get the XML document
#
#   @return     document object
#   @exception  XML parse errors, ...
#
#----------------------------------------------------------------------------
proc ::dom::DOMImplementation::load { dom url } {

    error "Sorry, load method not implemented yet!"

}

#----------------------------------------------------------------------------
#   isa (docDoc method, for [incr tcl] compatibility)
#
#
#   @in  className
#
#   @return         1 iff inherits from the given class
#
#----------------------------------------------------------------------------
proc ::dom::domDoc::isa { doc className } {

    if {$className == "domDoc"} {
        return 1
    }
    return 0
}

#----------------------------------------------------------------------------
#   info (domDoc method, for [incr tcl] compatibility)
#
#
#   @in  subcommand
#   @in  args
#
#----------------------------------------------------------------------------
proc ::dom::domDoc::info { doc subcommand args } {

    switch $subcommand {
        class {
            return "domDoc"
        }
        inherit {
            return ""
        }
        heritage {
            return "domDoc {}"
        }
        default {
            error "domDoc::info subcommand $subcommand not yet implemented!"
        }
    }
}

#----------------------------------------------------------------------------
#   importNode (domDoc method)
#
#       Document Object Model (Core) Level 2 method
#
#
#   @in  subcommand
#   @in  args
#
#----------------------------------------------------------------------------
proc ::dom::domDoc::importNode { doc importedNode deep } {

    if {$deep || ($deep == "-deep")} {
        set node [$importedNode cloneNode -deep]
    } else {
        set node [$importedNode cloneNode]
    }
    return $node
}

#----------------------------------------------------------------------------
#   isa (domNode method, for [incr tcl] compatibility)
#
#
#   @in  className
#
#   @return         1 iff inherits from the given class
#
#----------------------------------------------------------------------------
proc ::dom::domNode::isa { doc className } {

    if {$className == "domNode"} {
        return 1
    }
    return 0
}

#----------------------------------------------------------------------------
#   info (domNode method, for [incr tcl] compatibility)
#
#
#   @in  subcommand
#   @in  args
#
#----------------------------------------------------------------------------
proc ::dom::domNode::info { doc subcommand args } {

    switch $subcommand {
        class {
            return "domNode"
        }
        inherit {
            return ""
        }
        heritage {
            return "domNode {}"
        }
        default {
            error "domNode::info subcommand $subcommand not yet implemented!"
        }
    }
}

#----------------------------------------------------------------------------
#   isWithin (domNode method)
#
#       tests, whether a node object is nested below another tag
#
#
#   @in  tagName  the nodeName of an elment node
#
#   @return       1 iff node is nested below a element with nodeName tagName
#                 0 otherwise
#
#----------------------------------------------------------------------------
proc ::dom::domNode::isWithin { node tagName } {

    while {[$node parentNode] != ""} {
        set node [$node parentNode]
        if {[$node nodeName] == $tagName} {
            return 1
        }
    }
    return 0
}

#----------------------------------------------------------------------------
#   tagName (domNode method)
#
#       same a nodeName for element interface
#
#----------------------------------------------------------------------------
proc ::dom::domNode::tagName { node } {

    if {[$node nodeType] == "ELEMENT_NODE"} {
        return [$node nodeName]
    }
    return -code error "NOT_SUPPORTED_ERR not an element!"
}

#----------------------------------------------------------------------------
#   simpleTranslate (domNode method)
#
#       applies simple translation rules similar to Cost's simple
#       translations to a node
#
#
#   @in  output_var
#   @in  trans_specs
#
#----------------------------------------------------------------------------
proc ::dom::domNode::simpleTranslate { node output_var trans_specs } {

    upvar $output_var output

    if {[$node nodeType] == "TEXT_NODE"} {
        append output [cgiQuote [$node nodeValue]]
        return
    }
    set found 0

    foreach {match action} $trans_specs {

        if {[catch {
            if {!$found && ([$node selectNode self::$match] != "") } {
              set found 1
            }
        } err]} {
            if {![string match "NodeSet expected for parent axis!" $err]} {
                error $err
            }
        }
        if {$found && ($action != "-")} {
            set stop 0
            foreach {type value} $action {
                switch $type {
                    prefix { append output [subst $value] }
                    tag    { append output <$value>       }
                    start  { append output [eval $value]  }
                    stop   { set stop 1                   }
                }
            }
            if {!$stop} {
                foreach child [$node childNodes] {
                    simpleTranslate  $child output $trans_specs
                }
            }
            foreach {type value} $action {
                switch $type {
                    suffix { append output [subst $value] }
                    end    { append output [eval $value]  }
                    tag    { append output </$value>      }
                }
            }
            return
        }
    }
    foreach child [$node childNodes] {
        simpleTranslate $child output $trans_specs
    }
}

#----------------------------------------------------------------------------
#   a DOM conformant 'live' childNodes
#
#   @return   a 'nodelist' object (it is just the normal node)
#
#----------------------------------------------------------------------------
proc ::dom::domNode::childNodesLive { node } {

    return $node
}

#----------------------------------------------------------------------------
#   item method on a 'nodelist' object
#
#   @return   a 'nodelist' object (it is just a normal
#
#----------------------------------------------------------------------------
proc ::dom::domNode::item { nodeListNode index } {

    return [lindex [$nodeListNode childNodes] $index]
}

#----------------------------------------------------------------------------
#   length method on a 'nodelist' object
#
#   @return   a 'nodelist' object (it is just a normal
#
#----------------------------------------------------------------------------
proc ::dom::domNode::length { nodeListNode } {

    return [llength [$nodeListNode childNodes]]
}

#----------------------------------------------------------------------------
#   appendData on a 'CharacterData' object
#
#----------------------------------------------------------------------------
proc ::dom::domNode::appendData { node  arg } {

    set type [$node nodeType]
    if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") &&
        ($type != "COMMENT_NODE")
    } {
        return -code error "NOT_SUPPORTED_ERR: node is not a cdata node"
    }
    set oldValue [$node nodeValue]
    $node nodeValue [append oldValue $arg]
}

#----------------------------------------------------------------------------
#   deleteData on a 'CharacterData' object
#
#----------------------------------------------------------------------------
proc ::dom::domNode::deleteData { node offset count } {

    set type [$node nodeType]
    if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") &&
        ($type != "COMMENT_NODE")
    } {
        return -code error "NOT_SUPPORTED_ERR: node is not a cdata node"
    }
    incr offset -1
    set before [string range [$node nodeValue] 0 $offset]
    incr offset
    incr offset $count
    set after  [string range [$node nodeValue] $offset end]
    $node nodeValue [append before $after]
}

#----------------------------------------------------------------------------
#   insertData on a 'CharacterData' object
#
#----------------------------------------------------------------------------
proc ::dom::domNode::insertData { node  offset arg } {

    set type [$node nodeType]
    if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") &&
        ($type != "COMMENT_NODE")
    } {
        return -code error "NOT_SUPPORTED_ERR: node is not a cdata node"
    }
    incr offset -1
    set before [string range [$node nodeValue] 0 $offset]
    incr offset
    set after  [string range [$node nodeValue] $offset end]
    $node nodeValue [append before $arg $after]
}

#----------------------------------------------------------------------------
#   replaceData on a 'CharacterData' object
#
#----------------------------------------------------------------------------
proc ::dom::domNode::replaceData { node offset count arg } {

    set type [$node nodeType]
    if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") &&
        ($type != "COMMENT_NODE")
    } {
        return -code error "NOT_SUPPORTED_ERR: node is not a cdata node"
    }
    incr offset -1
    set before [string range [$node nodeValue] 0 $offset]
    incr offset
    incr offset $count
    set after  [string range [$node nodeValue] $offset end]
    $node nodeValue [append before $arg $after]
}

#----------------------------------------------------------------------------
#   substringData on a 'CharacterData' object
#
#   @return   part of the node value (text)
#
#----------------------------------------------------------------------------
proc ::dom::domNode::substringData { node offset count } {

    set type [$node nodeType]
    if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") &&
        ($type != "COMMENT_NODE")
    } {
        return -code error "NOT_SUPPORTED_ERR: node is not a cdata node"
    }
    set endOffset [expr $offset + $count - 1]
    return [string range [$node nodeValue] $offset $endOffset]
}

#----------------------------------------------------------------------------
#   coerce2number
#
#----------------------------------------------------------------------------
proc ::dom::xpathFuncHelper::coerce2number { type value } {
    switch $type {
        empty      { return 0 }
        number -
        string     { return $value }
        attrvalues { return [lindex $value 0] }
        nodes      { return [[lindex $value 0] selectNodes number()] }
        attrnodes  { return [lindex $value 1] }
    }
}

#----------------------------------------------------------------------------
#   coerce2string
#
#----------------------------------------------------------------------------
proc ::dom::xpathFuncHelper::coerce2string { type value } {
    switch $type {
        empty      { return "" }
        number -
        string     { return $value }
        attrvalues { return [lindex $value 0] }
        nodes      { return [[lindex $value 0] selectNodes string()] }
        attrnodes  { return [lindex $value 1] }
    }
}

#----------------------------------------------------------------------------
#   function-available
#
#----------------------------------------------------------------------------
proc ::dom::xpathFunc::function-available { ctxNode pos
                                            nodeListType nodeList args} {

    if {[llength $args] != 2} {
        error "function-available(): wrong # of args!"
    }
    foreach { arg1Typ arg1Value } $args break
    set str [::dom::xpathFuncHelper::coerce2string $arg1Typ $arg1Value ]
    switch $str {
        boolean -
        ceiling -
        concat -
        contains -
        count -
        current -
        document -
        element-available -
        false -
        floor -
        format-number -
        generate-id -
        id -
        key -
        last -
        lang -
        local-name -
        name -
        namespace-uri -
        normalize-space -
        not -
        number -
        position -
        round -
        starts-with -
        string -
        string-length -
        substring -
        substring-after -
        substring-before -
        sum -
        translate -
        true -
        unparsed-entity-uri {
            return [list bool true]
        }
        default {
            set TclXpathFuncs [info procs ::dom::xpathFunc::*]
            if {[lsearch -exact $TclXpathFuncs $str] != -1} {
                return [list bool true]
            } else {
                return [list bool false]
            }
        }
    }
}

#----------------------------------------------------------------------------
#   element-available
#
#   This is not strictly correct. The XSLT namespace may be bound
#   to another prefix (and the prefix 'xsl' may be bound to another
#   namespace). Since the expression context isn't available at the
#   moment at tcl coded XPath functions, this couldn't be done better
#   than this "works in the 'normal' cases" version.
#----------------------------------------------------------------------------
proc ::dom::xpathFunc::element-available { ctxNode pos
                                            nodeListType nodeList args} {

    if {[llength $args] != 2} {
        error "element-available(): wrong # of args!"
    }
    foreach { arg1Typ arg1Value } $args break
    set str [::dom::xpathFuncHelper::coerce2string $arg1Typ $arg1Value ]
    # The XSLT recommendation says: "The element-available
    # function returns true if and only if the expanded-name
    # is the name of an instruction." The following xsl
    # elements are not in the category instruction.
    # xsl:attribute-set 
    # xsl:decimal-format 
    # xsl:include
    # xsl:key 
    # xsl:namespace-alias
    # xsl:output
    # xsl:param
    # xsl:strip-space
    # xsl:preserve-space
    # xsl:template
    # xsl:import
    # xsl:otherwise
    # xsl:sort
    # xsl:stylesheet
    # xsl:transform
    # xsl:with-param
    # xsl:when
    switch $str {
        xsl:apply-templates -
        xsl:apply-imports -
        xsl:call-template -
        xsl:element -
        xsl:attribute -
        xsl:text -
        xsl:processing-instruction -
        xsl:comment -
        xsl:copy -
        xsl:value-of -
        xsl:number -
        xsl:for-each -
        xsl:if -
        xsl:choose -
        xsl:variable -
        xsl:copy-of -
        xsl:message -
        xsl:fallback {
            return [list bool true]
        }
        default {
            return [list bool false]
        }
    }
}

#----------------------------------------------------------------------------
#   system-property
#
#   This is not strictly correct. The XSLT namespace may be bound
#   to another prefix (and the prefix 'xsl' may be bound to another
#   namespace). Since the expression context isn't available at the
#   moment at tcl coded XPath functions, this couldn't be done better
#   than this "works in the 'normal' cases" version.
#----------------------------------------------------------------------------
proc ::dom::xpathFunc::system-property { ctxNode pos
                                         nodeListType nodeList args } {

    if {[llength $args] != 2} {
        error "system-property(): wrong # of args!"
    }
    foreach { arg1Typ arg1Value } $args break
    set str [::dom::xpathFuncHelper::coerce2string $arg1Typ $arg1Value ]
    switch $str {
        xsl:version {
            return [list number 1.0]
        }
        xsl:vendor {
            return [list string "Jochen Loewer (loewerj@hotmail.com), Rolf Ade (rolf@pointsman.de) et. al."]
        }
        xsl:vendor-url {
            return [list string "http://www.tdom.org"]
        }
        default {
            return [list string ""]
        }
    }
}

#----------------------------------------------------------------------------
#   IANAEncoding2TclEncoding
#
#----------------------------------------------------------------------------

# As of version 8.3.4 tcl supports 
# cp860 cp861 cp862 cp863 tis-620 cp864 cp865 cp866 gb12345 cp949
# cp950 cp869 dingbats ksc5601 macCentEuro cp874 macUkraine jis0201
# gb2312 euc-cn euc-jp iso8859-10 macThai jis0208 iso2022-jp
# macIceland iso2022 iso8859-13 iso8859-14 jis0212 iso8859-15 cp737
# iso8859-16 big5 euc-kr macRomania macTurkish gb1988 iso2022-kr
# macGreek ascii cp437 macRoman iso8859-1 iso8859-2 iso8859-3 ebcdic
# macCroatian koi8-r iso8859-4 iso8859-5 cp1250 macCyrillic iso8859-6
# cp1251 koi8-u macDingbats iso8859-7 cp1252 iso8859-8 cp1253
# iso8859-9 cp1254 cp1255 cp850 cp1256 cp932 identity cp1257 cp852
# macJapan cp1258 shiftjis utf-8 cp855 cp936 symbol cp775 unicode
# cp857
# 
# Just add more mappings (and mail them to the tDOM mailing list, please).

proc tDOM::IANAEncoding2TclEncoding {IANAName} {
    
    # First the most widespread encodings with there
    # preferred MIME name, to speed lookup in this
    # usual cases. Later the official names and the
    # aliases.
    #
    # For "official names for character sets that may be
    # used in the Internet" see 
    # http://www.iana.org/assignments/character-sets
    # (that's the source for the encoding names below)
    # 
    # Matching is case-insensitive

    switch [string tolower $IANAName] {
        "us-ascii"    {return ascii}
        "utf-8"       {return utf-8}
        "utf-16"      {return unicode; # not sure about this}
        "iso-8859-1"  {return iso8859-1}
        "iso-8859-2"  {return iso8859-2}
        "iso-8859-3"  {return iso8859-3}
        "iso-8859-4"  {return iso8859-4}
        "iso-8859-5"  {return iso8859-5}
        "iso-8859-6"  {return iso8859-6}
        "iso-8859-7"  {return iso8859-7}
        "iso-8859-8"  {return iso8859-8}
        "iso-8859-9"  {return iso8859-9}
        "iso-8859-10" {return iso8859-10}
        "iso-8859-13" {return iso8859-13}
        "iso-8859-14" {return iso8859-14}
        "iso-8859-15" {return iso8859-15}
        "iso-8859-16" {return iso8859-16}
        "iso-2022-kr" {return iso2022-kr}
        "euc-kr"      {return euc-kr}
        "iso-2022-jp" {return iso2022-jp}
        "koi8-r"      {return koi8-r}
        "shift_jis"   {return shiftjis}
        "euc-jp"      {return euc-jp}
        "gb2312"      {return gb2312}
        "big5"        {return big5}
        "cp866"       {return cp866}
        "cp1250"      {return cp1250}
        "cp1253"      {return cp1253}
        "cp1254"      {return cp1254}
        "cp1255"      {return cp1255}
        "cp1256"      {return cp1256}
        "cp1257"      {return cp1257}

        "windows-1251" -
        "cp1251"      {return cp1251}

        "windows-1252" -
        "cp1252"      {return cp1252}    

        "iso_8859-1:1987" -
        "iso-ir-100" -
        "iso_8859-1" -
        "latin1" -
        "l1" -
        "ibm819" -
        "cp819" -
        "csisolatin1" {return iso8859-1}
        
        "iso_8859-2:1987" -
        "iso-ir-101" -
        "iso_8859-2" -
        "iso-8859-2" -
        "latin2" -
        "l2" -
        "csisolatin2" {return iso8859-2}

        "iso_8859-5:1988" -
        "iso-ir-144" -
        "iso_8859-5" -
        "iso-8859-5" -
        "cyrillic" -
        "csisolatincyrillic" {return iso8859-5}

        "ms_kanji" -
        "csshiftjis"  {return shiftjis}
        
        "csiso2022kr" {return iso2022-kr}

        "ibm866" -
        "csibm866"    {return cp866}
        
        default {
            # There are much more encoding names out there
            # It's only laziness, that let me stop here.
            error "Unrecognized encoding name '$IANAName'"
        }
    }
}

#----------------------------------------------------------------------------
#   xmlOpenFile
#
#----------------------------------------------------------------------------
proc tDOM::xmlOpenFile {filename {encodingString {}}} {

    set fd [open $filename]

    if {$encodingString != {}} {
        upvar $encodingString encString
    }

    # The autodetection of the encoding follows
    # XML Recomendation, Appendix F

    fconfigure $fd -encoding binary
    if {![binary scan [read $fd 4] "H8" firstBytes]} {
        # very short (< 4 Bytes) file
        seek $fd 0 start
        set encString UTF-8
        return $fd
    }
    
    # First check for BOM
    switch [string range $firstBytes 0 3] {
        "feff" -
        "fffe" {
            # feff: UTF-16, big-endian BOM
            # ffef: UTF-16, little-endian BOM
            seek $fd 0 start
            set encString UTF-16            
            fconfigure $fd -encoding identity
            return $fd
        }
    }

    # If the entity has a XML Declaration, the first four characters
    # must be "<?xm".
    switch $firstBytes {
        "3c3f786d" {
            # UTF-8, ISO 646, ASCII, some part of ISO 8859, Shift-JIS,
            # EUC, or any other 7-bit, 8-bit, or mixed-width encoding which 
            # ensures that the characters of ASCII have their normal positions,
            # width and values; the actual encoding declaration must be read to
            # detect which of these applies, but since all of these encodings
            # use the same bit patterns for the ASCII characters, the encoding
            # declaration itself be read reliably.

            # First 300 bytes should be enough for a XML Declaration
            # This is of course not 100 percent bullet-proof.
            set head [read $fd 296]

            # Try to find the end of the XML Declaration
            set closeIndex [string first ">" $head]
            if {$closeIndex == -1} {
                error "Weird XML data or not XML data at all"
            }

            seek $fd 0 start
            set xmlDeclaration [read $fd [expr {$closeIndex + 5}]]
            # extract the encoding information
            set pattern {^[^>]+encoding=[\x20\x9\xd\xa]*["']([^ "']+)['"]}
            # emacs: "
            if {![regexp $pattern $head - encStr]} {
                # Probably something like <?xml version="1.0"?>. 
                # Without encoding declaration this must be UTF-8
                set encoding utf-8
                set encString UTF-8
            } else {
                set encoding [IANAEncoding2TclEncoding $encStr]
                set encString $encStr
            }
        }
        "0000003c" -
        "0000003c" -
        "3c000000" -
        "00003c00" {
            # UCS-4
            error "UCS-4 not supported"
        }
        "003c003f" -
        "3c003f00" {
            # UTF-16, big-endian, no BOM
            # UTF-16, little-endian, no BOM
            seek $fd 0 start
            set encoding identity
            set encString UTF-16
        }
        "4c6fa794" {
            # EBCDIC in some flavor
            error "EBCDIC not supported"
        }
        default {
            # UTF-8 without an encoding declaration
            seek $fd 0 start
            set encoding identity
            set encString "UTF-8"
        }
    }
    fconfigure $fd -encoding $encoding
    return $fd
}

#----------------------------------------------------------------------------
#   xmlReadFile
#
#----------------------------------------------------------------------------
proc tDOM::xmlReadFile {filename {encodingString {}}} {

    if {$encodingString != {}} {
        upvar $encodingString encString
    }
    
    set fd [xmlOpenFile $filename encString]
    set data [read $fd [file size $filename]]
    close $fd 
    return $data
}

#----------------------------------------------------------------------------
#   extRefHandler
#   
#   A very simple external entity resolver, included for convenience.
#   Depends on the tcllib package uri and resolves only file URLs. 
#
#----------------------------------------------------------------------------

if {![catch {package require uri}]} {
    proc tDOM::extRefHandler {base systemId publicId} {
        variable extRefHandlerDebug
        variable useForeignDTD

        if {$extRefHandlerDebug} {
            puts stderr "tDOM::extRefHandler called with:"
            puts stderr "\tbase:     '$base'"
            puts stderr "\tsystemId: '$systemId'"
            puts stderr "\tpublicId: '$publicId'"
        }
        if {$systemId == ""} {
            if {$useForeignDTD != ""} {
                set systemId $useForeignDTD
            } else {
                error "::tDOM::useForeignDTD does\
                        not point to the foreign DTD"
            }
        }
        set absolutURI [uri::resolve $base $systemId]
        array set uriData [uri::split $absolutURI]
        switch $uriData(scheme) {
            file {
                return [list string $absolutURI [xmlReadFile $uriData(path)]]
            }
            default {
                error "can only handle file URI's"
            }
        }
    }
}

#----------------------------------------------------------------------------
#   baseURL
#   
#   A simple convenience proc which returns an absolute URL for a given
#   filename.
#
#----------------------------------------------------------------------------

proc tDOM::baseURL {path} {
    switch [file pathtype $path] {
        "relative" {
            return "file://[pwd]/$path"
        }
        default {
            return "file://$path"
        }
    }
}

# EOF

if { $::tcl_platform(platform) ne "windows" } {
     return;
   }

package ifneeded tls 1.6.3 \
    "[list source [file join $dir tls.tcl]] ; \
     [list tls::initlib $dir tls163.dll]"

#
# Copyright (C) 1997-2000 Matt Newman <matt@novadigm.com>
#
# $Header: /cvsroot/tls/tls/tls.tcl,v 1.12 2010/07/27 17:15:47 hobbs2 Exp $
#
namespace eval tls {
    variable logcmd tclLog
    variable debug 0

    # Default flags passed to tls::import
    variable defaults {}

    # Maps UID to Server Socket
    variable srvmap
    variable srvuid 0

    # Over-ride this if you are using a different socket command
    variable socketCmd
    if {![info exists socketCmd]} {
        set socketCmd [info command ::socket]
    }
}

proc tls::initlib {dir dll} {
    # Package index cd's into the package directory for loading.
    # Irrelevant to unixoids, but for Windows this enables the OS to find
    # the dependent DLL's in the CWD, where they may be.
    set cwd [pwd]
    catch {cd $dir}
    if {[string equal $::tcl_platform(platform) "windows"] &&
  ![string equal [lindex [file system $dir] 0] "native"]} {
  # If it is a wrapped executable running on windows, the openssl
  # dlls must be copied out of the virtual filesystem to the disk
  # where Windows will find them when resolving the dependency in
  # the tls dll. We choose to make them siblings of the executable.
  package require starkit
  set dst [file nativename [file dirname $starkit::topdir]]
  foreach sdll [glob -nocomplain -directory $dir -tails *eay32.dll] {
      catch {file delete -force            $dst/$sdll}
      catch {file copy   -force $dir/$sdll $dst/$sdll}
  }
    }
    # These lines added by Mike for Potato
    set bits [::potato::checkbits]
    set files [glob -nocomplain -dir [pwd] -tails *_${bits}bit.dll]
    if { [llength $files] } {
         set dll [lindex $files 0]
       }
    # End addition by Mike for Potato
    set res [catch {uplevel #0 [list load [file join [pwd] $dll]]} err]
    catch {cd $cwd}
    if {$res} {
  namespace eval [namespace parent] {namespace delete tls}
  return -code $res $err
    }
    rename tls::initlib {}
}

#
# Backwards compatibility, also used to set the default
# context options
#
proc tls::init {args} {
    variable defaults

    set defaults $args
}
#
# Helper function - behaves exactly as the native socket command.
#
proc tls::socket {args} {
    variable socketCmd
    variable defaults
    set idx [lsearch $args -server]
    if {$idx != -1} {
  set server 1
  set callback [lindex $args [expr {$idx+1}]]
  set args [lreplace $args $idx [expr {$idx+1}]]

  set usage "wrong # args: should be \"tls::socket -server command ?options? port\""
  set options "-cadir, -cafile, -certfile, -cipher, -command, -keyfile, -myaddr, -password, -request, -require, -ssl2, -ssl3, or -tls1"
    } else {
  set server 0

  set usage "wrong # args: should be \"tls::socket ?options? host port\""
  set options "-async, -cadir, -cafile, -certfile, -cipher, -command, -keyfile, -myaddr, -myport, -password, -request, -require, -ssl2, -ssl3, or -tls1"
    }
    set argc [llength $args]
    set sopts {}
    set iopts [concat [list -server $server] $defaults] ;# Import options

    for {set idx 0} {$idx < $argc} {incr idx} {
  set arg [lindex $args $idx]
  switch -glob -- $server,$arg {
      0,-async  {lappend sopts $arg}
      0,-myport -
      *,-type -
      *,-myaddr {lappend sopts $arg [lindex $args [incr idx]]}
      *,-cadir  -
      *,-cafile -
      *,-certfile -
      *,-cipher -
      *,-command  -
      *,-keyfile  -
      *,-password -
      *,-request  -
      *,-require  -
      *,-ssl2 -
      *,-ssl3 -
      *,-tls1 {lappend iopts $arg [lindex $args [incr idx]]}
      -*    {return -code error "bad option \"$arg\": must be one of $options"}
      default {break}
  }
    }
    if {$server} {
  if {($idx + 1) != $argc} {
      return -code error $usage
  }
  set uid [incr ::tls::srvuid]

  set port [lindex $args [expr {$argc-1}]]
  lappend sopts $port
  #set sopts [linsert $sopts 0 -server $callback]
  set sopts [linsert $sopts 0 -server [list tls::_accept $iopts $callback]]
  #set sopts [linsert $sopts 0 -server [list tls::_accept $uid $callback]]
    } else {
  if {($idx + 2) != $argc} {
      return -code error $usage
  }
  set host [lindex $args [expr {$argc-2}]]
  set port [lindex $args [expr {$argc-1}]]
  lappend sopts $host $port
    }
    #
    # Create TCP/IP socket
    #
    set chan [eval $socketCmd $sopts]
    if {!$server && [catch {
  #
  # Push SSL layer onto socket
  #
  eval [list tls::import] $chan $iopts
    } err]} {
  set info ${::errorInfo}
  catch {close $chan}
  return -code error -errorinfo $info $err
    }
    return $chan
}

# tls::_accept --
#
#   This is the actual accept that TLS sockets use, which then calls
#   the callback registered by tls::socket.
#
# Arguments:
#   iopts tls::import opts
#   callback  server callback to invoke
#   chan  socket channel to accept/deny
#   ipaddr  calling IP address
#   port  calling port
#
# Results:
#   Returns an error if the callback throws one.
#
proc tls::_accept { iopts callback chan ipaddr port } {
    log 2 [list tls::_accept $iopts $callback $chan $ipaddr $port]

    set chan [eval [list tls::import $chan] $iopts]

    lappend callback $chan $ipaddr $port
    if {[catch {
  uplevel #0 $callback
    } err]} {
  log 1 "tls::_accept error: ${::errorInfo}"
  close $chan
  error $err $::errorInfo $::errorCode
    } else {
  log 2 "tls::_accept - called \"$callback\" succeeded"
    }
}
#
# Sample callback for hooking: -
#
# error
# verify
# info
#
proc tls::callback {option args} {
    variable debug

    #log 2 [concat $option $args]

    switch -- $option {
  "error" {
      foreach {chan msg} $args break

      log 0 "TLS/$chan: error: $msg"
  }
  "verify"  {
      # poor man's lassign
      foreach {chan depth cert rc err} $args break

      array set c $cert

      if {$rc != "1"} {
    log 1 "TLS/$chan: verify/$depth: Bad Cert: $err (rc = $rc)"
      } else {
    log 2 "TLS/$chan: verify/$depth: $c(subject)"
      }
      if {$debug > 0} {
    return 1; # FORCE OK
      } else {
    return $rc
      }
  }
  "info"  {
      # poor man's lassign
      foreach {chan major minor state msg} $args break

      if {$msg != ""} {
    append state ": $msg"
      }
      # For tracing
      upvar #0 tls::$chan cb
      set cb($major) $minor

      log 2 "TLS/$chan: $major/$minor: $state"
  }
  default {
      return -code error "bad option \"$option\":\
        must be one of error, info, or verify"
  }
    }
}

proc tls::xhandshake {chan} {
    upvar #0 tls::$chan cb

    if {[info exists cb(handshake)] && \
  $cb(handshake) == "done"} {
  return 1
    }
    while {1} {
  vwait tls::${chan}(handshake)
  if {![info exists cb(handshake)]} {
      return 0
  }
  if {$cb(handshake) == "done"} {
      return 1
  }
    }
}

proc tls::password {} {
    log 0 "TLS/Password: did you forget to set your passwd!"
    # Return the worlds best kept secret password.
    return "secret"
}

proc tls::log {level msg} {
    variable debug
    variable logcmd

    if {$level > $debug || $logcmd == ""} {
  return
    }
    set cmd $logcmd
    lappend cmd $msg
    uplevel #0 $cmd
}