#!/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;
}
}
|