Beefy Boxes and Bandwidth Generously Provided by pair Networks
Just another Perl shrine
 
PerlMonks  

pEdit

by Elijah (Hermit)
on Mar 05, 2004 at 18:45 UTC ( [id://334317]=sourcecode: print w/replies, xml ) Need Help??
Category: GUI Programming
Author/Contact Info ZiaTioN/Elijah
Description: pEdit is a full blown programming environment/text editor. It has many basic functions users have come to expect from a text editor. This is written exclusively in Perl for Perl programming. Some highlights include keyword coloring and custom bindings. pEdit also contains a front end syntax checker and script running capabilites from within the program itself.
#!/usr/bin/perl

################################
################################
##     Written by ZiaTioN     ##
##       Title = pEdit        ##
## version 0.7 (beta release) ##
################################
################################

# The following comments are for perl2exe compilation!

#perl2exe_include Tk;
#perl2exe_include Tk::Text;
#perl2exe_include Tk::Menu;
#perl2exe_include Tk::Photo;
#perl2exe_include Tk::Scrollbar;
#perl2exe_include Tk::DialogBox;
#perl2exe_include Tk::Radiobutton;
#perl2exe_include strict;
#perl2exe_include File::Compare;
#perl2exe_include Win32::Printer;

#perl2exe_bundle "pedit.gif"

use Tk;
use Tk::Text;
use Tk::Menu;
use Tk::Scrollbar;
use Tk::DialogBox;
use Tk::Radiobutton;
use strict;
use File::Compare;
use Win32::Printer;

our($filename, $info, $line_number, $search_string,
    $count, $num, $last, $last_search, $trigger, $total_lines);

my $main_title = "pEdit v(0.7) - (beta release)";
my $text_coloring = 1;
our $Comment = '#';

our %Highlights = (
   Red_Keyword   => [qw(red bold)],
   Blue_Keyword  => [qw(blue bold)],
   Green_Keyword => [qw(green bold)],
   Brown_Keyword => [qw(brown bold)],
   Comment       => [qw(grey italic)],
   Found         => [qw(big_italic bold)],
);

our @Red_Keywords = qw(print sprintf);

our @Blue_Keywords = qw(if elsif else my our use sub);

our @Green_Keywords = qw(while foreach loop);

our @Brown_Keywords = qw(split glob substr length open close chomp cho
+p next unless push pop);

#our $All_Keys = "print|sprintf|if|elsif|else|my|our|use|sub|while|for
+each|loop|split|
#                 glob|substr|length|open|close|chomp|chop|next|unless
+|push|pop";

my $mw = MainWindow->new();
$mw->minsize(qw(350 200));
$mw->title($main_title);

# Create necessary widgets
my $t = $mw->Scrolled("Text", -scrollbars => 'e', -font => ['Courier N
+ew', '10'])->pack(-side => 'top', 
                     -fill => 'both', -expand => 1);
my $ts = $mw->Frame->pack(-side => 'top', -fill => 'x');
my $status = $mw->Scrolled("Text", -scrollbars => 'e', -height => '8',
+ -font => '12')->
                           pack(-side => 'top',-fill => 'x', -expand =
+> 0);

#####################################################
#Start of menubar creation
my $menubar = $mw->Menu;

my $file_menu = $menubar->cascade(-label => "~File", -tearoff => 0);
$file_menu->command(-label => '~Open',    
            -command => \&load);
$file_menu->command(-label => '~New/Clear',    
            -command => \&clear_new);
$file_menu->command(-label => '~Save',    
            -command => \&save_file);
$file_menu->command(-label => '~Save As',    
            -command => \&save_as);
$file_menu->command(-label => '~Print',    
            -command => \&print);
$file_menu->command(-label => '~Exit',    
            -command => \&close);

my $edit_menu = $menubar->cascade(-label => "~Edit", -tearoff => 0);
$edit_menu->command(-label => '~Find',    
            -command => sub {find($t, '1.0', 'end')});
$edit_menu->command(-label => '~Go To',    
            -command => \&go_to);
$edit_menu->command(-label => '~Text Formatting',    
            -command => \&color_text);
$edit_menu->command(-label => '~Total Lines',    
            -command => \&total_lines);
$edit_menu->command(-label => '~Refresh',    
            -command => \&refresh);

my $functions_menu = $menubar->cascade(-label => "~Functions", -tearof
+f => 0);
$functions_menu->command(-label => '~Test Syntax',    
            -command => \&interpret);
$functions_menu->command(-label => '~Run Script',    
            -command => \&run);

my $help_menu = $menubar->cascade(-label => "~Help", -tearoff => 0);
$help_menu->command(-label => '~About',    
            -command => \&about);
$help_menu->command(-label => '~Release Notes',    
            -command => \&release);

$mw->configure(-menu => $menubar);
#End of menubar creation
#######################################################

my $temp_dir = $ENV{TEMP} || $ENV{TMP} || ($^O eq "MSWin32" ? $ENV{WIN
+DIR} : '/tmp');

$mw->Label(-textvariable => \$info, -relief => 'ridge')->
   pack(-side => 'bottom', -fill => 'x');

if (-e $temp_dir."\\pedit.gif") {
   $ts->Photo('middle', -file=>$temp_dir."\\pedit.gif");
   $ts->Label(-image=>'middle')->pack(-side=>'bottom');
}

$t->tagConfigure("blue",   -foreground => "blue");
$t->tagConfigure("red",    -foreground => "red");
$t->tagConfigure("orange", -foreground => "orange");
$t->tagConfigure("brown",  -foreground => "brown");
$t->tagConfigure("grey",   -foreground => "grey");
$t->tagConfigure("green",  -foreground => "forest green");


$t->tagConfigure('bold',       -font => ['Courier New', 10, 'bold']);
$t->tagConfigure('italic',     -font => ['Courier New', 10, 'italic'])
+;
$t->tagConfigure('big_italic', -font => ['Times New Roman', 20, 'itali
+c']);

######################################################################
+#######
# Some of my own bindings!

$mw->bind('Tk::Text', '<Control-s>', [\&save_file]);
$mw->bind('Tk::Text', '<Control-a>', sub {$t->tagAdd('sel','1.0','end'
+)});
$mw->bind('Tk::Text', '<Control-o>', sub {load()});
$mw->bind('Tk::Text', '<Control-n>', [\&clear_new]);
$mw->bind('Tk::Text', '<Control-p>', [\&print]);
$mw->bind('<MouseWheel>' => 
[ sub { $_[0]->yview('scroll', -($_[1] / 120) * 4, 'units') }, Ev('D')
+ ]); 

# Automatically prepends $t to called sub's args
$t->bind('<KeyRelease>', [\&highlight_range, 'insert linestart', 'inse
+rt lineend']);

# Paste events may include more than one line to be formatted,
# so we rehighlight the entire text.
$t->bind('<<Paste>>', [\&highlight_range, '1.0', 'end']);
######################################################################
+#######

#$t->focus();

if ($ARGV[0]) {
   load($ARGV[0]);
}

MainLoop();

######################################################################
+###
# Remove all formatting so that updates will unhighlight things proper
+ly.
sub unhighlight_range {
  my $t     = shift;
  my $start = shift;
  my $end   = shift;

  foreach my $style (keys %Highlights) {
    foreach my $tag (@{$Highlights{$style}}) {
      $t->tagRemove($tag, $start, $end);
    }
  }
}

##################################################################
# This is the meat and potatoes of the text formatting (coloring).
sub highlight_range {
   my $t     = shift;
   my $start = shift;
   my $end   = shift;

   if ($text_coloring == 1) {
      unhighlight_range($t, $start, $end);

      my $word_len = length $Comment;
      my $next = $start;
      while (my $comm = $t->search(-regexp => $Comment, $next, $end)) 
+{
         $next = "$comm + $word_len chars";

         if($comm) {
            mark_word($t, $comm, "$comm lineend", 'Comment');
         }
      }
 
      foreach my $word (@Red_Keywords) {
         my $word_len = length $word;
         my $next = $start;
         while (my $from = $t->search(-regexp, "\\b\Q$word\E\\b", $nex
+t, $end)) {
            $next = "$from + $word_len chars";

            # Search for a comment character on the same line
            my $comment = $t->search(
               -regexp => $Comment,
               "$from linestart" => "$from lineend"
            );     

            # If comment found and is before keyword, skip keyword for
+matting
            unless($comment and $t->compare($comment, '<', $from)) {
               mark_word($t, $from, $next, 'Red_Keyword');
            }
         }
      } 

      foreach my $word (@Blue_Keywords) {
         my $word_len = length $word;
         my $next = $start;
         while (my $from = $t->search(-regexp, "\\b\Q$word\E\\b", $nex
+t, $end)) {
            $next = "$from + $word_len chars";

            # Search for a comment character on the same line
            my $comment = $t->search(
              -regexp => $Comment,
              "$from linestart" => "$from lineend"
            );

            # If comment found and is before keyword, skip formatting
            unless($comment and $t->compare($comment, '<', $from)) {
              mark_word($t, $from, $next, 'Blue_Keyword');
            }
         }
      }

      foreach my $word (@Green_Keywords) {
         my $word_len = length $word;
         my $next = $start;
         while (my $from = $t->search(-regexp, "\\b\Q$word\E\\b", $nex
+t, $end)) {
            $next = "$from + $word_len chars";

            # Search for a comment character on the same line
            my $comment = $t->search(
              -regexp => $Comment,
              "$from linestart" => "$from lineend"
            );

            # If comment found and is before keyword, skip formatting
            unless($comment and $t->compare($comment, '<', $from)) {
              mark_word($t, $from, $next, 'Green_Keyword');
            }
         }
      }

      foreach my $word (@Brown_Keywords) {
         my $word_len = length $word;
         my $next = $start;
         while (my $from = $t->search(-regexp, "\\b\Q$word\E\\b", $nex
+t, $end)) {
            $next = "$from + $word_len chars";
 
            # Search for a comment character on the same line
            my $comment = $t->search(
              -regexp => $Comment,
              "$from linestart" => "$from lineend"
            );

            # If comment found and is before keyword, skip formatting
            unless($comment and $t->compare($comment, '<', $from)) {
              mark_word($t, $from, $next, 'Brown_Keyword');
            }
         }
      }
   }
}

######################################################################
+######################
# mark_word does the actual tagging of text once "highlight_range" is 
+done parsing the file.
sub mark_word {
   my $text  = shift;
   my $start = shift;
   my $end   = shift;
   my $style = shift;

   return unless exists $Highlights{$style};

   foreach my $tag (@{$Highlights{$style}}) {
     $text->tagAdd($tag, $start, $end);
   }
}

######################################
# open does just that, opens the file.
sub load {
   my $browse = shift;

   if (!$browse) {$browse = $t->getOpenFile(-title => "Browse For A Fi
+le!");}
   if ($browse) {
      $t->delete("1.0", "end");
      $status->delete("1.0", "end");
      if (!open(TARGET, "$browse")) {
         $info = "Error!";
         $status->insert("end", "ERROR: Could not open $browse\n"); 
         return; 
      }
      $filename = $browse;

      $info = "Loading file '$filename'...";
      $total_lines = 0;
      while (<TARGET>) {
         $t->insert("end", $_);
         $total_lines++;
      }
      close(TARGET);
      $info = "File $filename loaded";
      $mw->title("$main_title ".$filename);

      highlight_range($t, '1.0', 'end');

   }else{
      return;
   }
}

######################################################################
+#############
# refresh simply refreshes the text formatting, total lines and the st
+atus section.
sub refresh {
   $status->delete("1.0", "end");
   chomp(my $data = $t->get("1.0", "end"));
   if (!$filename && $data ne /\s+/) {
      my @data = split(/\n/, $data);
      $total_lines = 1;
      foreach my $line (@data) {
         $total_lines++;
      }
   }

   if ($text_coloring == 1) {
      highlight_range($t, '1.0', 'end');
   }elsif ($text_coloring == 0) {
      unhighlight_range($t, '1.0', 'end');
   }
}

# clear_new initiates a new session.
sub clear_new {
   $t->delete("1.0", "end");
   $status->delete("1.0", "end");
   $filename = "";
   $total_lines = 0;
   $mw->title("$main_title ".$filename);
}

#########################################
# print does what it says it does, print!
sub print {
   $status->delete("1.0", "end");
   my $dc = new Win32::Printer(
                              papersize       => 1,
                              dialog          => NOSELECTION,
                              description     => 'subject',
                              unit            => 'mm'
                              );

   #my $font = $dc->Font('Arial Bold', 24);
   #$dc->Font($font);
   #$dc->Color(0, 0, 255);
   $status->insert("end", "Printing Document:\n".$filename);
   chomp(my $page = $t->get("1.0", "end"));
   my @page = split(/\n/, $page);
   my $y = 15;
   foreach (@page) {
      $dc->Write($_, 10, $y, 800, 100, [0x00000010]);
      $y+=3;
   }
   $dc->Close();
   $status->delete("1.0", "end");
   $info = "Print job complete!";
}

######################################################################
# save_as prompts user for directory and filename to save the file as.
sub save_as {
   my $save = $t->getSaveFile(-title => "Saving File!");
   $info = "Saving $save";
   chomp(my $data = $t->get("1.0", "end"));

   if ($save) {
      open (FH, ">$save") || $status->insert("end", "Cannot open \"$sa
+ve\"\n");
      print FH $data;
      close(FH);
      $info = "Saved.";
      $filename = $save;
      $mw->title("$main_title ".$filename);
      refresh();
   }else{
      $status->delete("1.0", "end");
      $status->insert("end", "File save has been cancelled!");
   }
}

###############################################################
# save_file saves the file using the filename in the Entry box.
sub save_file {
   if ($filename) {
      $info = "Saving $filename";
      chomp(my $data = $t->get("1.0", "end"));

      open (FH, ">$filename") || $status->insert("end", "Cannot open \
+"$filename\"\n");
      print FH $data;
      close(FH);

      $info = "Saved.";
   }else{
      $status->delete("1.0", "end");
      $status->insert("end", "Error while saving!\nYou must choose \"S
+ave As\" for new file.\n");
      save_as();
   }
}

######################################################################
+#########
# save_and_exit saves the current file to the current filename and the
+n exists.
sub save_and_exit {
   if ($filename) {
      chomp(my $data = $t->get("1.0", "end"));

      open (FH, ">$filename") || $status->insert("end", "Cannot open \
+"$filename\"\n");
      print FH $data;
      close(FH);

      exit 0;
   }else{
      $status->delete("1.0", "end");
      $status->insert("end", "Error while saving!\nYou must choose \"S
+ave As\" for new file.\n");
      save_as();
   }
}

######################################################################
+###########################
# total_lines keeps track of the amount of lines in a file and reports
+ this amount when prompted.
sub total_lines {
   chomp(my $data = $t->get("1.0", "end"));
   if (!$filename && $data ne /\s+/) {
      my @data = split(/\n/, $data);
      $total_lines = 0;
      foreach my $line (@data) {
         $total_lines++;
      }
   }

   if (!$total_lines) {
      $total_lines = 0;
   }#else{
    #  $total_lines--;
   #}
   
   my $tl = $mw->DialogBox(-title => "Number Of Lines", -buttons => ["
+Close"]);
   $tl->add("Entry", -text => \$total_lines)->pack();
   $tl->resizable('no','no');
   $tl->Show();
}

######################################################################
+###################
# color_text is a configurable setting window which will allow the use
+r to turn on or off
# the text formatting.
sub color_text {
   chomp(my $data = $t->get("1.0", "end"));

   if ($data) {
      my $ct = $mw->DialogBox(-title => "Color Code Text?", -buttons =
+> ["Turn On", "Turn Off"]);
      $ct->Label(-text => "Choose your preference for formatted text")
+->pack();
      $ct->resizable('no','no');
      my $response = $ct->Show();

      if ($response eq "Turn On") {
         $text_coloring = 1;
         refresh();
      }else{
         $text_coloring = 0;
         refresh();
      }
   }else{
      $status->delete("1.0", "end");
      $status->insert("end", "No text to format!\n");
   }
}

######################################################################
+####
# This sub program will scroll the file looking for the user input str
+ing.
sub find {
   my $t     = shift;
   my $start = shift;
   my $end   = shift;

   chomp(my $data = $t->get("1.0", "end"));
   
   if ($data ne /\s+/) {
      my $fw = $mw->DialogBox(-title => "Search", -buttons => ["Search
+", "Quit"], -popover => $status,
                              -command => sub {&search if ($search_str
+ing ne /\s/ && $_[0] eq "Search")});
      $fw->add("Entry", -text => \$search_string)->pack();
      $fw->resizable('no','no');
      $fw->Show();

      sub search {;
         my $next = "1.0";
         chomp(my $string = $search_string);
         $status->delete("1.0", "end");
         $status->insert("end", "Searching for \"$string\"\n----------
+-------------------");

         my $string_len = length $string;
         my $next = $start;
         while (my $found = $t->search(-regexp => $string, $next, $end
+)) {
            $next = "$found + $string_len chars";

            if($found) {
               my @line = split(/\./, $found);
               refresh();
               mark_word($t, $found, $next, 'Found');
               &go_to($line[0]);      
               my $fw = $mw->DialogBox(-title => "Find Next", -buttons
+ => ["Next", "Quit"], -popover => $status,
                                       -command => sub {last if ($_[0]
+ eq "Quit")});
               $fw->resizable('no', 'no');
               $fw->Show();
            }
         }
         refresh();
         $status->delete("1.0", "end");
         $status->insert("end", "Finished searching the document!\n");
      }
   }else{
      $status->delete("1.0", "end");
      $status->insert("end", "Error! You cannot search a blank file!!\
+n");
   }      
}

######################################################################
+#
# runs is what calls the perl interpretor and runs the script provided
+.
sub run {
   $info = "Executing script!";
   if (!$filename) {
      chomp(my $data = $t->get("1.0", "end"));
      if ($data =~ /\w+/) {
         open (IN, ">syn_check") || $t->insert("end", "Cannot open \"s
+yn_check\"\n");
         print IN $data;
         close(IN);
      }else{
         $status->delete("1.0", "end");
         $status->insert("end", "Error! No script was provided to run.
+\n");
      }
   }

   if ($filename) {
      my($fork);
      system qq[ start cmd /k perl "$filename" ];
      #system("perl -e\"system 'start cmd';\" /k perl \"$filename\"");
   }else{
      my($fork);
      system qq[ start cmd /k perl "syn_check" ];
   }
   $status->delete("1.0", "end");
   $status->insert("end", "If your script is a command line script ");
   $status->insert("end", "it will appear in the open command prompt.\
+n");
   $status->insert("end", "If it is a GUI interface then you will see 
+it ");
   $status->insert("end", "if you did everything right :-)\n");
}

################################################################
# interpret runs the script with new changes through the Perl
# intrepetor to check the syntax so user will know if there code
# is correct.
sub interpret {
   $info = "Checking script syntax.";
   chomp(my $data = $t->get("1.0", "end"));

   if ($data =~ /\w+/) {
      open (IN, ">syn_check") || $t->insert("end", "Cannot open \"syn_
+check\"\n");
      print IN $data;
      close(IN);
   }else{
      $status->delete("1.0", "end");
      $status->insert("end", "No source code to interpret was found!\n
+");
      $info = "Error while checking syntax!";
      next;
   }

   my $test = `perl -c syn_check 2>&1`;
   $info = "Syntax Tested\!";
   $status->delete("1.0", "end");
   if ($test) {
      if ($test =~ /syn_check syntax OK/i) {
         $status->insert("end", "Syntax passed!\n");
      }else{
         $status->insert("end", $test);
      }
   }else{
      $status->delete("1.0", "end");
      $status->insert("end", "There was an error while receiving respo
+nse from interpretor!\n");
   }
}

######################################################################
+#
# go_to opens a new window prompting user for line number to scroll to
+.
sub go_to {
   my $count = shift;
   chomp(my $data = $t->get("1.0", "end"));
   if (!$filename && $data ne /\s+/) {
      my @data = split(/\n/, $data);
      $total_lines = 1;
      foreach my $line (@data) {
         $total_lines++;
      }
   }

   if ($count) {
      chomp($line_number = $count);
      scroll_line();
   }

   if ($data ne /\s+/ && !$count) {
      my $sw = $mw->DialogBox(-title => "Go To Line", -buttons => ["Go
+"], -popover => $status);
      $sw->add("Entry", -text => \$line_number)->pack();
      $sw->resizable('no','no');
      my $response = $sw->Show();
      if ($line_number != 0 && $response eq "Go") {
         &scroll_line;
      }
   }elsif ($data eq /\s+/){
      $status->delete("1.0", "end");
      $status->insert("end", "Error! You cannot scroll a blank file!\n
+");
   }

   sub scroll_line {
      $line_number--;
      $t->yviewMoveto($line_number/$total_lines);
      $line_number++;
      
   }
}

######################################################################
+####
# release simply pops up a windows displaying the release notes docume
+nted
# in the README.txt file
sub release {
   my $rw = MainWindow->new();
   $rw->minsize(qw(350 200));
   $rw->title("Release Notes!"); 

   my $rt = $rw->Scrolled("Text", -scrollbars => 'e', -font => ['Couri
+er New', '10'])->pack(-side => 'top', 
                     -fill => 'both', -expand => 1);

   if (!open(RELEASE, "README.txt")) {
      $info = "Error!";
      $status->insert("end", "ERROR: Could not open README.txt\n"); 
      return; 
   }

   $info = "Opening release notes...";
   while (<RELEASE>) {
      $rt->insert("end", $_);
   }
   close(RELEASE);
   $info = "Release Notes being viewed!";
}

######################################################################
+###################
# close is triggered by the "Exit" button and performs a check to see 
+if any changes have
# been made before closing. If it detects an y changes it will prompt 
+to save changes.
sub close {
   my $empty = 0;

   chomp(my $data = $t->get("1.0", "end"));

   open (TEMP, ">compare") || $t->insert("end", "Cannot open \"compare
+\"\n");
   print TEMP $data;
   close(TEMP);

   if ($filename ne /\s/) {
      my $compare = compare($filename, "compare");
      if ($compare == 0) {
         exit 0;
      }elsif ($compare == -1) {
         $status->insert("end", "There was an error while comparing!\n
+");
      }else{
         my $sw = MainWindow->new(-title=>"Content Has Changed");
         my $frame = $sw->Frame->pack(-side => 'top', -fill => 'x');
         $frame->Label(-text => "Would you like to save before exiting
+?")->
                       pack(-side => 'left', -anchor => 'w');
         $frame->Button(-text => "No", -background => 'navy blue', -fo
+reground => 'white', -command => sub {exit 0;})->
                        pack(-side => 'right'); 
         $frame->Button(-text => "Yes", -background => 'navy blue', -f
+oreground => 'white', -command =>\&save_and_exit)->
                        pack(-side => 'right'); 
      }
   }elsif($filename eq /\s/ && $data){
      my $sw = MainWindow->new(-title=>"Content Has Changed");
      my $frame = $sw->Frame->pack(-side => 'top', -fill => 'x');
      $frame->Label(-text => "Would you like to save before exiting?")
+->
                    pack(-side => 'left', -anchor => 'w');
      $frame->Button(-text => "No", -background => 'navy blue', -foreg
+round => 'white', -command => sub {exit 0;})->
                     pack(-side => 'right'); 
      $frame->Button(-text => "Yes", -background => 'navy blue', -fore
+ground => 'white', -command =>\&save_as)->
                     pack(-side => 'right'); 
   }else{
      exit 0;
   }
}
Replies are listed 'Best First'.
Re: pEdit
by zentara (Archbishop) on Mar 06, 2004 at 15:26 UTC
    It would be nice to say this is for Win32. I had to comment out the &print sub and change it to sub print {return} to get this to run. Maybe you could do an OS check? Like:
    ############################## if ($^O =~ /Win/i) { sub print {your sub.....} } else { sub print {return} } ##############################

    I'm not really a human, but I play one on earth. flash japh
      Yeah that is because the print function was the last thing I was working on. Other than that it is not platform specific which is what I was really going for while writing it. So for me to say it is for Windows only just because I was messing around with a Win32 print module in a beta release of it would do the program a great injustice.

      Like you have found if you simply comment this out or even remove it all together there are no platform dependencies, other than that I hope you liked it.

      Oh and I better mention this before some else does and thinks it is a bug or a lack of coding, all language keywords do not get colored. I only added those that I use quiet often and probably even left some of those out. It would be very easy to simply add the keywords you wanted to color to their coresponding desired color.

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: sourcecode [id://334317]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others chilling in the Monastery: (2)
As of 2024-04-20 03:04 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found