% This file defines syntax highlighting for perl.
% The original author is Lars Marowsky-Bree <lmb@pointer.in-minden.de>

% Create and initialize the syntax tables.

$1 = "perl";

create_syntax_table ($1);
define_syntax ("#", "", '%', $1);
%define_syntax ("# =start #", "=cut", '%', $1);
define_syntax ("=head", "=cut", '%', $1);
define_syntax ("([{", ")]}", '(', $1);
define_syntax ('\'', '"', $1);
define_syntax ('"', '"', $1);
define_syntax ('\\', '\\', $1);
define_syntax ("$0-9a-zA-Z_", 'w', $1);        % words
define_syntax ("-+0-9a-fA-F.xXL", '0', $1);   % Numbers
define_syntax (",;.?:", ',', $1);
define_syntax ("%-+/&*=<>|!~^", '+', $1);
set_syntax_flags ($1, 0x80|0x10);

#ifdef HAS_DFA_SYNTAX
enable_highlight_cache("perl.dfa", $1);
define_highlight_rule("#.*$", "comment", $1);
define_highlight_rule("([\\$%&@\\*]|\\$#)[A-Za-z_0-9]+", "normal", $1);
define_highlight_rule(strcat("\\$([_\\./,\"\\\\#\\*\\?\\]\\[;!@:\\$<>\\(\\)",
			     "%=\\-~\\^\\|&`'\\+]|\\^[A-Z])"), "normal", $1);
define_highlight_rule("[A-Za-z_][A-Za-z_0-9]*", "Knormal", $1);
define_highlight_rule("[0-9]+(\\.[0-9]+)?([Ee][\\+\\-]?[0-9]*)?", "number",
		      $1);
define_highlight_rule("0[xX][0-9A-Fa-f]*", "number", $1);
define_highlight_rule("[\\(\\[\\{\\<\\>\\}\\]\\),;\\.\\?:]", "delimiter", $1);
define_highlight_rule("[%\\-\\+/&\\*=<>\\|!~\\^]", "operator", $1);
define_highlight_rule("-[A-Za-z]", "keyword0", $1);
define_highlight_rule("'[^']*'", "string", $1);
define_highlight_rule("'[^']*$", "string", $1);
define_highlight_rule("\"([^\"\\\\]|\\\\.)*\"", "string", $1);
define_highlight_rule("\"([^\"\\\\]|\\\\.)*\\\\?$", "string", $1);
define_highlight_rule("m?/([^/\\\\]|\\\\.)*/[gio]*", "string", $1);
define_highlight_rule("m/([^/\\\\]|\\\\.)*\\\\?$", "string", $1);
define_highlight_rule("s/([^/\\\\]|\\\\.)*(/([^/\\\\]|\\\\.)*)?/[geio]*",
		      "string", $1);
define_highlight_rule("s/([^/\\\\]|\\\\.)*(/([^/\\\\]|\\\\.)*)?\\\\?$",
		      "string", $1);
define_highlight_rule("(tr|y)/([^/\\\\]|\\\\.)*(/([^/\\\\]|\\\\.)*)?/[cds]*",
		      "string", $1);
define_highlight_rule("(tr|y)/([^/\\\\]|\\\\.)*(/([^/\\\\]|\\\\.)*)?\\\\?$",
		      "string", $1);
define_highlight_rule(".", "normal", $1);
build_highlight_table ($1);
#endif

() = define_keywords ($1,
		      strcat ("endhostentendserventgethostentgetservent",
			      "getsockoptsethostentsetserventsetsockopt",
			      "socketpair"),
		      10);
() = define_keywords ($1,
		      strcat ("endprotoentgetpeernamegetprioritygetprotoent",
			      "getsocknamesetprioritysetprotoent"),
		      11);
() = define_keywords ($1, "getnetbyaddrgetnetbyname", 12);
() = define_keywords ($1,
		      strcat ("gethostbyaddrgethostbynamegetservbyname",
			      "getservbyport"),
		      13);
() = define_keywords ($1, "getprotobyname", 14);
() = define_keywords ($1, "getprotobynumber", 16);
() = define_keywords ($1, "-Xdoeqiflcm/mynoq/s/ucy/", 2);
() = define_keywords ($1,
		      strcat ("abschrcosdieeofexpforhexintlogmapoctordpoppos",
			      "qq/qw/qx/refsinsubtietr/usevec"),
		      3);
() = define_keywords ($1,
		      strcat ("bindchopdumpeachelseevalexecexitforkgetcglobgoto",
			      "grepjoinkeyskilllastlinknextopenpackpipepush",
			      "randreadrecvredoseeksendsortsqrtstattelltime",
			      "waitwarn"),
		      4);
