menu

#!/usr/bin/perl -w

use strict;
use Tkx;

our $VERSION = "1.00";

(my $progname = $0) =~ s,.*[\\/],,;
my $IS_AQUA = Tkx::tk_windowingsystem() eq "aqua";

eval {
    Tkx::package_require("style");
    Tkx::style__use("lobster", -priority => 70);
};
if ($@) {
    $@ =~ s/ at .*//;
    print "Can't update style: $@";
}

my $mw = Tkx::widget->new(".");
$mw->configure(-menu => mk_menu($mw));

Tkx::MainLoop();
exit;

sub mk_menu {
    my $mw = shift;
    my $menu = $mw->new_menu;

    my $file = $menu->new_menu(
        -tearoff => 0,
    );
    $menu->add_cascade(
        -label => "File",
        -underline => 0,
        -menu => $file,
    );
    $file->add_command(
        -label => "New",
        -underline => 0,
        -accelerator => "Ctrl+N",
        -command => \&new,
    );
    $mw->g_bind("<Control-n>", \&new);
    $file->add_command(
        -label   => "Exit",
        -underline => 1,
        -command => [\&Tkx::destroy, $mw],
    ) unless $IS_AQUA;

    my $help = $menu->new_menu(
        -name => "help",
        -tearoff => 0,
    );
    $menu->add_cascade(
        -label => "Help",
        -underline => 0,
        -menu => $help,
    );
    $help->add_command(
        -label => "\u$progname Manual",
        -command => \&show_manual,
    );

    my $about_menu = $help;
    if ($IS_AQUA) {
	# On Mac OS we want about box to appear in the application
	# menu.  Anything added to a menu with the name "apple" will
	# appear in this menu.
	$about_menu = $menu->new_menu(
	    -name => "apple",
        );
	$menu->add_cascade(
	    -menu => $about_menu,
        );
    }
    $about_menu->add_command(
        -label => "About \u$progname",
        -command => \&about,
    );

    return $menu;
}


sub about {
    Tkx::tk___messageBox(
        -parent => $mw,
        -title => "About \u$progname",
        -type => "ok",
        -icon => "info",
        -message => "$progname v$VERSION\nCopyright 2005 ActiveState.  All rights reserved.",
    );
}

BEGIN {
    my @pod;
    my $manual_window;
    my $bold;

    sub show_manual {
	if ($manual_window && Tkx::winfo_exists($manual_window)) {
	    $manual_window->g_wm_deiconify;
	    $manual_window->g_raise;
	    return $manual_window;
	}

	unless (@pod) {
	    @pod = <DATA>;
	    shift(@pod) while $pod[0] =~ /^\s*$/;
	}

	my $w = $manual_window = $mw->new_toplevel();
	$w->g_wm_title("\u$progname Manual");

	Tkx::package_require("BWidget");
	my $sw = $w->new_ScrolledWindow(
            -managed => 0,
        );
        $sw->g_pack(
            -fill => "both",
            -expand => 1,
        );
        my $t = $sw->new_text(
            -padx => 5,
            -pady => 5,
            -background => "white",
        );
        $sw->setwidget($t);

	unless ($bold) {
	    my $font = $t->cget("-font");
	    if (Tkx::font_configure($font, "-weight") ne "bold") {
		$bold = Tkx::font_create(Tkx::SplitList(Tkx::font_configure($font)));
		Tkx::font_configure($bold,
		    -weight => "bold",
		    -size => int(Tkx::font_configure($font, "-size") * 1.4),
                );
	    }
	    else {
		$bold = $font;
	    }
	}

	$t->tag_configure("head1",
	    -background => "gray90",
            -font => $bold,
        );

	for my $line (@pod) {
	    local $_ = $line;  # copy since we modify
	    if (s/^=(head[1-4])\s+//) {
		$t->insert("end", $_, $1);
	    }
	    else {
		s/[A-Z]<([^>]*)>/$1/g;
		$t->insert("end", $_);
	    }
	}

	return $manual_window;
    }
}

__DATA__

=head1 NAME

menu - Application framework demo

=head1 SYNOPSIS

 menu

=head1 DESCRIPTION

This program demonstrates how a standard menu is set up, so please
take a look at its source code.

=head1 LICENSE

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

Copyright 2005 ActiveState.  All rights reserved.

=head1 SEE ALSO

L<Tkx>