#!/usr/bin/perl

use strict;
use warnings;

use Tk;
#use Tk::TextUndo; #Removed due to bugs that are too much effort to work around ATM
use Tk::Balloon;
use Tk::Clipboard;
use Clone qw(clone);

my $VERSION = '001.000104'; # 1.0 Alpha 4


=begin Todo

Improve general editing
Add Edit menu to access find and replace etc
Dirty document handling
Manage B, F, I, P, R and U flags
Checkmarks for menus
Make menus understand exclusion flags and group exclusive entrys when in same menu
Translate entities (note U flag)
Support snippet text (with formatting)
Disallow relink
handle tables
Figure out node name/id from selection?
LWP to get node name from id
Add email sending facility

=end

=cut

use constant kParaSpace => 6;

my $currentFile = '';
my %tagTypes;       # Style tag data
my %formatFonts;    # Fonts used in style tags. Keyed by tag
my @bindings;       # Key, menu and toolbar bindings.
my %menuItems;      # Child menu widgets keyed by menu label path
my %entities =      # Entities we need to use outside code blocks
    (
    '&', '&',
    '<', '&lt;',
    '>', '&gt;',
    '[', '&#91;',
    ']', '&#93;',
    );
my @stdFlags = (
    'B', # Block level element
    'C', # Clear all or specified tags: C or Ctag (note lower case)
    'F', # Format tag (inline element)
    'I', # Item in a list. Implies B
    'L', # Link
    'N', # Needs block level tag (any one of multiple): Ntag
    'P', # Applies to whole paragraph
    'R', # Readmore text
    'S', # Single spaced text
    'U', # Untranslated - don't translate entities
    'X', # Exclude all or specified tags: X or Xtag (note lower case)
    );
my @filetypes = (
    ['PerlMonks editor', '.PMedit',  'TEXT'],
    ['Text', '.txt',  'TEXT'],
    );


while (<DATA>) {
    # Load the default configuration stuff
    chomp;
    next if ! length;
    last if /^#key /;
    next if /^#/;
    
    my ($tag, $htmlTag, $name, $flagsField, @options) = split /\s*,\s*/;

    (print "Missing entries in tag line ($.): $_"), next if ! defined $flagsField;

    # pull out flags and handle X and C special case flags
    my %flags;
    @flags{@stdFlags} = (0) x @stdFlags; # Preset flags off
    $flags{'C'} = {};
    $flags{'N'} = {};
    $flags{'X'} = {};

    for (split /(?=[A-Z][a-z]*)/, $flagsField) {
        my ($flag, $value) = split /(?<=[A-Z])/, $_;
        
        print "Unhandled flag '$flag' used\n" if ! exists $flags{$flag};
        if (-1 != index 'XC', $flag) {
            $flags{$flag}{$value || 'ALL'} = 1;
            $flags{'C'}{$value || 'ALL'} = 1 if $flag eq 'X'; # X implies C
        } elsif ($flag eq 'N') {
            if (! defined $value) {
                print "Flag N requires a block tag - it has been ignored for $tag.\n";
            } else {
                $flags{$flag} = $value || 1;
            }
        } else {
            $flags{$flag} = $value || 1;
            $flags{'B'} = $value || 1 if $flag eq 'I';
        }
    }

    #Fix up options
    my $optionStr = join ', ', @options;
    my %optionHash;
    
    while ($optionStr =~ /\G,?\s*((?:(?!=>).)*)=>\s*(\[[^\]]*\]|[^,]*),?\s*/g) {
        my ($option, $value) = ($1, $2);
        
        trim (\$option, \$value);
        
        if ($value =~ s/\[|\]//g) {
            # Nested options. Turn them into a hash
            my @options = split ',', $value;
            my %optionHash;
            
            for (@options) {
                my ($suboption, $subvalue) = split /\s*=>\s*/;
                
                last if ! defined $subvalue;
                trim (\$suboption, \$subvalue);
                $optionHash{$suboption} = $subvalue;
            }
            
            $value = \%optionHash;
        }
        
        $optionHash{$option} = $value;
    }
    
    $tagTypes{$tag} = [$htmlTag, $name, \%flags, \%optionHash];
}

