# This is a file sent to me by an early beta tester, Di Zhao.
# It defines some functions to be called by Lisp for higlighting
# text based on Perl regular expressions.

                 use Emacs::Lisp;
                 defun (\*zd_color_red,
                        "color",
                        interactive("sZD-Pattern: "),
                        sub {
                            my ($pat) = @_;
                            my $text = &buffer_string();
                            while($text =~ /$pat/mg)
			    {  $pos = pos($text);
                               &put_text_property(int($pos - length($&) + 1), int($pos + 1), \*face, \*zd_red_face);
			    } 
                          
                             });

                        defun (\*zd_color,
                        "color",
                       # interactive("r"),
                        sub {
                            my ($pat, $color) = @_;
                            my $text = &buffer_string();
                            &set_face_foreground(\*zd_red_face, $color);
                            while($text =~ /$pat/mg)
			    {  $pos = pos($text);
                               &put_text_property(int($pos - length($&) + 1), int($pos + 1), \*face, \*zd_red_face);
			    } 
                          
                             });

                        defun (\*zd_color_region,
                        "color the region from beg to end",
                       # interactive("r"),
                        sub {
                            my ($beg, $end, @patterns) = @_;
                            my $text = &buffer_substring_no_properties($beg, $end);
			    my ($opts, $pat, $pos, $i, $line_pat, $line, $line_pos);
			   my @tmp;
			   my (@zd_faces) = (\*zd_red_face, \*zd_yellow_face, \*zd_green_face, \*zd_blue_face);
			for($i = $#patterns; $i >=0 ; $i-=2)
			{	if ($patterns[$i] !~ "v")
				{	unshift @tmp, $patterns[$i];
					unshift @tmp, $patterns[$i - 1];
				}
			} 
			@patterns = @tmp;
###ZD: Added 09/02, erase the previous pattern color##
			    &put_text_property($beg, $end, \*face, \*default);
######################################################
			for($i = $#patterns; $i >=0 ; $i-=2)
			{   $opts = $patterns[$i];
			    $pat = $patterns[$i - 1];
			    $line_pat = "^(.*\$)";
			    $zd_face = $zd_faces[$i / 2 > $#zd_faces ? $#zd_faces : $i /2]; 	
			    if ($opts =~ /i/)
			    {	$pat = "(?i)$pat";
			    }
			    $pat = "()($pat)";
			    if ($opts =~ /e/)
			    {	#$pat = "(^.*?:.*?)($pat)";
				$line_pat = "^.*?:(.*\$)";
			    }
                            while($text =~ /$line_pat/mg)
			    {  $line_pos = pos($text) - length($1); 
			       $line = $1 . "\n";
			       while($line =~ /$pat/g)
			       {
			       	$pos = pos($line) + $line_pos;
                      		&put_text_property(int($beg + $pos - length($&) + length($1)), int($beg + $pos), \*face, $zd_face);
			        }
			    } 
			}
                          
                            });
 

                       defun (\*zd_perl_grep,
                        "a function provides perl-like grep",
                        interactive("r"),
                        sub {
                            my ($pat) = @_;
                            my $text = &buffer_string();
                            setq { $zd_perl_grep_pattern = $pat;};
                            &set_buffer(&get_buffer_create("*ZD-PERL-GREP*"));
                            &erase_buffer();
                            while($text =~ /.*?\n/sg)
			    {  $line = $&;
                               if ($line =~ /$pat/)
			       {   &insert($line);
		   	       }
			    }
                          
                            &other_window(1);
                            &switch_to_buffer("*ZD-PERL-GREP*");
                            });
 		
#ZD: Added 09/02, get the current emacs process id####	
         		defun (\*zd_get_emacs_id,
			 "a function to get the emacs process id",
			 interactive(""),
			 sub {
			     $$;
			     # &message("%d", $$);
			     });

			defun (\*zd_get_root_file,
			  "get the root file",
			  interactive(""),
			  sub {
				my ($name) =@_;
				($root_file) = ($name =~ /\@\@([^\@]*$)/);
				if ($root_file eq "")
				{	$root_file = $name;}
				return $root_file;	
		              });	

			defun (\*zd_return_header,
			  "return the header of .all format file",
			  interactive(""),
			  sub {
				my ($str) =@_;
				#Patched 12/07/98, first omit ZD,ZL marks, for Ying's format
				$str =~ s/^ZD\S*\s*//;
				$str =~ s/^ZL\S*\s*//;
				$str =~ s/^###--\S*\s*//;
				#if ($str =~ /^TYPE \d*\./)	
				#{	$str =~ s/^TYPE \d*\.\s*//;
				#	$str =~ s/^"//;
				#	$str =~ s/"$//;
				#}
				#if ($str =~ /(^\d+\).*?-\d*?:)/)
				#Patched:11/11/98, the basic idea is:
				#if current line contains a part that fits the .all header format, then
				#use it as header, or just return the whole line
				#This way, I needn't worry about the mark format in front of the line 
				if ($str =~ /(\d+\).*?-\d+?:)/)
				{	$header = $&;
					return $header;
				} 
				return $str;
		              });	

			defun (\*zd_perl_search_forward,
			  "return the header of .all format file",
			  interactive(""),
			  sub {
				my ($str, $pat, $new_flag) =@_;
				if ($str =~ /$pat/)
				{	return pos($str);}
				else {	return -1;}
			      });
			defun (\*zd_buffer_in_window,
			  "traverse all windows to see if buffer is in it",
			  sub {
				my ($buf_name) =@_;
				if ($str =~ /$pat/)
				{	return pos($str);}
				else {	return -1;}
			      });