view release on metacpan or  search on metacpan

widgetTclpTk  view on Meta::CPAN

my $widget_lib = Tcl::pTk->findINC('demos/widget_lib');
my $wd = "$widget_lib/WidgetDemo.pm";
$WIDTRIB = Tcl::pTk->findINC('demos/widtrib');
unless (1) {
    $WIDTRIB = $ENV{WIDTRIB} if defined $ENV{WIDTRIB};
    $WIDTRIB = $ARGV[0] if defined $ARGV[0];
}


## Create images used for the buttons:
my $imageView = $MW->Photo('imageView', -format => 'GIF',
            -data => '    R0lGODlhEAAQAKIHAP///wwMDAAAAMDAwNnZ2SYmJmZmZv///yH5BAEAAAcALAAA
    AAAQABAAAANMKLos90+ASamDRxJCgw9YVnlDOXiQBgRDBRgHKE6sW8QR3doPKK27
    yg33q/GIOhdg6OsEJzeZykiBSUcs06e56Xx6np8ScIkFGuhQAgA7'
    );

my $imageDelete = $MW->Photo('imageDelete', -format => 'GIF',
            -data => '        R0lGODlhEAAQAIABAIQAAP///yH5BAEAAAEALAAAAAAQABAAAAIjjI+pmwAc3HGy
    PUSvqYpuvWQg40FfSVacBa5nN6JYDI3mzRQAOw=='
    );
    
my $imageRefresh = $MW->Photo('imageRefresh', -format => 'GIF',
            -data => '    R0lGODlhEAAQAJEDAP///wAAACpnKv///yH5BAEAAAMALAAAAAAQABAAAAI63IKp
    xgcPH2ouwgBCw1HIxHCQ4F3hSJKmwZXqWrmWxj7lKJ2dndcon9EBUq+gz3brVXAR
    2tICU0gXBQA7'
    );

# Try using darkmode-friendly PNG "NEW", otherwise fallback to GIF "NEW"
my $imageNew;
eval {
    $imageNew = $MW->Photo('imageNew', -format => 'PNG', -data => q{
    iVBORw0KGgoAAAANSUhEUgAAAB4AAAAOCAYAAAA45qw5AAACMElEQVR4AeVTAwxd
    QRCc2tZHGtQ2w9q2bdsOa9u2bUW1bdt2Z372JZe6DapJLqtb3h7+T8yKi5j4CsYD
    EUQXxETclT7kWOlH2VV+tFkdQHPSwksSISF+BauCqL0qgOcMWgGfgEkaMsHxqUBk
    3plE/sOnh/qDPAPJH/CKFBivGHWzFwBRnHhlqbu1Mh6CoFNnC/JshQ9p4YC2lrKt
    DCAV+THiVejyhMjAbrNSrroiEfKR9g7ZfCgOog8QfnUQV62wAk68ndQ9ZbyoWO1H
    Y6eDY1LCQL6a9ApOp9Hi1T0+gQq2JKMlky/oTKQliKWxEZvyG575kpW4pl1aZnQK
    CLOVt45Lkp8uXp2SL8KO6uitNTZLdpK6s+I/eZbhpmsmWeOGOVQNKYLITzpKPAO3
    tY7LSNZ7ccSLxX9y3uuOxRkg3dKESMoCHvL+GRVCutXsB3guLgDCeXOv4iWWkvwG
    BaS+PmlpK6SI9ApI2oC2UtrwZQEkhkH+NtolVlQXJl1I+QltuU3XEc721bIRFpa8
    IA5iqTo6vNNWmkNBLQbPeXwF2g17Q94nTQAfY3YzeY+WSu8MDzQ2kpELUhSGJUHE
    0zeR3rY1L+Xl5G/re+jbiK6KhThwwInsts1fbMUUcpZszKeVtggZEiGdZDe5AtHh
    7vL4CGiRvvKPS8FAvq9Nr4ZkFadR2y6kggu1z4vlyIbBp6BugQ8JLEg4bTkD9eMZ
    QZ8hpJ3VvTtuvbWrY/ElvP/9R+Aj3603+iE3fkEAAAAASUVORK5CYII=},
    );
    1;
} or do {
    $imageNew = $MW->Photo('imageNew', -format => 'GIF', -data => q{
    R0lGODlhHgAOALMPALMAANyIiOu7u8dEROaqqvru7sxVVeGZmbgREfXd3b0iItZ3
    d8IzM9FmZvDMzP///yH5BAEAAA8ALAAAAAAeAA4AAASa8MlJq7046827WVOCHEkw
    nANhUgJlEBIABJIwL3K+4IcUALCHjfbItYZDSgJgkBiYPmBMAUAkkLPKs/BAyLgM
    wAQwOAAY2ByCaw4QAFQSoDEePJ6DmU1xInYZTw5nOEFFdgVUelkVDTIMd3AKFGQ1
    MgI2AwEmQW8APZ0gdRONAks5nhIFVVxdAAkUAS2pAVwFl7ITB4UqHb0XEQA7},
    );
};