while (<DATA>) {
    # Load key binding information
    next if /^#/;
    chomp;
    next if ! length;
    

    my ($tag, $key, $menuItem, $toolbarItem, $rightClickItem) = split /\s*,\s*/;
    (print "Missing tag in binding line ($.): $_"), next if ! defined $tag;
    push @bindings, [$tag, "$key", $menuItem, $toolbarItem, $rightClickItem];
}

my $mw = MainWindow->new (-title => "PerlMonks node editor");
my $text = $mw->Scrolled
    ('Text', -font => 'normal', -wrap => 'word', -scrollbars => 'e',);

my $status = $mw->Label(-width => 60, -relief => "sunken", -bd => 1, -anchor => 'w');
my $balloon = $mw->Balloon(-statusbar => $status);
my $msg = '';
my $balloonCharIndex = '';
my $balloonLastIndex = '';

$status->pack(-side => "bottom", -fill => "both", -padx => 2, -pady => 1);
#$balloon->attach
#    (
#    $text, -msg => \$msg,
#    -balloonposition => 'mouse',  # Not really used since the postcommand returns the real position.
#    -postcommand => \&balloonPostCommand,
#    -motioncommand => \&balloonMotionCommand,
#    );

my $menuBar = $mw->Menu (-type => 'menubar');

$mw->configure(-menu => $menuBar);
$text->pack (-expand => 'yes', -fill => 'both');

# Build file menu
$menuItems{'~File'} = $menuBar->cascade(-label => '~File', -tearoff => 0);
$menuItems{'~File'}->command (-label => '~Render', -command => \&fileRender);
$menuItems{'~File'}->command (-label => '~Open...', -command => \&fileOpen);
$menuItems{'~File'}->command (-label => '~Save', -command => \&fileSave);
$menuItems{'~File'}->command (-label => 'Save ~As...', -command => \&fileSaveAs);
$menuItems{'~File'}->command (-label => 'E~xit', -command => \&fileExit);

# Build menus and bind keys
for my $tagData (@bindings) {
    my $menuPath = $tagData->[2];
    
    next if ! defined $menuPath;

    my $tag = $tagData->[0];
    my ($top, $item) = split '/', $menuPath;
    
    next if ! defined $item;
    if (! defined $menuItems{$top}) {
        $menuItems{$top} = $menuBar->cascade(-label => $top, -tearoff => 0);
    }

    my $newItem;
    
    if ($tag eq '-') {
        $newItem = $menuItems{$top}->separator ();
        next;
    } else {
        $newItem = $menuItems{$top}->command
            (-label => $item, -command => [\&doCommand, $tag]);
    }

    next if ! defined $tagData->[2];
    
    #Set up accelerator bindings
    my $key = $tagData->[1];

    next if ! length $key;
    $text->bind ("<$key>" => [\&keyCommand, $tag]);

    $key =~ s/^Control/ctrl/;
    $newItem->configure (-accelerator => $key);
}

my $realText = $text->Subwidget ('scrolled');

$realText->bindtags ([$realText, ref($realText), $realText->toplevel, 'all']);
$text->bind("<Return>", \&handleReturn);
$text->bind ('<Control i>', [\&keyCommand, 'italic']);

$menuItems{'~Help'} = $menuBar->cascade(-label => '~Help', -tearoff => 0);
$menuItems{'~Help'}->command (-label => '~PerlMonks Editor Help', -command => \&help);
$menuItems{'~Help'}->command (-label => '~About', -command => \&about);

# A couple of phantom paragraph spacing tags to ease calculating paragraph spacing
$text->tagConfigure("!para_start", -spacing1 => 0, -spacing3 => -(kParaSpace));
$text->tagConfigure("!para_end", -spacing1 => -(kParaSpace), -spacing3 => 0);

MainLoop ();

