#!/usr/bin/perl
################################
################################
## Written by ZiaTioN ##
## Title = pEdit ##
## version 0.8 (beta release) ##
## http://www.perlskripts.com ##
################################
################################
# The following comments are for perl2exe compilation!
#perl2exe_include Tk;
#perl2exe_include Tk::Text;
#perl2exe_include Tk::Menu;
#perl2exe_include Tk::TextUndo;
#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::TextUndo;
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.8) - (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);
my $mw = MainWindow->new();
$mw->minsize(qw(350 200));
$mw->title($main_title);
# Create necessary widgets
my $t = $mw->Scrolled("TextUndo", -scrollbars => 'e', -font => ['Couri
+er New', '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->separator;
$file_menu->command(-label => '~Save',
-command => \&save_file);
$file_menu->command(-label => '~Save As',
-command => \&save_as);
$file_menu->separator;
$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 => '~Undo',
-command => sub {$t->undo()});
$edit_menu->command(-label => '~Redo',
-command => sub {$t->redo()});
$edit_menu->separator;
$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 => '~Total Lines',
-command => \&total_lines);
$edit_menu->separator;
$edit_menu->command(-label => '~Text Formatting',
-command => \&color_text);
$edit_menu->command(-label => '~Refresh',
-command => \&refresh);
my $functions_menu = $menubar->cascade(-label => "~Functions", -tearof
+f => 0);
$functions_menu->command(-label => '~Add Indention',
-command => \&addtab);
$functions_menu->command(-label => '~Remove Indention',
-command => \&detab);
$functions_menu->separator;
$functions_menu->command(-label => '~Comment',
-command => \&comment);
$functions_menu->command(-label => '~Un-Comment',
-command => \&uncomment);
$functions_menu->separator;
$functions_menu->command(-label => '~Test Syntax',
-command => \&interpret);
$functions_menu->command(-label => '~Run Script',
-command => \&run);
$functions_menu->command(-label => '~Run With Arguments',
-command => \&runwith);
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');
}elsif (-e "pedit.gif") {
$ts->Photo('middle', -file=>"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::TextUndo', '<Control-s>', [\&save_file]);
$mw->bind('Tk::TextUndo', '<Control-a>', sub {$t->tagAdd('sel','1.0','
+end')});
$mw->bind('Tk::TextUndo', '<Control-o>', sub {load()});
$mw->bind('Tk::TextUndo', '<Control-n>', [\&clear_new]);
$mw->bind('Tk::TextUndo', '<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 => $t,
-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 => $t,
-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 {
my $args = "" || shift;
$info = "Executing script!";
if (!$filename) {
chomp(my $data = $t->get("1.0", "end"));
if ($data =~ /\w+/) {
open (IN, ">syn_check") || $status->insert("end", "Error duri
+ng script execution!\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);
if ($args) {
system qq[ start cmd /k perl "$filename" $args];
}else{
system qq[ start cmd /k perl "$filename" ];
}
}else{
my($fork);
if ($args) {
system qq[ start cmd /k perl "$filename" $args];
}else{
system qq[ start cmd /k perl "$filename" ];
}
}
$status->delete("1.0", "end");
$status->insert("end", "Program execution complete!");
}
sub runwith {
my $args;
my $argw = $mw->DialogBox(-title => "Enter Script Arguments", -butt
+ons => ["Run", "Cancel"], -popover => $t);
$argw->add("Entry", -text => \$args)->pack();
$argw->resizable('no','no');
my $response = $argw->Show();
run($args) if ($response eq "Run");
$argw->destroy if ($response eq "Cancel");
}
##############################################
# addtab accomplishes a block indention level.
sub addtab {
my ($tab, $spaces, $times);
$spaces = 3;
$times = 0;
while ($times < $spaces) {
$tab .=" ";
$times++;
}
my $selected = $t->getSelected;
$t->deleteSelected;
my @splitsel = split(/\n/, $selected);
foreach (@splitsel) {
$t->Insert($tab);
$t->Insert($_);
$t->Insert("\n");
}
refresh();
}
########################################
# detab removes a block indention level.
sub detab {
my ($spaces, $times, $whites, $char);
$spaces = 3;
($whites, $times) = 0;
my $selected = $t->getSelected;
$t->deleteSelected;
my @splitsel = split(/\n/, $selected);
foreach (@splitsel) {
my @chars = split(//, $_);
foreach my $char (@chars) {
if ($char =~ /\s/) { $whites++; }else{ last; }
}
if ($whites >= $spaces) {
$_ = substr($_, $spaces);
}else{
$_ = substr($_, $whites);
}
$t->Insert($_);
$t->Insert("\n");
$whites = 0;
}
refresh();
}
########################
# adds block commenting.
sub comment {
my $selected = $t->getSelected;
$t->deleteSelected;
my @splitsel = split(/\n/, $selected);
foreach (@splitsel) {
$t->Insert("#");
$t->Insert($_);
$t->Insert("\n");
}
refresh();
}
###########################
# removes block commenting.
sub uncomment {
my $selected = $t->getSelected;
$t->deleteSelected;
my @splitsel = split(/\n/, $selected);
foreach (@splitsel) {
$_ = substr($_, 1) if ($_ =~ /^#/);
$t->Insert($_);
$t->Insert("\n");
}
refresh();
}
################################################################
# 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
+", "Cancel"], -popover => $t);
$sw->add("Entry", -text => \$line_number)->pack();
$sw->resizable('no','no');
my $response = $sw->Show();
if ($line_number != 0 && $response eq "Go") {
&scroll_line;
}else{
$sw->destroy;
}
}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 = $mw->DialogBox(-title => "Content Has Changed", -but
+tons => ["Save & Exit", "Discard"], -popover => $t);
$sw->resizable('no','no');
my $response = $sw->Show();
if ($response eq "Save & Exit") {
save_and_exit();
}else{
exit(0);
}
}
}elsif($filename eq /\s/ && $data){
my $sw = $mw->DialogBox(-title => "Content Has Changed", -button
+s => ["Save & Exit", "Discard"], -popover => $t);
$sw->resizable('no','no');
my $response = $sw->Show();
if ($response eq "Save & Exit") {
save_as();
}else{
exit(0);
}
}else{
exit(0);
}
}
-
Are you posting in the right place? Check out Where do I post X? to know for sure.
-
Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
<code> <a> <b> <big>
<blockquote> <br /> <dd>
<dl> <dt> <em> <font>
<h1> <h2> <h3> <h4>
<h5> <h6> <hr /> <i>
<li> <nbsp> <ol> <p>
<small> <strike> <strong>
<sub> <sup> <table>
<td> <th> <tr> <tt>
<u> <ul>
-
Snippets of code should be wrapped in
<code> tags not
<pre> tags. In fact, <pre>
tags should generally be avoided. If they must
be used, extreme care should be
taken to ensure that their contents do not
have long lines (<70 chars), in order to prevent
horizontal scrolling (and possible janitor
intervention).
-
Want more info? How to link
or How to display code and escape characters
are good places to start.