# The code below creates the main window, consisting of a menu bar
# and a text widget that explains how to use the program, plus lists
# all of the demos as hypertext items.

my $file = $menubar->cascade(qw/-label File -underline 0 -menuitems/ =>
    [
      [cascade    => '~View', -menuitems =>
        [
          [command  => '~widget', -command => [\&view_widget, __FILE__]],
          [command  => '~WidgetDemo', -command => [\&view_widget, $wd]],
        ], # end cascade menuitems
      ], # end view cascade
      '',
      [command    => '~Quit', -command => sub{ $MW->destroy }],
    ]);

my $help = $menubar->cascade(qw/-label Help -underline 0 -menuitems/ =>
    [
      [command    => '~About'],
    ]);

my $T = $MW->Scrolled('ROText',
    -scrollbars         => 'e',
    -wrap               => 'word',
    -width              => 70,
    -height             => 30,
    -font               => $FONT,
    -setgrid            => 1,
    -highlightthickness => 0,
    -padx               => 4,
    -pady               => 2,
    -takefocus          => 0,
)->grid(qw/-sticky nsew/);
$MW->gridRowconfigure(   0, -weight => 1); # allow expansion in both ...
$MW->gridColumnconfigure(0, -weight => 1); # ... X and Y dimensions

my $STATUS_VAR;
my $status = $MW->Label(-textvariable => \$STATUS_VAR, qw/-anchor w/);
$status->grid(qw/-sticky ew/);

# Create a bunch of tags to use in the text widget, such as those for
# section titles and demo descriptions.  Also define the bindings for
# tags.

$T->tagConfigure(qw/title -font -*-Helvetica-Bold-R-Normal--*-180-*-*-*-*-*-*/);
$T->tagConfigure(qw/demo -lmargin1 1c -lmargin2 1c -foreground blue/);

if ($MW->depth  == 1) {
    $T->tagConfigure(qw/hot -background black -foreground white/);
    $T->tagConfigure(qw/visited -lmargin1 1c -lmargin2 1c -underline 1/);
} else {
    $T->tagConfigure(qw/hot -relief raised -borderwidth 1 -foreground red/);
    $T->tagConfigure(qw/visited -lmargin1 1c -lmargin2 1c -foreground/ =>
	    '#303080');
    if ($MW->windowingsystem eq 'aqua' and $MW->interp->Eval(
	    'package vcompare $tk_patchLevel 8.6.11') != -1) {
	$T->tagConfigure('demo', -foreground => 'systemLinkColor');
	$T->tagConfigure('visited', -foreground => 'purple');
    }
}
$T->tagConfigure('bold', -font => 'Helvetica 12 bold');

