use strict; use warnings; use diagnostics; use Tk; #use Tk::TextUndo; #Removed due to bugs that would be far too much effort to work around use Tk::Balloon; use Tk::Clipboard; use Tk::FBox; use Clone qw(clone); =head Todo Dirty document handling Manage B, F, I, P, R and U flags Translate entities (note U flag) Support snippet text (with formatting) Disallow relink Checkmarks for menus handle tables Add Edit menu to access find and replace etc Figure out node name/id from selection? LWP to get node name from id Make menus understand exclusion flags and group exclusive entrys when in same menu Add email sending facility =cut use constant kParaSpace => 6; my $VERSION = '001.000102'; # 1.0 Alpha 2 my $currentFile = ''; my %tagTypes; # Style tag data my %formatFonts; # Fonts used in style tags. Keyed by tag my %bindings; # Key, menu and toolbar bindings. Tag is value my %menuItems; # Child menu widgets keyed by menu label path my %entities = # Entities we need to use outside code blocks ( '&', '&', '<', '<', '>', '>', '[', '[', ']', ']', ); 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 '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) ); while () { # 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{'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 } 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 () { # 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; $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 $tag (keys %bindings) { my $menuPath = $bindings{$tag}[1]; next if ! defined $menuPath; my ($top, $item) = split '/', $menuPath; next if ! defined $item; if (! defined $menuItems{$top}) { $menuItems{$top} = $menuBar->cascade(-label => $top, -tearoff => 0); } my $newItem = $menuItems{$top}->command (-label => $item, -command => [\&doCommand, $tag]); if (defined $bindings{$tag}[0]) { #Set up accelerator bindings my $key = $bindings{$tag}[0]; 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("", \&handleReturn); $text->bind ('', [\&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->FBox(-type => 'open', -filter => '*.pmEdit')->Show; 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 () { 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->FBox(-type => 'save', -filter => '*.pmEdit')->Show; 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 .= ""; 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 '') { $result .= $paragraph; $paragraph = ''; } my $newStr = "

$paragraph

\n"; $newStr =~ s|

|\n

|; $result .= $newStr; } $paragraph = ''; } } else { print "Token type $type at $index not handled.\n"; } } $result =~ s|

|
|g; $result .= ""; 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 = <messageBox ( -icon => 'info', -message => $msg, -title => 'PerlMonks Editor Help', -type => 'Ok', ); } sub about { my $msg = <messageBox ( -icon => 'info', -message => $msg, -title => 'About PerlMonks Editor', -type => 'Ok', ); } __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,-background => #e0e0ff,-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,I, 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, -background => #f0f0f0, -foreground => #0060c0, cpan,link cpan://,Cpan link,L, -background => #f0f0f0, -foreground => #00a0a0, dict,link dict://,Dictionary link,L, -background => #f0f0f0, -foreground => #00a0a0, dist,link dist://,CPAN Distro link,L, -background => #f0f0f0, -foreground => #00a0a0, doc,link doc://,perldoc link,L, -background => #f0f0f0, -foreground => #00a0a0, ftp,link ftp://,Ftp link,L, -background => #f0f0f0, -foreground => #00a0a0, google,link google://,Google link,L, -background => #f0f0f0, -foreground => #00a0a0, href,link href://,Href link,L, -background => #f0f0f0, -foreground => #00a0a0, http,link http://,Http link,L, -background => #f0f0f0, -foreground => #00a0a0, https,link https://,Https link,L, -background => #f0f0f0, -foreground => #00a0a0, id,link id://,Node id link,L, -background => #f0f0f0, -foreground => #00a0a0, isbn,link isbn://,Isbn link,L, -background => #f0f0f0, -foreground => #00a0a0, jargon,link jargon://,Jargon link,L, -background => #f0f0f0, -foreground => #00a0a0, kobes,link kobes://,Kobes link,L, -background => #f0f0f0, -foreground => #00a0a0, lj,link lj://,Live journal link,L, -background => #f0f0f0, -foreground => #00a0a0, lucky,link lucky://,Google lucky link,L, -background => #f0f0f0, -foreground => #00a0a0, mod,link mod://,Mod link,L, -background => #f0f0f0, -foreground => #00a0a0, module,link module://,Module link,L, -background => #f0f0f0, -foreground => #00a0a0, name,link,Node name link,L, -background => #f0f0f0, -foreground => #0060c0, pad,link pad://,Scratchpad link,L, -background => #f0f0f0, -foreground => #00a0a0, perldoc,link perldoc://,Perldoc link,L, -background => #f0f0f0, -foreground => #00a0a0, pmdev,link pmdev://,Pmdev link,L, -background => #f0f0f0, -foreground => #00a0a0, wp,link wp://,Wp link,L, -background => #f0f0f0, -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 cpan,,Links/CPAN,,CPAN link italic,Control i,Format/Italic,,Italic strike,Control s,Format/Strike out,,Strike out sub,Control u,Format/Subscript,,Subscript super,Control s,Format/Superscript,,Superscript code,Control k,Format/Code,,Code id,Control d,Links/Node,,Node id link name,Control n,Links/Name,,Node name link