sub balloonPostCommand {
    return 0 if ! length $balloonCharIndex;
    
    my %balloonCharTags;
    my  $charIndex = $text->index ("$balloonCharIndex +1 char");
    
    @balloonCharTags{$text->tagNames()} = ($balloonCharIndex);
    
    # If no tags under mouse don't post the balloon.
    return 0 if ! %balloonCharTags;
    
    if (exists $balloonCharTags{name}) {
        my ($start, $end) = $text->tagPrevrange ('name', $balloonCharIndex);
        my $name = $text->get($start, $end);
        
        $name =~ s/\|.*//;
        $msg = "link to [${name}]'s home node";
    } elsif (exists $balloonCharTags{node}) {
        my ($start, $end) = $text->tagPrevrange ('node', $balloonCharIndex);
        my $node = $text->get($start, $end);
        
        $node =~ s/\|.*//;
        $msg = "link to node id $node";
        $msg .= ' (badly formed - digits only allowed)' if $node !~ /^\d+$/;
    } else {
        return 0;
    }
    
    my @p = $text->bbox($balloonCharIndex);
    my $x = $text->rootx + $p[0] + $p[2] - 4;
    my $y = $text->rooty + $p[1] + $p[3] + 2;
    print "-$x,$y-\n";
    return "$x,$y";
}

sub balloonMotionCommand {
    my $x = $text->pointerx - $text->rootx;
    my $y = $text->pointery - $text->rooty;
    
    $balloonCharIndex = $text->index ("\@$x,$y");

    # If the same char don't cancel the balloon.
    return 0 if $balloonLastIndex eq $balloonCharIndex;
    
    # New char under mouse - cancel it so a new balloon will be posted.
    $balloonLastIndex = $balloonCharIndex;
    print ">$balloonLastIndex<\n";
    return 1;
}

sub fileRender {
    $text->clipboardClear ();
    $text->clipboardAppend (render ());
}

sub fileOpen {
    $currentFile = $text->getOpenFile
        (
        -defaultextension => '.pmEdit',
        -filetypes => \@filetypes
        );
    
    return if ! defined $currentFile;
    
    if (! open inFile, '<', $currentFile) {
        $text->messageBox
            (
            -title => 'Load failed', -icon => 'error',
            -type => 'Ok',
            -message => "Unable to open '$currentFile' - $!"
            );
        return;
    }
    
    my @oldTags = $text->tagNames ();
    $text->delete ('1.0', 'end -1 char');
    $text->tagDelete (@oldTags);

    my @tagStates;
    my $currLine = 1;
    
    while (<inFile>) {
        next if ! /-(\S+)\s([^-]+)-(.*)/;
        my ($type, $index, $item) = ($1, $2, $3);
        
        if ($type eq 'tagon') {
            push @tagStates, [$type, $index, $item] if $item !~ /^(?:!|_)/;
        } elsif ($type eq 'tagoff') {
            push @tagStates, [$type, $index, $item] if $item !~ /^(?:!|_)/;
        } elsif ($type eq 'text') {
            if ($currLine != int ($index)) {
                $currLine = int ($index);
                $text->insert ('end', "\n");
            }
            
            $text->insert ($index, $item);
        } else {
            print "Token type $type at $index not handled.\n";
        }
    }
    
    close inFile;

    my @activeList;
    my $lastIndex = '1.0';
    
    for my $this (@tagStates) {
        my ($type, $index, $item) = @$this;
        
        if (@activeList) {
            my @tagList = buildTag (@activeList);
            
            $text->tagAdd ($_, $lastIndex, $index) for @tagList;
            $lastIndex = $index;
        }
        
        if ($type eq 'tagon') {
            push @activeList, $item;
            $lastIndex = $index;
        } else {
            @activeList = grep {$_ ne $item} @activeList;
        }
    }
    
    fixParaSpacing ();
}

sub fileSave {
    if (defined $currentFile and length $currentFile) {
        doSave ($currentFile);
    } else {
        fileSaveAs ();
    }
}

sub fileSaveAs {
    my $filename = $text->getSaveFile
        (-defaultextension => '.pmEdit', -filetypes => \@filetypes);
    doSave ($filename);
}

sub doSave {
    my $filename = shift;
    
    return if ! defined $filename or ! length $filename;
    
    open outFile, '>', $filename or
        $text->messageBox
            (
            -title => 'Save failed', -icon => 'error',
            -type => 'Ok',
            -message => "Unable to create '$filename' - $!"
            );
    my @dumpText = $text->dump ('-tag', '-text', '1.0', 'end');
    my ($html, $name, $mode, $params);
    
    while (@dumpText) {
        my ($type, $item, $index) = splice @dumpText, 0, 3;
        next if $type =~ /^tago(?:n|ff)$/ and $item =~ /^(?:_|!)/;
        print outFile "-$type $index-$item\n";
    }
    
    close outFile;
    $currentFile = $filename;
}

