Darstellung der Perl Syntax als HTML

Modul

package PerlWords;

use strict;

my $codefont            = '<span style="font-family: Courier New; color: black; letter-spacing: 1pt>';
my $k1col               = '<span style="color: black; font-weight: bold">';
my $bracketcol          = '<span style="color: blue">';
my $comcol              = '<span style="color: green">';
my $quotecol            = '<span style="color: gray">';
my $regcol              = '<span style="color: red">';
my $varcol              = '<span style="color: navy">';
my $svarcol             = '<span style="color: violet">';
my $hvarcol             = '<span style="color: maroon">';
my $numcol              = '<span style="color: olive">';

my $codefontend         = '</span>';
my $k1colend            = '</span>';
my $bracketcolend       = '</span>';
my $comcolend           = '</span>';
my $quotecolend         = '</span>';
my $regcolend           = '</span>';
my $varcolend           = '</span>';
my $svarcolend          = '</span>';
my $hvarcolend          = '</span>';
my $numcolend           = '</span>';

my @keywords = (
   "\%ENV", "\$ENV", "bless", "close", "closedir", "die", "shift", "eval", "exit", "grep", "local", "map", "my", "open",
   "opendir", "package", "print", "return", "splice", "split", "sub", "sysopen", "use", "require", "warn", "do", "each",
   "else", "elsif", "foreach", "for", "if", "unless", "until", "values", "while", "AUTOLOAD", "BEGIN", "CORE", "DESTROY",
   "END", "STDERR", "STDIN", "STDOUT", "abs", "accept", "alarm", "and",   "atan2", "bind", "binmode", "caller", "chdir",
   "chmod", "chomp", "chop", "chown", "chr", "chroot", "cmp", "connect", "continue", "cos", "crypt", "dbmclose", "dbmopen",
   "default", "defined", "delete", "dump", "endgrent", "endhostent", "endnetent", "endprotoent", "endpwent", "endservent",
   "eof", "eq", "exec", "exists", "exp", "fcntl", "fileno", "flock", "fork", "format", "formline", "getc", "getgrent",
   "getgrgid", "getgrnam", "gethostbyaddr", "gethostbyname", "gethostent", "getlogin", "getnetbyaddr", "getnetbyname",
   "getnetent", "getpeername", "getpgrp", "getppid", "getpriority", "getprotobyname", "getprotobynumber", "getprotoent",
   "getpwent", "getpwnam", "getpwuid", "getservbyname", "getservbyport", "getservent", "getsockname", "getsockopt", "glob",
   "gmtime", "goto", "ge", "hex", "import", "index", "int", "ioctl", "join", "keys", "kill", "last", "lc", "lcfirst", "length",
   "le", "link", "listen", "localtime", "local", "log", "lstat", "mkdir", "msgctl", "msgget", "msgrcv", "msgsnd", "new", "next",
   "ne", "no", "no", "oct", "or", "ord", "pack", "pipe", "pop", "pos", "q", "qq", "quotemeta", "qw", "qx", "read", "readdir",
   "readlink", "readpipe", "recv", "redo", "ref", "rename", "reset", "reverse", "rewinddir", "rindex", "rmdir", "scalar", "seek",
   "seekdir", "select", "semctl", "semget", "semop", "send", "setgrent", "sethostent", "setnetent", "setpgrp", "setpriority",
   "setprotoent", "setpwent", "setservent", "setsockopt", "shift", "shmctl", "shmget", "shmread", "shmwrite", "shutdown", "sin",
   "sleep", "socket", "socketpair", "sort", "split", "sprintf", "printf", "sqrt", "srand", "rand", "stat", "shift", "study",
   "substr", "switch", "symlink", "syscall", "sysread", "system", "syswrite", "tell", "telldir", "time", "times", "tr",   
   "truncate", "uc", "ucfirst", "umask", "undef", "unlink", "unpack", "unshift", "untie", "utime", "vec", "wait", "waitpid",
   "wantarray", "write", "xor",
);

sub new
{
   my $pkg = shift;
   my $obj = {};

   bless $obj, $pkg;

   $obj->{_ISREGEXP} = 0;

   return $obj;
}

sub DoHighLight
{
   my ($self, $code) = @_;

   $code =~ s/<br>/\n/gsm;
   $code =~ s/</<;/g;
   $code =~ s/>/>;/g;
   $code =~ s/\r//g;

   my @lines = split /\n/, $code;

   for (@lines)
   {
      $self->{_ISREGEXP} = 0;

      s/(\/.*?\/.*?)(;|,|$)/&_excom($self, $1, $2)/esmg;

      s/((?:".*?")|(?:'.*?'))/$quotecol$1$quotecolend/gsm unless $self->{_ISREGEXP}; # higlight strings
      s/([\%\@\$]\w+?)\b/$varcol$1$varcolend/smg unless $self->{_ISREGEXP}; # highlight variables
      s/([\%\@\$](?:\W|[0-9_]){1})/$svarcol$1$svarcolend/smg; # highlight build-in variables
      s/(\W)(\d+|-\d+)/$1$numcol$2$numcolend/smg unless $self->{_ISREGEXP}; # hightlight numbers
   }

   $code = join "\n", @lines;
   foreach (@keywords)
   {
      $code =~ s/(^$_|\s*$_|\($_|\}$_\{)(\s|[;\(<])/$k1col$1$k1colend$2/msg; # hightlight perl keywords
   }

   $code =~ s/({|})/$bracketcol$1$bracketcolend/msg; # highlight brackets , { }
   $code =~ s/([^\$]|^.?)(#.*?$)/$1.$comcol._x($2).$comcolend/smge unless $self->{_ISREGEXP}; # highlight comments

   return $code;
}

sub _x # Remove allready highlighted stuff
{
   my $y = shift;

   $y =~ s!<span style=["'](.+?)['"]>!!g;
   $y =~ s!</span>!!g;
   $y = $y;
}

sub _excom # Highlight RegExp's
{
   my ($self, $a, $b) = @_;
   my $res;

   if("$`$&" =~ /((?:".*?")|(?:'.*?'))/)
   {
      my $t = $a;
      $self->{_ISREGEXP} = 0;
      /()/;
      $t =~ s/(=~.*?)(\/.*?)(;|,|$)/$1$regcol$2$regcolend$3/sm;

      if($1) { $res = $t; }
      else { $res = "$a$b"; }
   }
   elsif(($` =~ /\:|\=+?$/) or ($` =~ /#/))
   {
      $res = "$a$b";
      $self->{_ISREGEXP} = 0;
   }
   else
   {
      $res = "$regcol$a$regcolend$b";
      $self->{_ISREGEXP} = 1;
   }

   return $res;
}

1;

Ergänzungen, Kommentare

SaschaKieferAkaEsskar - 11 Aug 2003: Um die Sache übersichtlicher zu machen, kann man natürlich die keywords auch in eine externe datei auslagern!