File Coverage

blib/lib/Tk/Markdown.pm
Criterion Covered Total %
statement 12 12 100.0
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 16 16 100.0


line stmt bran cond sub pod time code
1             package Tk::Markdown;
2            
3 1     1   37722 use 5.006;
  1         4  
  1         68  
4 1     1   6 use strict;
  1         2  
  1         47  
5 1     1   6 use warnings FATAL => 'all';
  1         6  
  1         73  
6            
7             =head1 NAME
8            
9             Tk::Markdown - display markdown in a Text
10            
11             =head1 VERSION
12            
13             Version 0.05
14            
15             =cut
16            
17             our $VERSION = '0.05';
18            
19 1     1   6 use base qw(Tk::Derived Tk::Text);
  1         2  
  1         795  
20             use Tk::Font;
21             #use Tk::Carp qw/fatalsToDialog warningsToDialog tkDeathsNonFatal/;
22             ## commented out tk carp cos it's not available in ppm!
23            
24             Construct Tk::Widget 'Markdown';
25            
26            
27             =head1 SYNOPSIS
28            
29            
30             use Tk;
31             use Tk::MarkdownTk;
32            
33             my $mw = new MainWindow();
34             my $mdt = $mw->MarkdownTk();
35            
36             $mdt->insert(q{
37             some markdown here
38             });
39            
40             =head1 METHODS
41            
42             =head2 insert
43            
44             Whenever insert is called on the Markdown,
45             some translation is done on the text in order to
46             diplay it nicely as markdown. Tables are reformatted
47             (if the line starts with a bar) and headers are
48             tagged with different fonts.
49            
50             This module is currently under development and
51             there's plenty to do, e.g. links, images, etc.
52            
53             =cut
54            
55             ### add the processing functionality to the insert method
56             sub insert
57             {
58             my ($self,$index,$content) = @_;
59             my $res = $self->SUPER::insert($index,FormatMarkdown($content));
60             if(! $self->{inserting}){ ### don't allow recursion...
61             $self->{inserting} = 1;
62             $self->PaintMarkdown();
63             # $self->TransformTk();
64             $self->see("1.0");
65             $self->{inserting} = 0;
66             }
67             return $res;
68             }
69            
70            
71            
72             ### these few subs are taken directly from ROText...
73            
74             =head2 defaultStyles
75            
76             Called internally. You can access the styles like this:
77            
78             use Data::Dumper;
79             print Dumper $o->{styles};
80            
81             To set styles, use $o->setStyles
82            
83             =cut
84            
85             ### named styles, used in _rules_ below.
86             sub defaultStyles {
87             my $self = shift;
88             my @sans = qw/-family Helvetica -size/;
89             my @serif = qw/-family Times -size/;
90             my @mono = qw/-family Courier -size/;
91             my @bold = qw/-weight bold/;
92             my @italic = qw/-slant italic/;
93             my @under = qw/-underline 1/;
94             my @over = qw/-overstrike 1/;
95             my %ss = (
96             body => ['black',@serif,12],
97             h1 => ['navy',@sans,18,@bold,@italic],
98             h2 => ['firebrick',@sans,18,@bold],
99             h3 => ['darkgreen',@sans,16,@bold,@italic],
100             h4 => ['brown',@sans,16,@bold],
101             h5 => ['seagreen',@sans,14,@bold,@italic],
102             h6 => ['darkslateblue',@sans,14,@bold],
103             code => ['DarkSlateGray',@mono,10],
104             list => ['black', @sans, 10],
105             );
106             #foreach(keys %ss){
107             # print @{$ss{$_}} % 2, "\n";
108             #}
109             $self->{'styles'} = \%ss;
110             $self->setStyles(%ss);
111             }
112            
113            
114             =head2 setStyles
115            
116             The argument is a hash of styles. The keys are predefined names, currently:
117            
118             =over
119            
120             =item body
121             =item h1
122             =item h2
123             =item h3
124             =item h4
125             =item h5
126             =item h6
127             =item code
128             =item list
129            
130             =back
131            
132             and the values are listrefs, in which the first element is the -foreground color, and
133             the remainder are options for the Tk::Font object. For example:
134            
135             $o->setStyles(
136             'h1' => [ qw/ red -family Times -weight bold -size 32 / ],
137             )
138            
139             =cut
140            
141            
142             ### add styles as tags to the text
143             sub setStyles {
144             my ($self,%styles) = @_;
145             %{$self->{styles}} = (%{$self->{styles}},%styles);
146             foreach (keys %styles){
147             my ($color,@font) = @{$styles{$_}};
148             $self->tagConfigure($_, -foreground=>$color, -font=>$self->Font(@font));
149             }
150             my ($color,@font) = @{$styles{body}};
151             $self->configure(-font=>$self->Font(@font),-foreground=>$color);
152             }
153            
154             =head2 FormatMarkdown
155            
156             This is called internally. It prettifies markdown prior to insertion.
157            
158             <% perl code here %> is interpretted here, so if you want to have perl
159             code that results in formatted markdown, you'll need to put it inside
160             <% %> (as opposed to the that will get run by MarkdownTk)
161            
162             =cut
163            
164             ### reformat the text of certain markdown components to make them prettier...
165             sub FormatMarkdown
166             {
167             my $markdown = shift;
168             $markdown =~ s/<\%=(.*?)\%>/ my $v=$1; eval("\$v = sub{ $v }"); &$v()/ges;
169             $markdown =~ s/<\%(.*?)\%>/ eval($1); ''/ges;
170             my @lines = split /\n/, $markdown;
171             my $i = 0;
172             while($i < @lines){
173             if($lines[$i] =~ /^\|/){ # tables!
174             my $j = $i;
175             while($lines[$j+1] =~ /^\||^-+$/){ $j++; }
176             @lines[$i..$j] = FormatMarkdownTable(@lines[$i..$j]);
177             $i = $j;
178             }
179             $i++;
180             }
181             $markdown = join("\n", @lines);
182             return $markdown;
183             }
184            
185             =head2 FormatMarkdownTable
186            
187             This is called internally. It prettifies markdown tables.
188            
189             =cut
190            
191             ### reformat the text of tables to make them prettier...
192             sub FormatMarkdownTable {
193             s/\s*\|\s*/|/g foreach @_;
194             s/^\s*\|\s*// foreach @_;
195             s/\s*\|\s*$// foreach @_;
196             my @colwidths = map {0} split /\|/, $_[0];
197             foreach my $row (@_){
198             next if $row =~ /^-+$/;
199             my @row = split /\|/, $row;
200             @colwidths = map {$colwidths[$_] > length($row[$_]) ? $colwidths[$_] : length($row[$_])} 0..$#row;
201             }
202             my $sum = 0;
203             foreach (@colwidths){
204             $sum += $_;
205             $sum += 3;
206             }
207             my $hr = '-' x $sum;
208             my @table;
209             foreach my $row (@_){
210             if($row =~ /^-+$/){
211             push @table, $hr;
212             next;
213             }
214             my @row = split /\|/, $row;
215             foreach my $j(0..$#row){
216             my $diff = $colwidths[$j] - length($row[$j]);
217             my $spaces = ' ' x $diff;
218             # if a number...
219             if($row[$j] =~ /^[-+]?(?:0[bx]|)\d+\.?\d*[fe][+-]?\d*$/){
220             $row[$j] = $spaces . $row[$j];
221             }
222             else {
223             $row[$j] .= $spaces;
224             }
225             $row[$j] = " $row[$j] ";
226             }
227             push @table, "|".join('|', @row)."|";
228             }
229             return @table;
230             }
231            
232             =head2 PaintMarkdown
233            
234             This is call internally. It applies the styles.
235            
236            
237            
238             =cut
239            
240            
241            
242             ### Add tags and substitute some characters to format the markdown.
243             sub PaintMarkdown
244             {
245             my $self = shift;
246             my @rules = (
247             ### HEADERS
248             [qr/^#[^#].*$/m, 'h1', qr/^#\s*(?=[^#])/m ,''],
249             [qr/^##[^#].*$/m, 'h2', qr/^##\s*(?=[^#])/m, ''],
250             [qr/^###[^#].*$/m, 'h3', qr/^###\s*(?=[^#])/m, ''],
251             [qr/^####[^#].*$/m, 'h4', qr/^####\s*(?=[^#])/m, ''],
252             [qr/^#####[^#].*$/m, 'h5', qr/^#####\s*(?=[^#])/m, ''],
253             [qr/^######[^#].*$/m, 'h6', qr/^######\s*(?=[^#])/m, ''],
254             ### TABLES
255             [qr/^\|.*\|$|^-+$|^\s\s\s\s/m, 'code', '', ''],
256             ### LISTS
257             [qr/^\*[^*].*$/m, 'list', qr/^\*(?=[^*])/, " \x{2022} "],
258             [qr/^\*\*[^*].*$/m, 'list', qr/^\*\*(?=[^*])/, " \x{25E6} "],
259             [qr/^\*\*\*[^*].*$/m, 'list', qr/^\*\*\*(?=[^*])/, " \x{2022} "],
260             [qr/^\*\*\*\*[^*].*$/m, 'list', qr/^\*\*\*\*(?=[^*])/, " \x{25E6} "],
261             [qr/^\*\*\*\*\*[^*].*$/m, 'list', qr/^\*\*\*\*\*(?=[^*])/, " \x{2022} "],
262             [qr/^\*\*\*\*\*\*[^*].*$/m, 'list', qr/^\*\*\*\*\*\*(?=[^*])/, " \x{25E6} "],
263             ### CODE
264             [qr/^\s\s\s\s.*$/m, 'code', '', ''],
265             );
266             foreach(@rules){
267             my ($re,$tag,$search,$replace) = @$_;
268             $self->FindAll('-regexp','-case', $re );
269             my @i = $self->tagRanges('sel');
270             $self->tagAdd($tag,@i) if @i;
271             if($search){
272             #print "$search\n";
273             $self->FindAndReplaceAll('-regexp','-case', $search, $replace);
274             }
275             }
276             }
277            
278             =head2 clipEvents
279            
280             This copied directly from Tk::ROText
281            
282             =cut
283            
284             sub clipEvents
285             {
286             return qw[Copy];
287             }
288            
289             =head2 ClassInit
290            
291             This is copied directly from Tk::ROText.
292            
293             =cut
294            
295             sub ClassInit
296             {
297             my ($class,$mw) = @_;
298             my $val = $class->bindRdOnly($mw);
299             my $cb = $mw->bind($class,'');
300             $mw->bind($class,'',$cb) if (defined $cb);
301             $cb = $mw->bind($class,'');
302             $mw->bind($class,'', $cb) if (defined $cb);
303             $class->clipboardOperations($mw,'Copy');
304             return $val;
305             }
306            
307             =head2 Populate
308            
309             This is copied and modified from Tk::ROText. The modification is the addition
310             of a call to setDefaultStyles. That's all.
311            
312             =cut
313            
314             sub Populate
315             {
316             my ($self,$args) = @_;
317             $self->SUPER::Populate($args);
318             my $m = $self->menu->entrycget($self->menu->index('Search'), '-menu');
319             $m->delete($m->index('Replace'));
320             $self->ConfigSpecs(-background=>['SELF'], -foreground=>['SELF'],);
321             $self->defaultStyles(); ### Jimi added this line... does a bit more setup.
322             }
323            
324            
325             =head2 Tk::Widget::ScrlMardown
326            
327             Copied and adapted from Tk::ROText
328            
329             =cut
330            
331             sub Tk::Widget::ScrlMarkdown { shift->Scrolled('Markdown' => @_) }
332            
333            
334            
335             =head1 AUTHOR
336            
337             JimiWills, C<< >>
338            
339             =head1 BUGS
340            
341             Please report any bugs or feature requests to C, or through
342             the web interface at L. I will be notified, and then you'll
343             automatically be notified of progress on your bug as I make changes.
344            
345            
346            
347            
348             =head1 SUPPORT
349            
350             You can find documentation for this module with the perldoc command.
351            
352             perldoc Tk::Markdown
353            
354            
355             You can also look for information at:
356            
357             =over 4
358            
359             =item * RT: CPAN's request tracker (report bugs here)
360            
361             L
362            
363             =item * AnnoCPAN: Annotated CPAN documentation
364            
365             L
366            
367             =item * CPAN Ratings
368            
369             L
370            
371             =item * Search CPAN
372            
373             L
374            
375             =back
376            
377            
378             =head1 ACKNOWLEDGEMENTS
379            
380            
381             =head1 LICENSE AND COPYRIGHT
382            
383             Copyright 2013 JimiWills.
384            
385             This program is free software; you can redistribute it and/or modify it
386             under the terms of the the Artistic License (2.0). You may obtain a
387             copy of the full license at:
388            
389             L
390            
391             Any use, modification, and distribution of the Standard or Modified
392             Versions is governed by this Artistic License. By using, modifying or
393             distributing the Package, you accept this license. Do not use, modify,
394             or distribute the Package, if you do not accept this license.
395            
396             If your Modified Version has been derived from a Modified Version made
397             by someone other than you, you are nevertheless required to ensure that
398             your Modified Version complies with the requirements of this license.
399            
400             This license does not grant you the right to use any trademark, service
401             mark, tradename, or logo of the Copyright Holder.
402            
403             This license includes the non-exclusive, worldwide, free-of-charge
404             patent license to make, have made, use, offer to sell, sell, import and
405             otherwise transfer the Package with respect to any patent claims
406             licensable by the Copyright Holder that are necessarily infringed by the
407             Package. If you institute patent litigation (including a cross-claim or
408             counterclaim) against any party alleging that the Package constitutes
409             direct or contributory patent infringement, then this Artistic License
410             to you shall terminate on the date that such litigation is filed.
411            
412             Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER
413             AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES.
414             THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
415             PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY
416             YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR
417             CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR
418             CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE,
419             EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
420            
421            
422             =cut
423            
424             1; # End of Tk::Markdown
425            
426            
427             # End