sub fileExit {
    exit 1;
}

sub render {
    my $result;
    my $paragraph;
    my $inCode = 0;
    my @dumpText = $text->dump ('-tag', '-text', '1.0', 'end');
    my ($html, $name, $mode, $params);
    
    while (@dumpText) {
        my ($type, $item, $index) = splice @dumpText, 0, 3;
        
        next if $item =~ m'^(?:sel|para)';
        
        my $segEnd = exists $dumpText[2] ? $dumpText[2] : 'end';

        if ($type =~ /^tago(?:n|ff)$/) {
            next if $item =~ /^(?:_|!)/;
            ($html, $name, $mode, $params) = @{$tagTypes{$item}};
        }
            
        if ($type eq 'tagon') {
            if ($mode->{'L'}) {
                my ($linkCode) = $html =~ /^\S*\s*(.*)/;
                $paragraph .= "[$linkCode";
                next;
            }

            $inCode = 1 if $item eq 'code';
            $paragraph .= "<$tagTypes{$item}[0]>";
        } elsif ($type eq 'tagoff') {
            if ($mode->{'L'}) {
                $paragraph .= ']';
                next;
            }
            
            $paragraph .= "</$tagTypes{$item}[0]>";
            if ($item eq 'code') {
                $inCode = 0;
            } else {
            }
        } elsif ($type eq 'text') {
            $paragraph .= $item;

            if ($paragraph =~ /\n/) {
                if ($inCode) {
                    $result .= $paragraph;
                } else {
                    $paragraph =~ tr/\n//d;
                    if ($paragraph eq '</code>') {
                        $result .= $paragraph;
                        $paragraph = '';
                    }
                    
                    my $newStr = "<p>$paragraph</p>\n";
                    
                    $newStr =~ s|<p></code>|</code>\n<p>|;
                    $result .= $newStr;
                }
                
                $paragraph = '';
            }
        } else {
            print "Token type $type at $index not handled.\n";
        }
    }
    
    $result =~ s|<p></p>|<br>|g;
    $result .= "<!-- Generated using PerlMonks editor version $VERSION -->";
    return $result;
}

sub keyCommand {
    my @params = @_;
    doCommand ($params[1]);
    Tk->break;
}


sub handleReturn {
    fixParaSpacing ();
}

sub doCommand {
    my %newTag = (tag => shift);
    my @selections = $text->tagRanges('sel');
    @newTag{'name', 'html', 'flags', 'params'} = @{$tagTypes{$newTag{tag}}};
        
    do {
        if (@selections) {
            my %tags;
            @tags{$text->tagNames($selections[0])} = (); # Preset current tags

            $newTag{isOn} = ! exists $tags{$newTag{tag}}; # Complement new tag's curr state
            $tags{$newTag{tag}} ||= $newTag{isOn};
            
            @newTag{'start', 'end'} = splice @selections, 0, 2;
        } else {
            my %activeTags;
            @activeTags{$text->tagNames('insert')} = ();
            return if ! exists $activeTags{$newTag{tag}};
            @newTag{'start', 'end'} = $text->tagPrevrange ($newTag{tag}, 'insert');
            $newTag{isOn} = 0;
        }
        
        return if ! defined $newTag{end};
        
        my $msg = $newTag{flags}{L} ? manageLink (%newTag) : updateTextTags (%newTag);

        if (length $msg) {
            $status->configure (-text => $msg);
            return;
        }

        
    } while (@selections);
}