$T->tagBind(qw/demo <ButtonRelease-1>/ => \&invoke);
my $last_line = '';
$T->tagBind(qw/demo <Enter>/ => [sub {
	my($text, $sv, $x, $y) = @_;
	$last_line = $text->index("\@$x,$y linestart");
	$text->tagAdd('hot', $last_line, "$last_line lineend");
	$text->configure(qw/-cursor hand2/);
	show_stat $sv, $text, $text->index('current');
    }, \$STATUS_VAR, Ev('x'), Ev('y')]
);
$T->tagBind(qw/demo <Leave>/ => [sub {
	my($text, $sv) = @_;
	$text->tagRemove(qw/hot 1.0 end/);
	$text->configure(qw/-cursor xterm/);
	$$sv = '';

widgetTclpTk  view on Meta::CPAN

    'image1'       => 'Two labels displaying images',
    'image2'       => 'A simple user interface for viewing images',
    'labelframe'   => 'Labelled frames',
    'ttkbut'        => '*The simple Themed Tk widgets',
);

demos 'Listboxes and Trees', (
    'states'       => 'The 50 states',
    'colors'       => 'Change widget\'s color scheme',
    'sayings'      => 'A collection of famous and infamous sayings',
    'mclist'      => '*A multi-column list of countries',
);

demos 'Entries, Spin-boxes and Combo-boxes', (
    'entry1'       => 'Entries without scrollbars',
    'entry2'       => 'Entries with scrollbars',
    'entry3'       => 'Validated entries and password fields',
    'spin'         => 'Spin-boxes',
    'combo'        => '*Combo-boxes',
    'form'         => 'Simple Rolodex-like form',
);

demos 'Text', (
    'texts'        => 'Basic editable text',
    'style'        => 'Text display styles',
    'bind'         => 'Hypertext (tag bindings)',
    'twind'        => 'A text widget with embedded windows',
    'search'       => 'A search tool built with a text widget',
);

demos 'Canvases', (
    'items'        => 'The canvas item types',
    'plot'         => 'A simple 2-D plot',
    'ctext'        => 'Text items in canvases',
    'arrows'       => 'An editor for arrowheads on canvas lines',
    'ruler'        => 'A ruler with adjustable tab stops',
    'floor'        => 'A building floor plan',
    'cscroll'      => 'A simple scrollable canvas',
    'transtile'    => 'Tiles and transparent images',
);

demos 'Scales and Progress Bars', (
    'hscale'       => 'Horizontal scale',
    'vscale'       => 'Vertical scale',
    'ttkprogressbar' => '*Progress bar',
);

demos 'Paned Windows and Notebooks', (
    'paned1'       => 'Horizontal paned window',
    'paned2'       => 'Vertical paned window',
    'ttkpane'      => '*Themed nested panes',
    'ttknote'      => '*Themed notebook',
);

demos 'Photos and Images', (
    'photo1'       => 'Transparent pixels',
    'photo2'       => 'Alpha channel compositing',
);

demos 'Menus and Toolbars', (
    'menus'        => 'Menus and cascades (sub-menus)',
    'menus2'       => 'As above, but using Perl/Tk -menuitems',
    'menbut'       => 'Menubuttons',
    'ttkmenu'      => '*Themed menu buttons',
    'toolbar'      => '*Themed toolbar',
);

demos 'Common Dialogs', (
    'msgBox'       => 'Message boxes',
    'filebox'      => 'File selection dialog',
    'choosedir'    => 'Directory selection dialog',
    'clrpick'      => 'Color picker',
);

demos 'Tix Widgets', (
    'balloon'      => 'Popup help window when mouse lingers over widget',
    'browseentry'  => 'Entry with Listbox to select list values',
    'browseentry2' => 'Another BrowseEntry example',
    'dirtree'      => 'Display a directory tree',
    'form_mgr'     => 'The form geometry manager',
    'HList'        => 'A hierarchical listbox widget',
    'HList2'       => 'Multicolumn listbox with individual cell styles',
    'labframe'     => 'A Frame with embedded label',
);

demos 'Simulations', (
    'bounce'       => 'Balls bouncing in a cavity',
);

demos 'Sample Perl Mega-Widgets', (
    'mega'         => 'Introduction to writing pure Perl mega-widgets',
    'slide'        => 'Composite Tk::SlideSwitch - binary on/off switch',
    'trace2'       => 'Derived   Tk::TraceText - Text contents defined by a traced variable',
);

demos 'Miscellaneous', (
    'bitmaps'      => 'The built-in bitmaps',
    'dialog1'      => 'A dialog box with a local grab',
    'dialog2'      => 'A dialog box with a global grab',
    'trace1'       => 'Trace a variable\'s value',
    'progress'     => 'Various ProgressBar widgets',
    'keysyms'      => 'Show keyboard symbols',
    'virtevents1'  => 'Synthesizing events',
);

$T->insert('end', "\n", '', "User Contributed Demonstrations\n", 'title');
opendir(C, $WIDTRIB) or warn "Cannot open $WIDTRIB: $!";
my(@dirent) = grep /^.+\.pl$/, sort(readdir C);
closedir C;
unshift @dirent, 'TEMPLATE.pl';	# I want it first
my $i = 0;
while ($_ = shift @dirent) {
    next if /TEMPLATE\.pl/ and $i != 0;
    unless (open(C, "$WIDTRIB/$_")) {
	warn "Cannot open $_: $!" unless /TEMPLATE\.pl/;
	next;
    }
    my($name) = /^(.*)\.pl$/;
    $_ = <C>;
    my($title) = /^#\s*(.*)$/;
    $DEMO_DESCRIPTION{$name} = $title;