Syntax-Highlight-Engine-Simple-0.09/0000755000175000017540000000000011605236023016653 5ustar sugamacutoutSyntax-Highlight-Engine-Simple-0.09/MANIFEST0000644000175000017540000000062311605236024020006 0ustar sugamacutoutChanges lib/Syntax/Highlight/Engine/Simple.pm Makefile.PL MANIFEST README t/00.load.t t/highlight.t t/highlight2.t t/subclass.t t/testfile/2original.txt t/testfile/3original.txt t/testfile/4original.txt t/testfile/expected.txt t/testfile/original.txt xt/perlcritic.t xt/perlcriticrc xt/pod-coverage.t xt/pod.t xt/podspell.t META.yml Module meta-data (added by MakeMaker) Syntax-Highlight-Engine-Simple-0.09/Changes0000755000175000017540000000211411605214514020150 0ustar sugamacutoutRevision history for Syntax-Highlight-Engine-Simple 0.09 2011/07/07 - Fixed: PBP test passed 0.08 2008/07/29 - Fixed: Bug on priority control(test6 in highlight.t) on some invironment 0.07 2008/07/28 - Fixed: Some Perl::Critic violations 0.06 2008/07/27 - Improved: Optimized the architecture and the performance on some situation has improved - Improved: The document edited 0.05 Sat Jul 16 00:53:00 2008 - Fixed: Perl::Critic test now requires version 1.088 or later - Fixed: Bug in complicated rule definition. - Added: Posibility to define allowed container by array. 0.04 Sat Jul 13 15:33:25 2008 - Fixed: Perl::Critic test failure in certain environment 0.03 Sat Jul 13 15:33:25 2008 - Fixed: Perl::Critic test failure in certain environment - Fixed: Bug in appendSyntax method 0.02 Sat Jul 13 15:33:25 2008 - Fixed: getClassNames method - Fixed: POD - Changed: Syntax format. allowed_container(array) abolished and container(string) adopted. 0.0.1 Mon Jul 7 14:13:17 2008 - Initial release. Syntax-Highlight-Engine-Simple-0.09/META.yml0000664000175000017540000000113611605236023020127 0ustar sugamacutout--- #YAML:1.0 name: Syntax-Highlight-Engine-Simple version: 0.09 abstract: Simple Syntax Highlight Engine author: - Sugama Keita license: unknown distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 build_requires: ExtUtils::MakeMaker: 0 requires: encoding: 0 Test::More: 0 version: 0 no_index: directory: - t - inc generated_by: ExtUtils::MakeMaker version 6.56 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 Syntax-Highlight-Engine-Simple-0.09/lib/0000755000175000017540000000000011605236023017421 5ustar sugamacutoutSyntax-Highlight-Engine-Simple-0.09/lib/Syntax/0000755000175000017540000000000011605236023020707 5ustar sugamacutoutSyntax-Highlight-Engine-Simple-0.09/lib/Syntax/Highlight/0000755000175000017540000000000011605236023022616 5ustar sugamacutoutSyntax-Highlight-Engine-Simple-0.09/lib/Syntax/Highlight/Engine/0000755000175000017540000000000011605236023024023 5ustar sugamacutoutSyntax-Highlight-Engine-Simple-0.09/lib/Syntax/Highlight/Engine/Simple.pm0000755000175000017540000003714411605221750025627 0ustar sugamacutoutpackage Syntax::Highlight::Engine::Simple; use warnings; use strict; use Carp; our $VERSION = '0.09'; ### --- ### constructor ### --- sub new { my $class = shift; my $self = bless {type => undef, syntax => undef, @_}, $class; $self->setParams(@_); if ($self->{type}) { my $class = "Syntax::Highlight::Engine::Simple::". $self->{type}; require $class; $class->setSyntax(); return $self; } $self->setSyntax(); return $self; } ### --- ### set params ### --- sub setParams { my $self = shift; my %args = ( html_escape_code_ref => \&_html_escape, @_); $self->{html_escape_code_ref} = $args{html_escape_code_ref}; } ### --- ### set syntax ### --- sub setSyntax { my $self = shift; my %args = (syntax => [], @_); $self->{syntax} = $args{syntax}; } ### --- ### append syntax ### --- sub appendSyntax { my $self = shift; my %args = ( syntax => { regexp => '', class => '', container => undef, }, @_); push(@{$self->{syntax}}, $args{syntax}); } ### --- ### Highlight multi Line ### --- sub doStr{ my $self = shift; my %args = (str => '', tab_width => -1, @_); defined $args{str} or croak 'doStr method got undefined value'; if ($args{tab_width} > 0) { my $tabed = ''; foreach my $line (split(/\r\n|\r|\n/, $args{str})) { $tabed .= &_tab2space($line, $args{tab_width}). "\n"; } $args{str} = $tabed; } return $self->_doLine($args{str}); } ### --- ### Highlight file ### --- sub doFile { my $self = shift; my %args = ( file => '', tab_width => -1, encode => 'utf8', @_); my $str = ''; require 5.005; open(my $filehandle, '<'. $args{file}) or croak 'File open failed'; binmode($filehandle, ":encoding($args{encode})"); while (my $line = <$filehandle>) { if ($args{tab_width} > 0) { $line = &_tab2space($line, $args{tab_width}); } $str .= $line; } close($filehandle); return $self->_doLine($str); } ### --- ### Highlight single line ### --- sub _doLine { my ($self, $str) = @_; $str =~ s/\r\n|\r/\n/g; $self->{_markup_map} = []; ### make markup map foreach my $i (0 .. $#{$self->{syntax}}) { $self->_makeAllowHash($i); $self->_make_map($str, $i); } my $outstr = ''; my $last_pos = 0; ### Apply the map to string foreach my $pos ($self->_restracture_map()) { my $str_left = substr($str, $last_pos, $$pos[0] - $last_pos); $outstr .= $self->{html_escape_code_ref}->($str_left); if (defined $$pos[1]) { $outstr .= sprintf("", $$pos[1]->{class}); } else { $outstr .= ''; } $last_pos = $$pos[0]; } return $outstr. $self->{html_escape_code_ref}->(substr($str, $last_pos)); } ### --- ### Prepare hash for container matching ### --- sub _makeAllowHash { my $self = shift; if (! exists $self->{syntax}->[$_[0]]->{container} ) { return; } my $allowed = $self->{syntax}->[$_[0]]->{container}; if (ref $allowed eq 'ARRAY') { foreach my $class ( @$allowed ) { $self->{syntax}->[$_[0]]->{_cont_hash}->{$class} = 0; } } elsif ($allowed) { $self->{syntax}->[$_[0]]->{_cont_hash}->{$allowed} = 0; } } ### --- ### Make markup map ### --------------------------------------- ### | open_pos | close_pos | syntax index ### | open_pos | close_pos | syntax index ### | open_pos | close_pos | syntax index ### --------------------------------------- ### --- sub _make_map { no warnings; ### Avoid Deep Recursion warning my ($self, $str, $index, $pos) = @_; $pos ||= 0; my $map_ref = $self->{_markup_map}; my @scraps = split(/$self->{syntax}->[$index]->{regexp}/, $str, 2); if ((scalar @scraps) >= 2) { my $rest = pop(@scraps); my $ins_pos0 = $pos + length($scraps[0]); my $ins_pos1 = $pos + (length($str) - length($rest)); ### Add markup position push(@$map_ref, [ $ins_pos0, $ins_pos1, $index, ] ); ### Recurseion for rest $self->_make_map($rest, $index, $ins_pos1); } ### Follow up process elsif (@$map_ref) { @$map_ref = sort { $$a[0] <=> $$b[0] or $$b[1] <=> $$a[1] or $$a[2] <=> $$b[2] } @$map_ref; } return; } ### --- ### restracture the map data into following format ### ------------------------ ### | open_pos | syntax ref ### | close_pos | ### | open_pos | syntax ref ### | close_pos | ### ------------------------ ### --- sub _restracture_map { my $self = shift; my $map_ref = $self->{_markup_map}; my @out_array; my @root = (); REGLOOP: for (my $i = 0; $i < scalar @$map_ref; $i++) { ### vacuum @root for (my $j = 0; $j < scalar @root; $j++) { if ($root[$j]->[1] <= $$map_ref[$i]->[0]) { splice(@root, $j--, 1); } } my $syntax_ref = $self->{syntax}->[$$map_ref[$i]->[2]]; my $ok = 0; ### no container restriction if (! exists $$syntax_ref{container}) { if (!scalar @root) { $ok = 1; } } else { ### Search for container BACKWARD: for (my $j = scalar @root - 1; $j >= 0; $j--) { ### overlap? if ($root[$j]->[1] > $$map_ref[$i]->[0]) { ### contained? if ($root[$j]->[1] >= $$map_ref[$i]->[1]) { my $root_class = $self->{syntax}->[$root[$j]->[2]]->{class}; if (exists $$syntax_ref{_cont_hash}->{$root_class}) { $ok = 1; last BACKWARD; # allowed } last BACKWARD; # container not allowed } last BACKWARD; # illigal overlap } splice(@root, $j, 1); } } if (! $ok) { splice(@$map_ref, $i--, 1); next REGLOOP; } push(@root, $$map_ref[$i]); push( @out_array, [$$map_ref[$i]->[0], $syntax_ref], [$$map_ref[$i]->[1]] ); } @out_array = sort {$$a[0] <=> $$b[0]} @out_array; return @out_array; } ### --- ### replace tabs to spaces ### --- sub _tab2space { no warnings 'recursion'; my ($str, $width) = @_; $str ||= ''; $width = defined $width ? $width : 4; my @scraps = split(/\t/, $str, 2); if (scalar @scraps == 2) { my $num = $width - (length($scraps[0]) % $width); my $right_str = &_tab2space($scraps[1], $width); return ($scraps[0]. ' ' x $num. $right_str); } return $str; } ### --- ### convert array to regexp ### --- sub array2regexp { my $self = shift; return sprintf('\\b(?:%s)\\b', join('|', @_)); } ### --- ### Return Class names ### --- sub getClassNames { return map {${$_}{class}} @{shift->{syntax}} } ### --- ### HTML escape ### --- sub _html_escape { my ($str) = @_; $str =~ s/&/&/g; $str =~ s//>/g; return $str; } 1; __END__ =head1 NAME Syntax::Highlight::Engine::Simple - Simple Syntax Highlight Engine =head1 VERSION This document describes Syntax::Highlight::Engine::Simple =head1 SYNOPSIS use Syntax::Highlight::Engine::Simple; # Constractor $highlight = Syntax::Highlight::Engine::Simple->new(%hash); # Parameter configuration $highlight->setParams(%hash); # Syntax definision and addition $highlight->setSyntax(%hash); $highlight->appendSyntax(%hash); # Perse $highlight->doFile(%hash); $highlight->doStr(%hash); # Utilities $highlight->array2regexp(%hash); $highlight->getClassNames(%hash); =head1 DESCRIPTION This is a Syntax highlight Engine. This generates a part of HTML string by marking up the input string with span tags along the given rules so that you can easily coloring with CSS. Advantage is the simpleness. This provides a simple way to define the highlighting rules by packing the complicated part of it into regular expression. Also, This works faster than similar highlight solutions on rough benchmarks. Here is a working example of This module. http://jamadam.com/dev/cpan/demo/Syntax/Highlight/Engine/Simple/ =head1 INTERFACE =head2 new I constractor calls for following arguments. =over B File type. This argument causes specific sub class to be loaded. B With this argument, you can assign rules in constractor. =back =head2 setParams This method calls for following arguments. =over B HTML escape code ref. Default subroutine escapes 3 characters '&', '<' and '>'. =back =head2 setSyntax Set the rules for highlight. It calls for a argument I in array. $highlighter->setSyntax( syntax => [ { class => 'tag', regexp => "<.+?>", }, { class => 'quote', regexp => "'.*?'", container => 'tag', }, { class => 'wquote', regexp => '".*?"', container => 'tag', }, { class => 'keyword', regexp => 'somekeyword', container => ['tag', 'quote', 'wquote'], }, ] ); The array can contain rules in hash which is consists of 3 keys, I, I and I. =over B This appears to the output SPAN tag. B Regular expression to be highlighted. B Class names of allowed container. It can be given in String or Array. This restricts the I to stand only inside of the classes. This parameter also works to ease the regulation some time. The highlighting rules doesn't stand in any container in default. This parameter eliminates it. =back =head2 appendSyntax Append syntax by giving a hash. $highlighter->setSyntax( syntax => { class => 'quote', regexp => "'.*?'", container => 'tag', } ); =head2 doStr Highlighting input string and returns the marked up string. This method calls for following arguments. =over B String. B Tab width for tab-space conversion. -1 for disable it. -1 is the default. =back $highlighter->doStr( str => $str, tab_width => 4 ); =head2 doFile Highlighting the file and returns the marked up string. This method calls for following arguments. =over B File name. B Tab width for tab-space conversion. -1 for disable it. -1 is the default. B Set the encode of file. utf8 is the default. =back $highlighter->doStr( str => $str, tab_width => 4, encode => 'utf8' ); =head2 array2regexp This is a utility method for converting string array to regular expression. =over =back =head2 getClassNames Returns the class names in array. =over =back =head1 DIAGNOSTICS =over =item C<< doStr method got undefined value >> =item C<< File open failed >> =back =head1 CONFIGURATION AND ENVIRONMENT I requires no configuration files or environment variables. Specific language syntax can be defined with sub classes and loaded in constructor if you give it the type argument. =head1 DEPENDENCIES =over =item L =item L =back =head1 INCOMPATIBILITIES None reported. =head1 BUGS AND LIMITATIONS No bugs have been reported. Please report any bugs or feature requests to C, or through the web interface at L. =head1 SEE ALSO =over =item L =item L =back =head1 AUTHOR Sugama Keita C<< >> =head1 LICENCE AND COPYRIGHT Copyright (c) 2008, Sugama Keita C<< >>. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See I. =head1 DISCLAIMER OF WARRANTY BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. =cut Syntax-Highlight-Engine-Simple-0.09/Makefile.PL0000755000175000017540000000115711605215304020633 0ustar sugamacutoutuse strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( NAME => 'Syntax::Highlight::Engine::Simple', AUTHOR => 'Sugama Keita ', VERSION_FROM => 'lib/Syntax/Highlight/Engine/Simple.pm', ABSTRACT_FROM => 'lib/Syntax/Highlight/Engine/Simple.pm', PL_FILES => {}, PREREQ_PM => { 'Test::More' => 0, 'version' => 0, 'encoding' => 0, }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'Syntax-Highlight-Engine-Simple-*' }, ); Syntax-Highlight-Engine-Simple-0.09/t/0000755000175000017540000000000011605236023017116 5ustar sugamacutoutSyntax-Highlight-Engine-Simple-0.09/t/subclass.t0000755000175000017540000002115011036416152021125 0ustar sugamacutoutuse strict; use warnings; use Test::More tests => 3; use Syntax::Highlight::Engine::Simple; my $highlighter; my $expected = ''; my $result = ''; ### ---------------------------------------------------------------------------- ### 1. Sub class ### ---------------------------------------------------------------------------- $highlighter = Syntax::Highlight::Engine::Simple::Perl->new(); $result = $highlighter->doStr(str => <<'ORIGINAL', tab_width => 4); if (1){ return 1; } else { return 2; } ORIGINAL is( $result, $expected=<<'EXPECTED' ); if (1){ return 1; } else { return 2; } EXPECTED ### ---------------------------------------------------------------------------- ### 2. Sub class2 ### ---------------------------------------------------------------------------- $highlighter = Syntax::Highlight::Engine::Simple::HTML->new(); $result = $highlighter->doStr(str => <<'ORIGINAL', tab_width => 4); title "double quote out of tag" keyword out of tag test ORIGINAL is( $result, $expected=<<'EXPECTED' ); <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd"> <html lang="ja"> <head> <meta http-equiv="Content-Type" content="text/html; charset=EUC-JP"> <title>title</title> <link href="/css/itpro/2008/common.css" rel="stylesheet" type="text/css"> <script type='text/javascript'> <!-- var a = 'a'; //--> </script> </head> <body> "double quote out of tag" keyword out of tag <HtML><!-- case ignore test --> test </body> </html> EXPECTED ### ---------------------------------------------------------------------------- ### 3. doFile with Sub Class also include multi byte Charactors ### ---------------------------------------------------------------------------- $highlighter = Syntax::Highlight::Engine::Simple::Perl->new(); $result = $highlighter->doFile(file => './t/testfile/original.txt', tab_width => 4); require 5.005; open(my $filehandle, '<'. './t/testfile/expected.txt'); binmode($filehandle, ":encoding(utf8)"); $expected = join('', <$filehandle>); is( $result, $expected ); ### ---------------------------------------------------------------------------- ### Sub Class for Perl Language ### ---------------------------------------------------------------------------- package Syntax::Highlight::Engine::Simple::Perl; use strict; use warnings; use base qw(Syntax::Highlight::Engine::Simple); sub setSyntax { shift->{syntax} = [ { class => 'quote', regexp => '(? 'quote', regexp => '(? 'quote', regexp => q@'.*?(? 'wquote', regexp => '(? 'wquote', regexp => q@".*?(? 'comment', regexp => '(?m)#+.*?$', }, { class => 'variable', regexp => '[\$\@\%][\w\d:]+', }, { class => 'function', regexp => '\&[\w\d:]+', }, { class => 'method', regexp => '(?<=->)[\w\d:]+', }, { class => 'number', regexp => '\b\d+\b', }, { class => 'keyword', regexp => __PACKAGE__->array2regexp(&getStatementKeywords()), }, { class => 'keyword', regexp => __PACKAGE__->array2regexp(&getKeywords()), }, { class => 'regexp_statement', regexp => '(?<=(? 'regexp_statement', regexp => '(?<=(? 'regexp_statement', regexp => '/.+?/', }, { class => 'perlpod', regexp => '(?sm)^=.+?(^=cut$)', }, { class => 'keyword2', regexp => '(?m)^=.+$', container => 'perlpod', }, { class => 'statement', regexp => '(?m)^=\w+', container => 'keyword2', }, ]; } sub getStatementKeywords { return ( 'continue', 'foreach', 'require', 'package', 'scalar', 'format', 'unless', 'local', 'until', 'while', 'elsif', 'next', 'last', 'goto', 'else', 'redo', 'sub', 'for', 'use', 'our', 'no', 'if', 'my', 'qr', 'qx', # 'qq', # 'qw', # 'tr', # 'm', # 'q', # 's', # 'y' ); } sub getKeywords { return ( 'getprotobynumber', 'getprotobyname', 'gethostbyaddr', 'gethostbyname', 'getservbyname', 'getservbyport', 'getnetbyaddr', 'getnetbyname', 'endprotoent', 'getpeername', 'getpriority', 'getprotoent', 'getsockname', 'setpriority', 'setprotoent', 'endhostent', 'endservent', 'gethostent', 'getservent', 'getsockopt', 'sethostent', 'setservent', 'setsockopt', 'socketpair', 'endnetent', 'getnetent', 'localtime', 'prototype', 'quotemeta', 'rewinddir', 'setnetent', 'wantarray', 'closedir', 'dbmclose', 'endgrent', 'endpwent', 'formline', 'getgrent', 'getgrgid', 'getgrnam', 'getlogin', 'getpwent', 'getpwnam', 'getpwuid', 'readline', 'readlink', 'readpipe', 'setgrent', 'setpwent', 'shmwrite', 'shutdown', 'syswrite', 'truncate', 'binmode', 'connect', 'dbmopen', 'defined', 'getpgrp', 'getppid', 'lcfirst', 'opendir', 'readdir', 'reverse', 'seekdir', 'setpgrp', 'shmread', 'sprintf', 'symlink', 'syscall', 'sysopen', 'sysread', 'sysseek', 'telldir', 'ucfirst', 'unshift', 'waitpid', 'accept', 'caller', 'chroot', 'delete', 'exists', 'fileno', 'gmtime', 'import', 'length', 'listen', 'msgctl', 'msgget', 'msgrcv', 'msgsnd', 'printf', 'rename', 'return', 'rindex', 'select', 'semctl', 'semget', 'shmctl', 'shmget', 'socket', 'splice', 'substr', 'system', 'unlink', 'unpack', 'values', 'alarm', 'atan2', 'bless', 'break', 'chdir', 'chmod', 'chomp', 'chown', 'close', 'crypt', 'fcntl', 'flock', 'index', 'ioctl', 'lstat', 'mkdir', 'print', 'reset', 'rmdir', 'semop', 'shift', 'sleep', 'split', 'srand', 'study', 'times', 'umask', 'undef', 'untie', 'utime', 'write', 'bind', 'chop', 'dump', 'each', 'eval', 'exec', 'exit', 'fork', 'getc', 'glob', 'grep', 'join', 'keys', 'kill', 'link', 'open', 'pack', 'pipe', 'push', 'rand', 'read', 'recv', 'seek', 'send', 'sort', 'sqrt', 'stat', 'tell', 'tied', 'time', 'wait', 'warn', 'abs', 'chr', 'cos', 'die', 'eof', 'exp', 'hex', 'int', 'log', 'map', 'oct', 'ord', 'pop', 'pos', 'ref', 'sin', 'tie', 'do', 'vec', 'lc', 'uc', ); } ### ---------------------------------------------------------------------------- ### Sub Class for HTML Language ### ---------------------------------------------------------------------------- package Syntax::Highlight::Engine::Simple::HTML; use strict; use warnings; use base qw(Syntax::Highlight::Engine::Simple); sub setSyntax { shift->{syntax} = [ { class => 'tag', regexp => q!(?s)(?<=<).+?(?=>)!, }, { class => 'quote', regexp => q!(?s)'.*?'!, container => 'tag', }, { class => 'wquote', regexp => q!(?s)".*?"!, container => 'tag', }, { class => 'number', regexp => '\b\d+\b', container => 'tag', }, { class => 'comment', regexp => '(?s)', }, { class => 'url', regexp => q!s?https?://[-_.\!~*'()a-zA-Z0-9;/?:@&=+$,%#]+!, }, ]; } Syntax-Highlight-Engine-Simple-0.09/t/testfile/0000755000175000017540000000000011605236023020735 5ustar sugamacutoutSyntax-Highlight-Engine-Simple-0.09/t/testfile/3original.txt0000755000175000017540000000000411036407262023365 0ustar sugamacutoutดมป๚Syntax-Highlight-Engine-Simple-0.09/t/testfile/expected.txt0000755000175000017540000007375611036416071023325 0ustar sugamacutoutpackage Syntax::Highlight::Engine::Simple; use warnings; use strict; use Carp; use version; our $VERSION = qv('0.0.1'); #use Data::Dumper; my $dump = Dumper($res->{'_headers'}); $dump =~ s/\\x{([0-9a-z]+)}/chr(hex($1))/ge; print "<pre>$dump</pre>";use version; ### ---------------------------------------------------------------------------- ### constractor ### ---------------------------------------------------------------------------- sub new { my $class = shift; my $self = bless {syntax => undef, encode => 'utf8', @_}, $class; $self->setSyntax(); $self->setParams(@_); return $self; } ### ---------------------------------------------------------------------------- ### set params ### ---------------------------------------------------------------------------- sub setParams { my $self = shift; my %args = ( html_escape_code_ref => \&_html_escape, encode => $self->{encode}, @_); $self->{encode} = $args{encode}; $self->{html_escape_code_ref} = $args{html_escape_code_ref}; } ### ---------------------------------------------------------------------------- ### set syntax ### ---------------------------------------------------------------------------- sub setSyntax { my $self = shift; my %args = (syntax => [], @_); $self->{syntax} = $args{syntax}; } ### ---------------------------------------------------------------------------- ### append syntax ### ---------------------------------------------------------------------------- sub appendSyntax { my $self = shift; my %args = ( syntax => { regexp => '', class => '', allow_nest => 0, }, @_); push(@{$self->{syntax}}, $args{syntax}); } ### ---------------------------------------------------------------------------- ### Highlight multi Line ### ---------------------------------------------------------------------------- sub doStr{ my $self = shift; my %args = (str => '', tab_width => -1, @_); if ($args{tab_width} > 0) { my $tabed = ''; foreach my $line (split(/\r\n|\r|\n/, $args{str})) { $tabed .= &_tab2space(str => $line, tab_width => $args{tab_width}). "\n"; } $args{str} = $tabed; } return $self->doLine(str => $args{str}); } ### ---------------------------------------------------------------------------- ### Highlight file ### ---------------------------------------------------------------------------- sub doFile { my $self = shift; my %args = (file => '', tab_width => -1, @_); my $str = ''; open(my $filehandle, '<'. $self->{encode},$args{file}) or croak 'File open failed'; while (my $line = <$filehandle>) { if ($args{tab_width} > 0) { $line = &_tab2space(str => $line, tab_width => $args{tab_width}); } $str .= $line; } close($filehandle); return $self->doLine(str => $str); } ### ---------------------------------------------------------------------------- ### Highlight single line ### ---------------------------------------------------------------------------- sub doLine { my $self = shift; my %args = ( str => '', @_); my $str = $args{str}; $str =~ s/\r\n|\r/\n/g; $self->{_markup_map} = []; ### make markup map foreach my $regexp (@{$self->{syntax}}) { $self->{_regexp} = $regexp->{regexp}; $self->{_class} = $regexp->{class}; $self->{_allow_nest} = $regexp->{allow_nest}; $self->_make_map(str => $str); } $self->_vacuum_map(); my $outstr = ''; ### Apply the markup map to string { my @markup_array; ### Restructure the map array foreach my $elem (@{$self->{_markup_map}}) { push(@markup_array, [$elem->[0], $elem->[2]], [$elem->[1]]); } @markup_array = sort {$a->[0] <=> $b->[0]} @markup_array; my $last_pos = 0; foreach my $pos (@markup_array) { my $str_left = substr($str, $last_pos, $pos->[0] - $last_pos); no strict 'refs'; $str_left = &{$self->{html_escape_code_ref}}($str_left); if (defined $pos->[1]) { $outstr .= sprintf("%s<span class='%s'>", $str_left, $pos->[1]); } else { $outstr .= sprintf("%s</span>", $str_left); } $last_pos = $pos->[0]; } $outstr .= substr($str, $last_pos); } return $outstr; } ### ---------------------------------------------------------------------------- ### Make markup map ### ---------------------------------------------------------------------------- sub _make_map { no warnings; ### Avoid Deep Recursion warning my $self = shift; my %args = ( str => '', pos => 0, @_); my $alias = $self->{_markup_map}; my @scraps = split(/($self->{_regexp})/, $args{str}, 2); if ((scalar @scraps) >= 3) { my $ins_pos0 = length($scraps[0]) + $args{pos}; my $ins_pos1 = length($scraps[1]) + $ins_pos0; ### Add markup position push( @$alias, [ $ins_pos0, $ins_pos1, $self->{_class}, ($self->{_allow_nest} or 0) ] ); ### Recurseion for rest $self->_make_map(str => pop(@scraps), pos => $ins_pos1); #$self->_make_map( # str => substr($scraps[1], 1). pop(@scraps), # pos => $ins_pos0 + 1 #); } ### Follow up process elsif (@$alias) { @$alias = sort {$a->[0] <=> $b->[0]} @$alias; } return; } ### ---------------------------------------------------------------------------- ### Vacuum map data ### ---------------------------------------------------------------------------- sub _vacuum_map { my $self = shift; my $alias = $self->{_markup_map}; $self->{_max_close_point} = $$alias[0]->[1]; ENTRY_LOOP: for (my $i = 1; $i < scalar @$alias; $i++) { ### Remove illigal overlap if ($$alias[$i]->[0] < $$alias[$i - 1]->[1] and $$alias[$i]->[1] >= $$alias[$i - 1]->[1]) { splice(@$alias, $i--, 1); next ENTRY_LOOP; } ### Remove nest if not allowed if (! $$alias[$i]->[3] and $$alias[$i]->[1] <= $self->{_max_close_point}) { splice(@$alias, $i--, 1); next ENTRY_LOOP; } if ($$alias[$i]->[1] > $self->{_max_close_point}) { $self->{_max_close_point} = $$alias[$i]->[1]; } } } ### ---------------------------------------------------------------------------- ### Return map for debug ### ---------------------------------------------------------------------------- sub _ret_map { return shift->{_markup_map}; } ### ---------------------------------------------------------------------------- ### replace tabs to spaces ### ---------------------------------------------------------------------------- sub _tab2space { no warnings; ### Avoid Deep Recursion warning my %args = (str => '', tab_width => 4, @_); my @scraps = split(/\t/, $args{str}, 2); if (scalar @scraps == 2) { my $num = $args{tab_width} - (length($scraps[0]) % $args{tab_width}); my $right_str = &_tab2space(%args, str => $scraps[1]); return ($scraps[0]. ' ' x $num. $right_str); } return $args{str}; } ### ---------------------------------------------------------------------------- ### convert array to regexp ### ---------------------------------------------------------------------------- sub array2regexp { my $self = shift; return sprintf('\\b(?:%s)\\b', join('|', @_)); } ### ---------------------------------------------------------------------------- ### convert array to regexp ### ---------------------------------------------------------------------------- sub getClassNames { return map {$_->{class}} @{shift->{syntax}} } ### ---------------------------------------------------------------------------- ### HTML escape ### ---------------------------------------------------------------------------- sub _html_escape { my ($str) = @_; $str =~ s/&/&amp;/g; $str =~ s/</&lt;/g; $str =~ s/>/&gt;/g; return $str; } 1; # Magic true value required at end of module __END__ =head1 NAME Syntax::Highlight::Engine::Simple - Simple, fast and flexible Syntax Highlight Engine =head1 VERSION This document describes Syntax::Highlight::Engine::Simple version 0.0.1 =head1 SYNOPSIS use Syntax::Highlight::Engine::Simple; # Constractor $highlight = Syntax::Highlight::Engine::Simple->new(%hash); # Parameter configuration $highlight->setParams(%hash); # Syntax definision and addition $highlight->setSyntax(%hash); $highlight->appendSyntax(%hash); # Perse $highlight->doLine(%hash); $highlight->doFile(%hash); $highlight->doStr(%hash); # Utilities $highlight->array2regexp(%hash); $highlight->getClassNames(%hash); =head1 DESCRIPTION This is a Syntax highlight Engine. You can easily and minutely define the rules for highlighting by regular expressions. This is much faster than Text::VimColor or Syntax::Highlight::Engine::Kate. A working example of This module is at bellow. http://jamadam.com/cpan/demo/Syntax/Highlight/Engine/Simple/ =head1 INTERFACE =over =item new =item setParams =item setSyntax =item appendSyntax =item doStr =item doFile =item doLine =item array2regexp =item getClassNames =back =head1 DIAGNOSTICS =for author to fill in: List every single error and warning message that the module can generate (even the ones that will "never happen"), with a full explanation of each problem, one or more likely causes, and any suggested remedies. =over =item C<< Error message here, perhaps with %s placeholders >> [Description of error here] =item C<< Another error message here >> [Description of error here] [Et cetera, et cetera] =back =head1 CONFIGURATION AND ENVIRONMENT =for author to fill in: A full explanation of any configuration system(s) used by the module, including the names and locations of any configuration files, and the meaning of any environment variables or properties that can be set. These descriptions must also include details of any configuration language used. Syntax::Highlight::Engine::Simple requires no configuration files or environment variables. =head1 DEPENDENCIES =for author to fill in: A list of all the other modules that this module relies upon, including any restrictions on versions, and an indication whether the module is part of the standard Perl distribution, part of the module's distribution, or must be installed separately. ] None. =head1 INCOMPATIBILITIES =for author to fill in: A list of any modules that this module cannot be used in conjunction with. This may be due to name conflicts in the interface, or competition for system or program resources, or due to internal limitations of Perl (for example, many modules that use source code filters are mutually incompatible). None reported. =head1 BUGS AND LIMITATIONS =for author to fill in: A list of known problems with the module, together with some indication Whether they are likely to be fixed in an upcoming release. Also a list of restrictions on the features the module does provide: data types that cannot be handled, performance issues and the circumstances in which they may arise, practical limitations on the size of data sets, special cases that are not (yet) handled, etc. No bugs have been reported. Please report any bugs or feature requests to C<bug-syntax-highlight-engine-Simple@rt.cpan.org>, or through the web interface at L<http://rt.cpan.org>. =head1 AUTHOR Sugama Keita C<< <sugama@jamadam.com> >> =head1 LICENCE AND COPYRIGHT Copyright (c) 2008, Sugama Keita C<< <sugama@jamadam.com> >>. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L<perlartistic>. =head1 DISCLAIMER OF WARRANTY BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. =cut Syntax-Highlight-Engine-Simple-0.09/t/testfile/original.txt0000755000175000017540000003123711034602064023311 0ustar sugamacutoutpackage Syntax::Highlight::Engine::Simple; use warnings; use strict; use Carp; use version; our $VERSION = qv('0.0.1'); #use Data::Dumper; my $dump = Dumper($res->{'_headers'}); $dump =~ s/\\x{([0-9a-z]+)}/chr(hex($1))/ge; print "
$dump
";use version; ### ---------------------------------------------------------------------------- ### constractor ### ---------------------------------------------------------------------------- sub new { my $class = shift; my $self = bless {syntax => undef, encode => 'utf8', @_}, $class; $self->setSyntax(); $self->setParams(@_); return $self; } ### ---------------------------------------------------------------------------- ### set params ### ---------------------------------------------------------------------------- sub setParams { my $self = shift; my %args = ( html_escape_code_ref => \&_html_escape, encode => $self->{encode}, @_); $self->{encode} = $args{encode}; $self->{html_escape_code_ref} = $args{html_escape_code_ref}; } ### ---------------------------------------------------------------------------- ### set syntax ### ---------------------------------------------------------------------------- sub setSyntax { my $self = shift; my %args = (syntax => [], @_); $self->{syntax} = $args{syntax}; } ### ---------------------------------------------------------------------------- ### append syntax ### ---------------------------------------------------------------------------- sub appendSyntax { my $self = shift; my %args = ( syntax => { regexp => '', class => '', allow_nest => 0, }, @_); push(@{$self->{syntax}}, $args{syntax}); } ### ---------------------------------------------------------------------------- ### Highlight multi Line ### ---------------------------------------------------------------------------- sub doStr{ my $self = shift; my %args = (str => '', tab_width => -1, @_); if ($args{tab_width} > 0) { my $tabed = ''; foreach my $line (split(/\r\n|\r|\n/, $args{str})) { $tabed .= &_tab2space(str => $line, tab_width => $args{tab_width}). "\n"; } $args{str} = $tabed; } return $self->doLine(str => $args{str}); } ### ---------------------------------------------------------------------------- ### Highlight file ### ---------------------------------------------------------------------------- sub doFile { my $self = shift; my %args = (file => '', tab_width => -1, @_); my $str = ''; open(my $filehandle, '<'. $self->{encode},$args{file}) or croak 'File open failed'; while (my $line = <$filehandle>) { if ($args{tab_width} > 0) { $line = &_tab2space(str => $line, tab_width => $args{tab_width}); } $str .= $line; } close($filehandle); return $self->doLine(str => $str); } ### ---------------------------------------------------------------------------- ### Highlight single line ### ---------------------------------------------------------------------------- sub doLine { my $self = shift; my %args = ( str => '', @_); my $str = $args{str}; $str =~ s/\r\n|\r/\n/g; $self->{_markup_map} = []; ### make markup map foreach my $regexp (@{$self->{syntax}}) { $self->{_regexp} = $regexp->{regexp}; $self->{_class} = $regexp->{class}; $self->{_allow_nest} = $regexp->{allow_nest}; $self->_make_map(str => $str); } $self->_vacuum_map(); my $outstr = ''; ### Apply the markup map to string { my @markup_array; ### Restructure the map array foreach my $elem (@{$self->{_markup_map}}) { push(@markup_array, [$elem->[0], $elem->[2]], [$elem->[1]]); } @markup_array = sort {$a->[0] <=> $b->[0]} @markup_array; my $last_pos = 0; foreach my $pos (@markup_array) { my $str_left = substr($str, $last_pos, $pos->[0] - $last_pos); no strict 'refs'; $str_left = &{$self->{html_escape_code_ref}}($str_left); if (defined $pos->[1]) { $outstr .= sprintf("%s", $str_left, $pos->[1]); } else { $outstr .= sprintf("%s", $str_left); } $last_pos = $pos->[0]; } $outstr .= substr($str, $last_pos); } return $outstr; } ### ---------------------------------------------------------------------------- ### Make markup map ### ---------------------------------------------------------------------------- sub _make_map { no warnings; ### Avoid Deep Recursion warning my $self = shift; my %args = ( str => '', pos => 0, @_); my $alias = $self->{_markup_map}; my @scraps = split(/($self->{_regexp})/, $args{str}, 2); if ((scalar @scraps) >= 3) { my $ins_pos0 = length($scraps[0]) + $args{pos}; my $ins_pos1 = length($scraps[1]) + $ins_pos0; ### Add markup position push( @$alias, [ $ins_pos0, $ins_pos1, $self->{_class}, ($self->{_allow_nest} or 0) ] ); ### Recurseion for rest $self->_make_map(str => pop(@scraps), pos => $ins_pos1); #$self->_make_map( # str => substr($scraps[1], 1). pop(@scraps), # pos => $ins_pos0 + 1 #); } ### Follow up process elsif (@$alias) { @$alias = sort {$a->[0] <=> $b->[0]} @$alias; } return; } ### ---------------------------------------------------------------------------- ### Vacuum map data ### ---------------------------------------------------------------------------- sub _vacuum_map { my $self = shift; my $alias = $self->{_markup_map}; $self->{_max_close_point} = $$alias[0]->[1]; ENTRY_LOOP: for (my $i = 1; $i < scalar @$alias; $i++) { ### Remove illigal overlap if ($$alias[$i]->[0] < $$alias[$i - 1]->[1] and $$alias[$i]->[1] >= $$alias[$i - 1]->[1]) { splice(@$alias, $i--, 1); next ENTRY_LOOP; } ### Remove nest if not allowed if (! $$alias[$i]->[3] and $$alias[$i]->[1] <= $self->{_max_close_point}) { splice(@$alias, $i--, 1); next ENTRY_LOOP; } if ($$alias[$i]->[1] > $self->{_max_close_point}) { $self->{_max_close_point} = $$alias[$i]->[1]; } } } ### ---------------------------------------------------------------------------- ### Return map for debug ### ---------------------------------------------------------------------------- sub _ret_map { return shift->{_markup_map}; } ### ---------------------------------------------------------------------------- ### replace tabs to spaces ### ---------------------------------------------------------------------------- sub _tab2space { no warnings; ### Avoid Deep Recursion warning my %args = (str => '', tab_width => 4, @_); my @scraps = split(/\t/, $args{str}, 2); if (scalar @scraps == 2) { my $num = $args{tab_width} - (length($scraps[0]) % $args{tab_width}); my $right_str = &_tab2space(%args, str => $scraps[1]); return ($scraps[0]. ' ' x $num. $right_str); } return $args{str}; } ### ---------------------------------------------------------------------------- ### convert array to regexp ### ---------------------------------------------------------------------------- sub array2regexp { my $self = shift; return sprintf('\\b(?:%s)\\b', join('|', @_)); } ### ---------------------------------------------------------------------------- ### convert array to regexp ### ---------------------------------------------------------------------------- sub getClassNames { return map {$_->{class}} @{shift->{syntax}} } ### ---------------------------------------------------------------------------- ### HTML escape ### ---------------------------------------------------------------------------- sub _html_escape { my ($str) = @_; $str =~ s/&/&/g; $str =~ s//>/g; return $str; } 1; # Magic true value required at end of module __END__ =head1 NAME Syntax::Highlight::Engine::Simple - Simple, fast and flexible Syntax Highlight Engine =head1 VERSION This document describes Syntax::Highlight::Engine::Simple version 0.0.1 =head1 SYNOPSIS use Syntax::Highlight::Engine::Simple; # Constractor $highlight = Syntax::Highlight::Engine::Simple->new(%hash); # Parameter configuration $highlight->setParams(%hash); # Syntax definision and addition $highlight->setSyntax(%hash); $highlight->appendSyntax(%hash); # Perse $highlight->doLine(%hash); $highlight->doFile(%hash); $highlight->doStr(%hash); # Utilities $highlight->array2regexp(%hash); $highlight->getClassNames(%hash); =head1 DESCRIPTION This is a Syntax highlight Engine. You can easily and minutely define the rules for highlighting by regular expressions. This is much faster than Text::VimColor or Syntax::Highlight::Engine::Kate. A working example of This module is at bellow. http://jamadam.com/cpan/demo/Syntax/Highlight/Engine/Simple/ =head1 INTERFACE =over =item new =item setParams =item setSyntax =item appendSyntax =item doStr =item doFile =item doLine =item array2regexp =item getClassNames =back =head1 DIAGNOSTICS =for author to fill in: List every single error and warning message that the module can generate (even the ones that will "never happen"), with a full explanation of each problem, one or more likely causes, and any suggested remedies. =over =item C<< Error message here, perhaps with %s placeholders >> [Description of error here] =item C<< Another error message here >> [Description of error here] [Et cetera, et cetera] =back =head1 CONFIGURATION AND ENVIRONMENT =for author to fill in: A full explanation of any configuration system(s) used by the module, including the names and locations of any configuration files, and the meaning of any environment variables or properties that can be set. These descriptions must also include details of any configuration language used. Syntax::Highlight::Engine::Simple requires no configuration files or environment variables. =head1 DEPENDENCIES =for author to fill in: A list of all the other modules that this module relies upon, including any restrictions on versions, and an indication whether the module is part of the standard Perl distribution, part of the module's distribution, or must be installed separately. ] None. =head1 INCOMPATIBILITIES =for author to fill in: A list of any modules that this module cannot be used in conjunction with. This may be due to name conflicts in the interface, or competition for system or program resources, or due to internal limitations of Perl (for example, many modules that use source code filters are mutually incompatible). None reported. =head1 BUGS AND LIMITATIONS =for author to fill in: A list of known problems with the module, together with some indication Whether they are likely to be fixed in an upcoming release. Also a list of restrictions on the features the module does provide: data types that cannot be handled, performance issues and the circumstances in which they may arise, practical limitations on the size of data sets, special cases that are not (yet) handled, etc. No bugs have been reported. Please report any bugs or feature requests to C, or through the web interface at L. =head1 AUTHOR Sugama Keita C<< >> =head1 LICENCE AND COPYRIGHT Copyright (c) 2008, Sugama Keita C<< >>. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =head1 DISCLAIMER OF WARRANTY BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. =cut Syntax-Highlight-Engine-Simple-0.09/t/testfile/2original.txt0000755000175000017540000000000611036407232023363 0ustar sugamacutoutๆผขๅญ—Syntax-Highlight-Engine-Simple-0.09/t/testfile/4original.txt0000755000175000017540000000000411036411035023357 0ustar sugamacutoutŠฟŽšSyntax-Highlight-Engine-Simple-0.09/t/00.load.t0000755000175000017540000000026711034322755020454 0ustar sugamacutoutuse Test::More tests => 1; BEGIN { use_ok( 'Syntax::Highlight::Engine::Simple' ); } diag( "Testing Syntax::Highlight::Engine::Simple $Syntax::Highlight::Engine::Simple::VERSION" ); Syntax-Highlight-Engine-Simple-0.09/t/highlight.t0000755000175000017540000001345311605212654021267 0ustar sugamacutoutuse strict; use warnings; use Test::More tests => 11; use Syntax::Highlight::Engine::Simple; use encoding 'utf8'; binmode(STDIN, ":utf8"); binmode(STDOUT, ":utf8"); binmode(STDERR, ":utf8"); my $highlighter = Syntax::Highlight::Engine::Simple->new(); my $expected = ''; my $result = ''; ### ---------------------------------------------------------------------------- ### 1. Define syntax ### ---------------------------------------------------------------------------- $highlighter->setSyntax( syntax => [ { class => 'quote', regexp => q@'.*?(? 'comment', regexp => '(?m)#+.*?$', }, ] ); is( $highlighter->doStr(str => <<'ORIGINAL'), $expected=<<'EXPECTED' ); #01 # comment 'inside' out "inside" out ORIGINAL # comment 'inside' out "inside" out EXPECTED ### ---------------------------------------------------------------------------- ### 2. Append syntax ### ---------------------------------------------------------------------------- $highlighter->appendSyntax( syntax => { class => 'wquote', regexp => q@".*?(?doStr(str => <<'ORIGINAL'); # comment 'inside' out "inside" out ORIGINAL is( $result, $expected=<<'EXPECTED' ); #02 # comment 'inside' out "inside" out EXPECTED ### ---------------------------------------------------------------------------- ### 3. Keyword difinision with Array ### ---------------------------------------------------------------------------- $highlighter->appendSyntax( syntax => { class => 'statement', regexp => $highlighter->array2regexp(qw(if else return)), }, ); $result = $highlighter->doStr(str => <<'ORIGINAL'); if (1){ return 1; } else { return 2; } ORIGINAL is( $result, $expected=<<'EXPECTED' ); #03 if (1){ return 1; } else { return 2; } EXPECTED ### ---------------------------------------------------------------------------- ### 4. Convert tab to spaces ### ---------------------------------------------------------------------------- $result = $highlighter->doStr(str => <<'ORIGINAL', tab_width => 4); if (1){ return 1; } else { return 2; } ORIGINAL is( $result, $expected=<<'EXPECTED' ); if (1){ return 1; } else { return 2; } EXPECTED ### ---------------------------------------------------------------------------- ### 5. Multi byte(Japanese test bellow) ### ---------------------------------------------------------------------------- $result = $highlighter->doStr(str => <<'ORIGINAL', tab_width => 4); ใ‚ใ„ใ†ใˆใŠ"ใ‹ใใใ‘ใ“"ใ•ใ—ใ™ใ›ใ'ใŸใกใคใฆใจ' ORIGINAL is( $result, $expected=<<'EXPECTED' ); ใ‚ใ„ใ†ใˆใŠ"ใ‹ใใใ‘ใ“"ใ•ใ—ใ™ใ›ใ'ใŸใกใคใฆใจ' EXPECTED ### ---------------------------------------------------------------------------- ### 6. Priority control ### ---------------------------------------------------------------------------- $highlighter = Syntax::Highlight::Engine::Simple->new(); $highlighter->setSyntax( syntax => [ { class => 'a', regexp => 'test', }, { class => 'b', regexp => 'test', }, ] ); $result = $highlighter->doStr(str => <<'ORIGINAL'); test test2 ORIGINAL is( $result, $expected=<<'EXPECTED' ); test test2 EXPECTED ### ---------------------------------------------------------------------------- ### 7. Embracement Allowance ### ---------------------------------------------------------------------------- $highlighter->appendSyntax( syntax => { class => 'c', regexp => 'test', container => 'a', }, ); $result = $highlighter->doStr(str => <<'ORIGINAL'); test test2 ORIGINAL is( $result, $expected=<<'EXPECTED' ); test test2 EXPECTED ### ---------------------------------------------------------------------------- ### 8. Embracement Allowance ### ---------------------------------------------------------------------------- $highlighter->appendSyntax( syntax => { class => 'd', regexp => 'tes', container => 'a', }, ); $result = $highlighter->doStr(str => <<'ORIGINAL'); test ORIGINAL is( $result, $expected=<<'EXPECTED' ); test EXPECTED ### ---------------------------------------------------------------------------- ### 9. doFile with Sub Class also include multi byte Charactors ### ---------------------------------------------------------------------------- $result = $highlighter->doFile(file => './t/testfile/2original.txt', tab_width => 4); is( $result, 'ๆผขๅญ—'); ### ---------------------------------------------------------------------------- ### 10. doFile with Sub Class also include multi byte Charactors ### ---------------------------------------------------------------------------- $result = $highlighter->doFile(file => './t/testfile/3original.txt', tab_width => 4, encode => 'euc-jp'); is( $result, 'ๆผขๅญ—'); ### ---------------------------------------------------------------------------- ### 10. doFile with Sub Class also include multi byte Charactors ### ---------------------------------------------------------------------------- $result = $highlighter->doFile(file => './t/testfile/4original.txt', tab_width => 4, encode => 'sjis'); is( $result, 'ๆผขๅญ—'); Syntax-Highlight-Engine-Simple-0.09/t/highlight2.t0000755000175000017540000000372411040534515021345 0ustar sugamacutoutuse strict; use warnings; use Test::More tests => 3; use Syntax::Highlight::Engine::Simple; use encoding 'utf8'; binmode(STDIN, ":utf8"); binmode(STDOUT, ":utf8"); binmode(STDERR, ":utf8"); my $highlighter = Syntax::Highlight::Engine::Simple->new(); my $expected = ''; my $result = ''; ### ---------------------------------------------------------------------------- ### 1. Illigal overlap ### ---------------------------------------------------------------------------- $highlighter->setSyntax( syntax => [ { class => 'a', regexp => "'.+?'", }, { class => 'b', regexp => '".+?"', container => 'a', }, { class => 'c', regexp => "!.+?!", }, ] ); is( $highlighter->doStr(str => <<'ORIGINAL'), $expected=<<'EXPECTED' ); '"b" !c'c! ORIGINAL '"b" !c'c! EXPECTED ### ---------------------------------------------------------------------------- ### 2. Multi container definition ### ---------------------------------------------------------------------------- $highlighter->setSyntax( syntax => [ { class => 'a', regexp => "'.+?'", }, { class => 'b', regexp => '".+?"', }, { class => 'c', regexp => "!.+?!", container => ['a', 'b'], }, ] ); is( $highlighter->doStr(str => <<'ORIGINAL'), $expected=<<'EXPECTED' ); 'aaa!c!aaa' "bbb!c!bbb" ORIGINAL 'aaa!c!aaa' "bbb!c!bbb" EXPECTED ### ---------------------------------------------------------------------------- ### 3. Make sure the close anticipates open at the same position ### ---------------------------------------------------------------------------- $highlighter->setSyntax( syntax => [ { class => 'a', regexp => "a", }, { class => 'b', regexp => '".+?"', }, ] ); is( $highlighter->doStr(str => <<'ORIGINAL'), $expected=<<'EXPECTED' ); a"b" ORIGINAL a"b" EXPECTED Syntax-Highlight-Engine-Simple-0.09/xt/0000755000175000017540000000000011605236023017306 5ustar sugamacutoutSyntax-Highlight-Engine-Simple-0.09/xt/pod-coverage.t0000755000175000017540000000025411034322755022056 0ustar sugamacutout#!perl -T use Test::More; eval "use Test::Pod::Coverage 1.04"; plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@; all_pod_coverage_ok(); Syntax-Highlight-Engine-Simple-0.09/xt/podspell.t0000755000175000017540000000171111601314167021322 0ustar sugamacutoutuse strict; use warnings; use Test::More; use Test::Requires 'Test::Spelling'; use Config; use File::Spec; use ExtUtils::MakeMaker; my %cmd_map = ( spell => 'spell', aspell => 'aspell list -l en', ispell => 'ispell -l', hunspell => 'hunspell -d en_US -l', ); my $spell_cmd; for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; ($spell_cmd) = map { $cmd_map{$_} } grep { my $abs = File::Spec->catfile($dir, $_); -x $abs or MM->maybe_command($abs); } keys %cmd_map; last if $spell_cmd; } $spell_cmd = $ENV{SPELL_CMD} if $ENV{SPELL_CMD}; plan skip_all => "spell command are not available." unless $spell_cmd; add_stopwords(map { split /[\s\:\-]/ } ); set_spell_cmd($spell_cmd); $ENV{LANG} = 'C'; all_pod_files_spelling_ok('lib'); __DATA__ Sugama Keita Mojolicious mojolicious Plugins tusu WAF ini plugins ErrorDocument apache's app ep html init mojo parsable CGI HTML URL Syntax-Highlight-Engine-Simple-0.09/xt/perlcriticrc0000755000175000017540000000011311034161423021711 0ustar sugamacutout# no strict 'refs' [TestingAndDebugging::ProhibitNoStrict] allow = refs Syntax-Highlight-Engine-Simple-0.09/xt/pod.t0000755000175000017540000000021411034322755020261 0ustar sugamacutout#!perl -T use Test::More; eval "use Test::Pod 1.14"; plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; all_pod_files_ok(); Syntax-Highlight-Engine-Simple-0.09/xt/perlcritic.t0000755000175000017540000000056711605210327021645 0ustar sugamacutout#!perl use strict; use Test::More; eval { require Test::Perl::Critic; Test::Perl::Critic->import(-profile => "xt/perlcriticrc") }; if ($@) { plan skip_all => "Test::Perl::Critic is not installed."; } elsif (version->new($Perl::Critic::VERSION) lt "1.088") { plan skip_all => "Perl::Critic 1.088 required for the test."; } all_critic_ok("lib");