sub updateTextTags {
    my %newTag = @_;
    my @dumpText = $text->dump ('-tag', '-text', $newTag{start}, $newTag{end});
    my @activeTags = $text->tagNames($newTag{start});
    my %tags;
    
    @tags{@activeTags} = (1) x @activeTags; # Preset current tags
    $tags{$newTag{tag}} = $newTag{isOn};

    TOKEN: while (@dumpText) {
        my ($type, $item, $index) = splice @dumpText, 0, 3;
        my $segEnd = exists $dumpText[2] ? $dumpText[2] : $newTag{end};

        if ($type eq 'tagon') {
            $tags{$item} = 1 if $item ne $newTag{tag};
        } elsif ($type eq 'tagoff') {
            $tags{$item} = 0 if $item ne $newTag{tag};
        } elsif ($type eq 'text') {
            my @tagList = grep {! /^_|^sel$/ && $tags{$_}} keys %tags;
            my @removeList = grep {! $tags{$_} || /^_/} keys %tags;

            # Bail if current tags preclude new tag
            for (@tagList) {
                next if ! exists $tagTypes{$_} or $newTag{tag} eq $_;
                my ($Ihtml, $Iname, $Iflags, $Iparams) = @{$tagTypes{$_}};
                
                # Check for existing tag that precludes all new tags
                if ($Iflags->{'X'}{'ALL'}) {
                    next TOKEN
                }
                
                # Check for existing tag that precludes $newTag
                if ($Iflags->{'X'}{$newTag{tag}}) {
                    next TOKEN;
                }
            }

            if ($newTag{isOn}) {
                if ($newTag{flags}->{'C'}{'ALL'}) {
                    # Strip all other tags
                    push @removeList, @tagList;
                } elsif (%{$newTag{flags}->{'C'}}) {
                    # Clear specific tags
                    push @removeList, keys %{$newTag{flags}->{'C'}};
                }
                push @tagList, $newTag{tag};
            }

            $text->tagRemove ($_, $index, $segEnd) for @removeList;
            
            @tagList = buildTag (@tagList);
            $text->tagAdd ($_, $index, $segEnd) for @tagList;
            fixParaSpacing ($index);
        } else {
            print "Token type $type at $index not handled.\n";
        }
    }
    
    return '';
}

sub manageLink {
    my %newTag = @_;
    my @activeTags = $text->tagNames($newTag{start});
    my %tags;
    
    if (! $newTag{isOn}) {
        # Remove the link
        $text->tagRemove ($newTag{tag}, $newTag{start}, $newTag{end});
        updateTextTags (%newTag);
        return '';
    }
    
    @tags{@activeTags} = (1) x @activeTags; # Preset current tags
    for (keys %tags) {
        next if ! exists $tagTypes{$_};
        return 1 if $newTag{tag} eq $_ and $newTag{isOn}; # Link already
        
        my ($Ihtml, $Iname, $Iflags, $Iparams) = @{$tagTypes{$_}};
        return "Can't link inside $Iname" if $Iflags->{'X'}{'ALL'};
        return "Can't link inside $Iname" if $Iflags->{'X'}{'link'};
    }
    
    return 'Links must not span line ends.'
        if int ($newTag{start}) != int ($newTag{end});
        
    # Get the link text
    my $orgLinkText = $text->get($newTag{start}, $newTag{end});
    my ($linkStr, $textStr) = $orgLinkText =~ /^([~|]*\|?)(.*)/;
    my $indexStr = "$newTag{start} +" . length ($linkStr) . 'chars';
    my $linkEnd = $text->index ($indexStr);
    my %linkTag = %{clone (\%newTag)};
    my %textTag = %{clone (\%newTag)};

    $linkTag{end} = $linkEnd;
    $textTag{start} = $linkEnd;
    
    updateTextTags (%linkTag);
    updateTextTags (%textTag);
    return '';
}

sub buildTag {
    my %tags;
    
    @tags{@_} = ();
    
    my @tagList = sort keys %tags;
    my $newFormatTag = '_' . join '_', @tagList;
    my %options;
    my %fontParams;
    
    for (@tagList) {
        next if ! exists $tagTypes{$_} || ! ref $tagTypes{$_};

        my ($html, $name, $mode, $params) = @{$tagTypes{$_}};
        next if ! ref $params;
        
        for my $type (keys %$params) {
            if ($type =~ /-font/) {
                for my $subType (keys %{$params->{$type}}) {
                    $fontParams{$subType} = $params->{$type}{$subType};
                }
            } else {
                $options{$type} = $params->{$type};
            }
        }
    }
    
    $options{-font} = buildFont (%fontParams) if %fontParams;
    $text->tagConfigure ($newFormatTag, %options);

    push @tagList, $newFormatTag;
    return @tagList;
}

