Category: | GUI Programming |
Author/Contact Info | KM - http://perlguy.com/gpod/ |
Description: | As an exercise to do some Perl/Gtk+ without using Glade, I decided to create a Gtk+ POD viewer, gPOD.
I have been using it for the last few days, and actually kind of like it, so I thought I would share. I have
a growing TODO list for it (adding color text, saving as things other than text, saving prefs, etc...) so
if you happen to use it, and like it let me know so I can give you updates. So, use it, abuse it, give me some comments (here or email), suggestions, patches, screenshots, etc.. I plan to continue to work on this and build a decent app. So far, I have only tested this with Gtk 1.2.8/Gtk-Perl 0.7004, and Helix Gnome. |
#!/usr/bin/perl use strict; use warnings; use Gnome; use Pod::Text; use Fcntl; use Config; my $NAME = 'gPOD'; my $VERSION = '0.1'; my %cache; my %saved; my $current; my @current_font = (undef, undef); my $file_dialog; my $font_diag; init Gnome $NAME; my $app = new Gnome::App $NAME, $NAME; signal_connect $app 'delete_event', sub { Gtk->main_quit; return 0 }; $app->create_menus( { type => 'subtree', label => '_File', subtree => [ # Don't need these (yet) #{ # type => 'item', # label => '_New', # pixmap_type => 'stock', # pixmap_info => 'Menu_New' #}, #{ # type => 'item', # label => '_Open...', # pixmap_type => 'stock', # pixmap_info => 'Menu_Open' #}, { type => 'item', label => '_Save', pixmap_type => 'stock', pixmap_info => 'Menu_Save', callback => \&signal_save_file }, #{ # type => 'item', # label => 'Save _As...', # pixmap_type => 'stock', # pixmap_info => 'Menu_Save As' #}, { type => 'separator' }, { type => 'item', label => 'E_xit', pixmap_type => 'stock', pixmap_info => 'Menu_Quit', callback => sub { Gtk->main_quit; ret +urn 0 } } ] }, { type => 'subtree', label => '_Edit', subtree => [ # Don't need these (yet) #{ # type => 'item', # label => 'C_ut', # pixmap_type => 'stock', # pixmap_info => 'Menu_Cut', #}, { type => 'item', label => '_Copy', pixmap_type => 'stock', pixmap_info => 'Menu_Copy' }, #{ # type => 'item', # label => '_Paste', # pixmap_type => 'stock', # pixmap_info => 'Menu_Paste' #} ] }, # No prefs, yet { type => 'subtree', label => '_Settings', subtree => [ { type => 'item', label => '_Fonts', pixmap_type => 'stock', pixmap_info => 'Menu_Preferences', callback => \&signal_show_fonts } ] }, # { # type => 'item', # label => '_Preferences...', # pixmap_type => 'stock', # pixmap_info => 'Menu_Preferences', # callback => \&signal_show_prefs # } # ] #}, { type => 'subtree', label => '_Help', subtree => [ {type => 'item', label => '_About...', pixmap_type => 'stock', pixmap_info => 'Menu_About', callback => \&about_box } ] } ); $app->create_toolbar( { type => 'item', label => 'Save', pixmap_type => 'stock', pixmap_info => 'Save', hint => "Save this POD", callback => \&signal_save_file }, { type => 'item', label => 'Exit', pixmap_type => 'stock', pixmap_info => 'Quit', hint => "Quit $NAME", callback => sub { Gtk->main_quit;} } ); # Get pod files my $PATH = $Config{installprivlib} . "/pod"; opendir (DIR, $PATH); my @pods = grep { /\.pod$/} readdir DIR; closedir DIR; $app->set_default_size(600,400); # Make window where POD text will be my $text = new Gtk::Text(undef, undef); $text->set_editable(0); $text->set_adjustments($text->hadj,$text->vadj); # Make scrollbar my $vscroll = new Gtk::VScrollbar($text->vadj); # Make window which will list PODs my $scrolled_window = new Gtk::ScrolledWindow( undef, undef ); $scrolled_window->set_policy( 'automatic', 'automatic' ); # Make list of PODs my $list = new Gtk::List; $list->signal_connect('selection_changed', \&signal_list_selected); $scrolled_window->add_with_viewport($list); # Create our list-o-PODs my $length = 0; my %holder; for my $pod (sort @pods) { my $item = new Gtk::ListItem; (my $cpod = $pod) =~ s!\.pod$!!; my $lab = new Gtk::Label($cpod); $length = length($pod) if length $pod > $length; $item->add($lab); $list->add($item); $holder{$item->{_gtk}} = $pod; } # Make the hbox my $box1 = new Gtk::HBox(0,0); # Define starting size of list window $scrolled_window->set_usize($length*8,0); # Define starting size of viewing window $text->set_usize(600-($length*8),0); # Pack up the hbox with goodies $box1->pack_start($scrolled_window, 0, 1, 0); $box1->pack_start($text, 1, 1, 0); $box1->pack_start($vscroll, 0, 0, 0); # Toss the hbox into the app $app->set_contents($box1); # App bar my $bar = new Gnome::AppBar 0,1,"user"; $bar->set_status(""); $app->set_statusbar($bar); show_all $app; main Gtk; # Signals and subroutines sub about_box { my $about = new Gnome::About $NAME, $VERSION, "(C) Kevin Meltzer, 2001", ["Kevin Meltzer <gpod\@perlguy.com>"], "A Gtk+ POD Viewer\n\n". "Gtk " . Gtk->major_version . "." . Gtk->minor_version . "." . Gtk->micro_version . "\n". "Gtk-Perl " . $Gtk::VERSION . "\n" . "This program is released under the same terms as Perl itself"; $about->set_title("About $NAME"); $about->position('mouse'); $about->set_policy(1,1,0); $about->set_modal(1); show $about; } sub signal_list_selected { my @list = @_; my @dlist = $list[0]->selection; # Must be an unselect.. so bail return unless @dlist; # This is dumb my $item = $holder{%{$dlist[0]}->{'_gtk'}}; $text->backward_delete($text->get_point); $text->set_point(0); $current = $item; # See if we have this POD in the cache already if (exists $cache{$item}) { $text->insert($current_font[0], $text->style->text('no +rmal'), undef, $cache{$item}); $bar->set_status("$item (From cache)"); return; } # Make temp file. my $tmp = "/tmp/gPOD.$item.$$"; # Do what part of perldoc does sysopen(OUT, $tmp, O_WRONLY | O_EXCL | O_CREAT, 0600) or die " +Can't open $tmp: $!"; # Hate to turn off warnings, but Pod::Text can throw crap at u +s {local $^W =0; Pod::Text->new()->parse_from_file("$PATH/$item" +,\*OUT);}; close OUT; # Open the file open(FH, $tmp); my @lines = <FH>; close FH; # cache it $cache{$item} = "@lines"; $text->insert($current_font[0], $text->style->text('normal'), +undef, "@lines"); $bar->set_status("$item (From file)"); # clean up unlink $tmp; } # Below is currently unused sub signal_show_prefs { my $option = new Gtk::Menu; my $option_item = new Gtk::MenuItem("Soon, you can prefer thin +gs"); $option->append($option_item); #$option_item->signal_connect('activate', sub {print "foo";}); $option_item->show; $option->popup(undef, undef, time(), undef, undef); } # Currently, only saving text. I want to change this. sub signal_save_file { # Do nothing if no file is being viewed return unless $current; # Create a new file selection widget $file_dialog = new Gtk::FileSelection("File Selection"); $file_dialog->signal_connect( "destroy", sub { $file_dialog->h +ide; } ); # Connect the ok_button to file_ok_sel function $file_dialog->ok_button->signal_connect( "clicked", \&file_ok_sel, $file_dialog ); # Connect the cancel_button to hide the widget $file_dialog->cancel_button->signal_connect( "clicked", sub {$file_dialog->hi +de;} ); # Lets set the filename, as if this were a save dialog, and we + are giving # a default filename $file_dialog->set_filename($current. ".txt"); $file_dialog->show(); } # Get the selected filename and print it to the console sub file_ok_sel { my ($widget, $file_selection) = @_; my $file = $file_selection->get_filename(); # For later use #$saved{$file}++; open(FH, ">>$file") or die "Can't open $file ($!)"; print FH $cache{$current}; close FH; $file_dialog->hide; } sub signal_show_fonts { $font_diag = new Gtk::FontSelectionDialog("Fonts"); $font_diag->signal_connect( "destroy", sub { $font_diag->hide; + } ); # Connect the ok_button to file_ok_sel function $font_diag->ok_button->signal_connect("clicked", \&font_ok_sel, $font_diag ); # Connect the cancel_button to hide the widget $font_diag->cancel_button->signal_connect("clicked", sub {$font_diag->hide;} +); $font_diag->set_font_name($current_font[1]) if $current_font[1 +]; $font_diag->show(); } sub font_ok_sel { my ($widget, $font_selection) = @_; my $font = $font_diag->get_font; my $font_full = $font_diag->get_font_name; $font_diag->hide; $text->backward_delete($text->get_point); $text->set_point(0); $text->insert($font , $text->style->text('normal'), undef,$cac +he{$current}) unless !exists $cache{$current}; @current_font = ($font, $font_full); } |
|
---|
Back to
Code Catacombs