Beefy Boxes and Bandwidth Generously Provided by pair Networks
Your skill will accomplish
what the force of many cannot
 
PerlMonks  

comment on

( [id://3333]=superdoc: print w/replies, xml ) Need Help??
#!/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); } }

In reply to pEdit v0.8 Beta release by Elijah

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • 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.
Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Chatterbox?
and the web crawler heard nothing...

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

    No recent polls found