sub buildFont {
    my %options = @_;
    my $fontName = '';
    
    $fontName .= "$_|$options{$_}," for sort keys %options;
    $fontName =~ tr/-+/mp/;
    $fontName =~ tr/a-zA-Z0-9/mp_/c;
    $mw->fontCreate($fontName, %options) if ! $formatFonts{$fontName}++;
    return $fontName;
}

sub fixParaSpacing {
    my $targetLine = shift;
    
    if (! defined $targetLine) {
        fixGlobalParaSpacing ();
        return;
    }
}

sub fixGlobalParaSpacing {
    my $lastLine = ($text->index ('end') =~ /(\d+)/)[0];
    my $lastTailSpace = -(kParaSpace);
    my @paraTags;
    
    push @paraTags, "!para_$_" for (1..$lastLine);
    $text->tagDelete (@paraTags); # Clear current spacing tags
    
    for my $line (1..$lastLine) {
        my $headSpace = kParaSpace;
        my $tailSpace = kParaSpace;
        my @activeTags = $text->tagNames("$line.0");
        
        # Note that this is currently broken if the first character happens to be a
        # part of a single spaced style applied to a partial line
        for (@activeTags) {
            next if ! exists $tagTypes{$_} || ! ref $tagTypes{$_};
    
            my ($html, $name, $mode, $params) = @{$tagTypes{$_}};
            next if ! ref $params;
    
            for my $type (keys %$params) {
                $headSpace = $params->{$type} if $headSpace && $type =~ /-spacing1/;
                $tailSpace = $params->{$type} if $tailSpace && $type =~ /-spacing3/;
            }
        }

        if ($lastTailSpace == -(kParaSpace)) {
            $headSpace = 0;
        } elsif ($lastTailSpace == 0 && $headSpace > 0) {
            $headSpace += kParaSpace;
        } elsif ($lastTailSpace > 0 && $headSpace == 0) {
            $headSpace += kParaSpace;
        }

        $text->tagConfigure("!para_$line", -spacing1 => $headSpace, -spacing3 => $tailSpace);
        $text->tagAdd ("!para_$line", "$line.0");
        $text->tagRaise ("!para_$line");
        $lastTailSpace = $tailSpace;
    }
}

sub trim {
    for (@_) {
        $$_ =~ s/^\s+//;
        $$_ =~ s/\s+$//;
    }
}

sub help {
    my $msg = <<MSG;
This editor is designed to provide wysiwyg editing for PerlMonks.org nodes. The
contents of the node is edited off-line and rendered (File|Render) to the
clipboard for pasting into a node's text edit field.

Feedback can be /msged to GrandFather in the first instance. If you provide an
email address in your /msg, GrandFather will most likely reply to the email
address.
MSG

    $mw->messageBox (
        -icon => 'info',
        -message => $msg, -title => 'PerlMonks Editor Help',
        -type => 'Ok',
        );
}

sub about {
    my $msg = <<MSG;
PerlMonks Editor

Written by GrandFather for the assistance, pleasure and edification of other
monks.
MSG

    $mw->messageBox (
        -icon => 'info',
        -message => $msg, -title => 'About PerlMonks Editor',
        -type => 'Ok',
        );
}

=head1 NAME

PMEdit - A wysiwyg PerlMonks.org markup savy editor.

=head1 DESCRIPTION

This script is a PerlMonks.org markup savy editor. It may be useful for most
everything based web sites and can be adapted for use for light weight HTML
generation.

=head1 README

PerlMonks editor is designed to allow wysiwig editing of material to be
posted on everything based web sites such as PerlMonks. Initial versions are
intended to be used to prepare the material offline and then render to the
clipboard for pasting into a node's edit field. It is expected that later
versions will interact more directly with the web site to allow easier
updating of existing nodes and quoting material from nodes that are being
replied to.

The current version is considered to be an alpha version. It does some cool
stuff, but much of the intended functionality is not yet implemented.

The only known significant bug is that sometimes a closing code tag and opening
p tag get out of order in rendering. This seems to be when an inline code tag
occurs at the start of a paragraph following a code block. There are various
rough edges related to on screen formating and editing, many seem to be odd
behaviour provided by the Text widget.