() = define_keywords ($1,
		      strcat ("alarmatan2blesschdirchmodchompchownclosecrypt",
			      "elsiffcntlflockindexioctllocallstatmkdirprint",
			      "resetrmdirsemopshiftsleepsplitsrandstudytimes",
			      "umaskundefuntieuntilutimewhilewrite"),
		      5);
() = define_keywords ($1,
		      strcat ("acceptcallerchrootdeleteexistsfilenogmtime",
			      "importlengthlistenmsgctlmsggetmsgrcvmsgsnd",
			      "printfrenamereturnrindexscalarselectsemctl",
			      "semgetshmctlshmgetsocketsplicesubstrsystem",
			      "unlessunlinkunpackvalues"),
		      6);
() = define_keywords ($1,
		      strcat ("binmodeconnectdbmopendefinedforeachgetpgrpgetppid",
			      "lcfirstopendirpackagereaddirrequirereverseseekdir",
			      "setpgrpshmreadsprintfsymlinksyscallsysread",
			      "telldirucfirstunshiftwaitpid"),
		      7);
() = define_keywords ($1,
		      strcat ("closedirdbmcloseendgrentendpwentformline",
			      "getgrentgetgrgidgetgrnamgetlogingetpwent",
			      "getpwnamgetpwuidreadlinksetgrentsetpwent",
			      "shmwriteshutdownsyswritetruncate"),
		      8);
() = define_keywords ($1,
		      strcat ("endnetentgetnetentlocaltimequotemeta",
			      "rewinddirsetnetentwantarray"),
		      9);

% Stolen from cmode.sl
static define perl_indent_to (n)
{
   bol_skip_white ();
   if (what_column != n)
     {
	bol_trim ();
	n--;
	whitespace (n);
     }
}

public define perl_indent_line()
{
   variable col; % Column
   variable c, oc;   % Character, original character
   variable cont_line = 1; %
   variable start_pos;

   start_pos = create_user_mark ();
   
   EXIT_BLOCK
     {
	goto_user_mark (start_pos);
	bskip_white ();
	if (bolp())
	  % (start of line)
	  bol_skip_white();
	else
	  goto_user_mark (start_pos);
     }

   % (original position : start of line)
   bol_skip_white();
   % (original position : start of line : copy)
   push_spot();

   c = what_char ();

   % No empty lines, to make rest of processing easier.
   if (bolp())
     if (eolp())
       insert(" ");

   % Default to indent on first column
   col = 1;

   % If inside a () indent to level of opening '(' + 1
   % Ex:
   %  foo (bar
   %       baz(fum
   %           foz))
   if (find_matching_delimiter(')') == 1)
     {
	col = what_column()+1;
	cont_line = 0;
     }

   % (original position : start of line)
   pop_spot();
   % (original position : start of line : copy)
   push_spot();
   bol();
   % If strings continue through lines, indent them to the
   % first column.
   % Ex:
   %    "foo
   % bar
   % baz"
   %    fum();
   if (parse_to_point() == -1)
     {
	perl_indent_to(1);
	return;
     }

   % (original position : start of line)
   pop_spot();
   % (original position : start of line : copy)
   push_spot();

   if (find_matching_delimiter('}') == 1)
     {
	% (original position : start of line : start of last '{' line)
	bol_skip_white();
	% Indent to last '{'
	col = what_column();

	if (c == '}')
	  cont_line = 0;
	else
	  % Indent to last '{' + C_INDENT
	  col += C_INDENT;
     }
   
   % (original position : start of line)
   pop_spot();

   % (original position)
   goto_user_mark (start_pos);

   if (cont_line != 0)
     {
	oc = c;

	% Find previous non-comment line
	do
	  {
	     % Start of file, pretty hard to find context ;-)

	     !if (up_1 ())
	       {
		  bol();
		  break;
	       }

	     bol_skip_white();
	     !if (eolp())
	       {
		  go_right (1);
	       }
	  }
	while (parse_to_point() == -2);
	%trim();
	eol();

	% Find last non-comment character
	variable ptp;

	while (ptp = parse_to_point (),
	       (ptp == -2)
	       or ((ptp == 0) and (what_char == '#')))
	  !if (left (1))
	    % Oops?
	    break;

	bskip_chars (" \t");

	c = ';';
	!if (bolp())
	  {
	     go_left_1 ();

	     if (parse_to_point() != -2)
	       c = what_char ();
	  }

	bol_skip_white();

	if ((c != ';') and (c != '{')
	    and (c != '}') and (c != '(')
	    and (oc != '{'))
	  col += C_CONTINUED_OFFSET;
	
	goto_user_mark (start_pos);
     }

   perl_indent_to(col);
}

define perl_mode ()
{
   variable kmap = "perl";
   set_mode (kmap, 4);
   use_syntax_table (kmap);
   %set_buffer_hook("indent_hook", &perl_indent_line);
   mode_set_mode_info("perl", "fold_info", "#{{{\r#}}}\r\r");
   run_mode_hooks("perl_mode_hook");
}