The current version provides configuration information for associating
markup with display styles, menu entries, key assignements and (in the
future) toolbar entries. The configuration is included in the script in a
__DATA__ section.

There are two sectons in the configuration data seperated by a line starting
with "#key ". The first section contains information mapping tags to display
formatting and management and output rendering. The lines are of the form:

tag name,HTML tag, UI text, flags, modifiers as key value pairs

For example
    
code,c,Code block,BFXCU,-spacing1 => 0,-spacing3 => 0,-foreground => #e0e0ff,-font => [-family => courier, -weight => bold]

=over 8

code: the name used internally for tagging text

c: the HTML or link element tag text

Code block: String that may be used in the user interface

BFXCU: flags that control display, placement and rendering

...: display formatting. See the Tk::Text TAGS section

=back

The following flags may be used:

=over 8

B: Block level element (paragraph tag <p>)

C: Clear all or specified tags: C or Ctag (note lower case). Allows code tags to
reset any other tags when the code tag format is applied for example.

F: Format tag (inline element such as bold <b>)

I: Item in a list. Implies B. Will get special display handling.

L: Link. Gets [] brackets to signal a PerlMonks link

N: Needs block level tag (any one of multiple): Ntag. Used to ensure a the
flaged tag is a child element of one of the specified element types. For example
a list item (I flag) would specify NolistNulist to indicate it must be contained
in a ol or ul element.

P: Applies to whole paragraph. Set for element types such as <p> and <readmore>

R: Readmore text. <readmore> semantics (implies P)

S: Single spaced text. Prevents additional paragraph spacing on the displayed
text (doesn't affect output rendering).

U: Untranslated - don't translate entities. Used in code elements and other
elements to retain characters such as <>&[] as litteral characters.

X: Exclude all or specified tags: X or Xtag (note lower case). Prevent the
listed tags being applied in regions that contain the current tag. Used to
prevent formatting being applied in a code block for example.

=back

The second section describes key and menu bindings for tags. Eventually toolbar
support may be added also. The lines in this section are of the form:

tag,key,menu item,toolbar item,right click item

For example:

code,Control k,Format/Code,,Code

=over 4

code: the tag name used in the previous section

Control k: the key combination used to access the tag

Format/Code: the menu path to the entry used to access the tag. In this case a
'Code' entry would be created in the 'Format' menu

missing: The missing entry is a place holder for a toolbar entry

Code: the right click menu entry used to access the tag

=back

a special case entry is used to put dividers in menus. It is of the form:

-,-,Format/-,,

Note that menu entries are generated in the order that they are specified in the
configuration section.

=head1 PREREQUISITES

This script requires the following modules:

c<strict> C<warnings> C<Tk> C<Tk::Balloon> C<Tk::Clipboard> C<Clone>

=pod OSNAMES

any

=head1 AUTHOR

Peter Jaquiery <F<grandpa@cpan.org>>

=head1 COPYRIGHT

Copyright (c) 2006, Peter Jaquiery. All rights reserved.
This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

=pod SCRIPT CATEGORIES

Web

=cut

__DATA__
#tag style definitions
#tag name,HTML tag, UI text, flags, modifiers as key value pairs
big,big,Big font,F,-font => [-size => 16]
bold,b,Bold,F,-font => [-weight => bold]
center,center,Centered text,P,
code,code,Code block,BFXCU,-spacing1 => 0,-spacing3 => 0,-foreground => #8080e0,-font => [-family => courier, -weight => bold]
cpan,link id://,CPAN link,L, -background => #c0c0c0, -foreground => #40e040,
dd,dd,Definition Description,B,
del,del,Deleted Text,F,
dl,dl,Definition List,B,-lmargin1 => 20m, -lmargin2 => 20m, -rmargin => 20m
dt,dt,Definition Term,B,-lmargin1 => 10m, -lmargin2 => 10m, -rmargin => 10m, -font => [-weight => bold]
emphasis,em,Emphasis,F,-font => [-weight => bold]
h3,h3,Header level 3,B,-font => [-size => 24], -background => #c0c0c0,-spacing1 => 18
h4,h4,Header level 4,B,-font => [-size => 24], -background => #8080c0,-spacing1 => 14
h5,h5,Header level 5,B,-font => [-size => 16], -background => #c0c0c0,-spacing1 => 14
h6,h6,Header level 6,B,-font => [-size => 16], -background => #8080c0,-spacing1 => 10
hrule,hr,Horizontal rule,BX,
inserted,ins,ins,BF, -background => #ffffc0,
italic,i,Italic,F,-font => [-slant => italic]
item,li,List item,INolNul,
olist,ol,Ordered list,B,-lmargin1 => 20m, -lmargin2 => 20m, -rmargin => 20m
quote,blockquote,Quoted block,P,-lmargin1 => 15m,-lmargin2 => 15m,-rmargin => 15m
readmore,readmore,Read more block,BR,-background => #a0b7ce
small,small,small,F,-font => [-size => 8]
spoiler,spoiler,Spoiler,F, -background => #000000, -foreground => #404040,
strike,strike,Strike Out,F,-overstrike => on
strong,strong,Strong emphasis,F,
sub,sub,Sub script,FCsuper,-offset => -2p,-font => [-size => 8]
super,sup,Super script,FCsub,-offset => 4p,-font => [-size => 8]
teletype,Teletype text,tt,F,-font => [-family => courier], -background => #FFFFc0
ulist,ul,Unordered list,B,-lmargin1 => 20m, -lmargin2 => 20m, -rmargin => 20m
underline,u,Underline,F,[-underline => on]],

#links - still tag style definitions
acronym,link acronym://,Acronym link,L, -underline => 1, -foreground => #0060c0,
cpan,link cpan://,Cpan link,L, -underline => 1, -foreground => #00a0a0,
dict,link dict://,Dictionary link,L, -underline => 1, -foreground => #00a0a0,
dist,link dist://,CPAN Distro link,L, -underline => 1, -foreground => #00a0a0,
doc,link doc://,perldoc link,L, -underline => 1, -foreground => #00a0a0,
ftp,link ftp://,Ftp link,L, -underline => 1, -foreground => #00a0a0,
google,link google://,Google link,L, -underline => 1, -foreground => #00a0a0,
href,link href://,Href link,L, -underline => 1, -foreground => #00a0a0,
http,link http://,Http link,L, -underline => 1, -foreground => #00a0a0,
https,link https://,Https link,L, -underline => 1, -foreground => #00a0a0,
id,link id://,Node id link,L, -underline => 1, -foreground => #00a0a0,
isbn,link isbn://,Isbn link,L, -underline => 1, -foreground => #00a0a0,
jargon,link jargon://,Jargon link,L, -underline => 1, -foreground => #00a0a0,
kobes,link kobes://,Kobes link,L, -underline => 1, -foreground => #00a0a0,
lj,link lj://,Live journal link,L, -underline => 1, -foreground => #00a0a0,
lucky,link lucky://,Google lucky link,L, -underline => 1, -foreground => #00a0a0,
mod,link mod://,Mod link,L, -underline => 1, -foreground => #00a0a0,
module,link module://,Module link,L, -underline => 1, -foreground => #00a0a0,
name,link,Node name link,L, -foreground => #0060c0, -underline => 1
pad,link pad://,Scratchpad link,L, -underline => 1, -foreground => #00a0a0,
perldoc,link perldoc://,Perldoc link,L, -underline => 1, -foreground => #00a0a0,
pmdev,link pmdev://,Pmdev link,L, -underline => 1, -foreground => #00a0a0,
wp,link wp://,Wp link,L, -underline => 1, -foreground => #00a0a0,

#key bindings, menu items and tool bar items
#tag,key,menu item,toolbar item,right click item
big,Control 2,Format/Big,,Big
bold,Control b,Format/Bold,,Bold
italic,Control i,Format/Italic,,Italic
small,Control s,Format/Small,,Small
strike,Control s,Format/Strike out,,Strike out
sub,Control u,Format/Subscript,,Subscript
super,Control s,Format/Superscript,,Superscript
-,-,Format/-,-,
code,Control k,Format/Code,,Code

#links - still bindings
cpan,,Links/CPAN,,CPAN link
id,Control d,Links/Node,,Node id link
name,Control n,Links/Name,,Node name link