Recently in Graphics Category

Lightning Strikes Four Times

by Mike Friedman

Good software design principles tell us that we should work to separate unrelated concerns. For example, the popular Model-View-Controller (MVC) pattern is common in web application designs. In MVC, separate modular components form a model, which provides access to a data source, a view, which presents the data to the end user, and a controller, which implements the required features.

Ideally, it's possible to replace any one of these components without breaking the whole system. A templating engine that translates the application's data into HTML (the view) could be replaced with one that generates YAML or a PDF file. The model and controller shouldn't be affected by changing the way that the view presents data to the user.

Other concerns are difficult to separate. In the world of aspect-oriented programming, a crosscutting concern is a facet of a program which is difficult to modularize because it must interact with many disparate pieces of your system.

Consider an application that logs copious trace data when in debugging mode. In order to ensure that it is operating correctly, you may want to log when it enters and exits each subroutine. A typical way to accomplish this is by conditionally executing a logging function based on the value of a constant, which turns debugging on and off.

    use strict;
    use warnings;

    use constant DEBUG => 1;

    sub do_something { 
        log_message("I'm doing something") if DEBUG;

        # do something here

        log_message("I'm done doing something") if DEBUG;
    }

This solution is simple, but it presents a few problems. Perhaps most strikingly, it's simply a lot of code to write. For each subroutine that you want to log, you must write two nearly identical lines of code. In a large system with hundreds or thousands of subroutines, this gets tedious fast, and can lead to inconsistently formatted messages as every copy-paste-edit cycle tweaks them a little bit.

Further, it offends the simple design goal of an MVC framework, because every component must talk to the logging system directly.

One way to improve this technique is to automatically wrap every interesting subroutine in a special logging function. There are a few ways to go about this. One of the simplest is to use subroutine attributes to install a dynamically generated wrapper.

Attributes

Perl 5.6 introduced attributes that allow you to add arbitrary metadata to a variable. Attributes can be attached both to package variables, including subroutines, and lexical variables. Since Perl 5.8, attributes on lexical variables apply at runtime. Attributes on package variables activate at compile-time.

The interface to Perl attributes is via the attributes pragma. (The older attrs is deprecated.) The CPAN module Attribute::Handlers makes working with attributes a bit easier. Here's an example of how you might rewrite the logging system using an attribute handler.

    use strict;
    use warnings;

    use constant DEBUG => 1;

    use Attribute::Handlers;

    sub _log : ATTR(CODE) {
        my ($pkg, $sym, $code) = @_;

        if( DEBUG ) {
            my $name = *{ $sym }{NAME};

            no warnings 'redefine';

            *{ $sym } = sub {
                log_message("Entering sub $pkg\:\:$name");
                my @ret = $code->( @_ );
                log_message("Leaving sub $pkg\:\:$name");
                return @ret;
            };
        }
    }

    sub do_something : _log {
        print "I'm doing something.\n";
    }

Attributes are declared by placing a colon (:) and the attribute name after a variable or subroutine declaration. Optionally, the attribute can receive some data as a parameter; Attribute::Handlers goes to great lengths to massage the passed data for you if necessary.

To set up an attribute handler, the code declares a subroutine, _log, with the ATTR attribute, passing the string CODE as a parameter. Attribute::Handlers provides ATTR, and the CODE parameter tells it that the new handler only applies to subroutines.

During compile time, any subroutine declared with the _log attribute causes Perl to call the attribute handler with several parameters. The first three are the package in which the subroutine was compiled, a reference to the typeglob where its symbol lives, and a reference to the subroutine itself. These are sufficient for now.

If the DEBUG constant is true, the handler sets to work wrapping the newly compiled subroutine. First, it grabs its name from the typeglob, then it adds a new subroutine to its spot in the symbol table. Because the code redefines a package symbol, it's important to turn off warnings for symbol redefinitions in within this block.

Because the new function is a lexical closure over $pkg, $name, and most importantly $code, it can use those values to construct the logging messages and call the original function.

All of this may seem like a lot of work, but once it's done, all you need to do to enable entry and exit logging for any function is to simply apply the _log attribute. The logging messages themselves get manufactured via closures when the program compiles, so we know they'll always be consistent. If you want to change them, you only have to do it in one place.

Best of all, because attribute handlers get inherited, if you define your handler in a base class, any subclass can use it.

Caveats

Although this is a powerful technique, it isn't perfect. The code will not properly wrap anonymous subroutines, and it won't necessarily propagate calling context to the wrapped functions. Further, using this technique will significantly increase the number of subroutine dispatches that your program must execute during runtime. Depending on your program's complexity, this may significantly increase the size of your call stack. If blinding speed is a major design goal, this strategy may not be for you.

Going Further

Other common cross-cutting concerns are authentication and authorization systems. Subroutine attributes can wrap functions in a security checker that will refuse to call the functions to callers without the proper credentials.

Perl Outperforms C with OpenGL

by Bob Free

Desktop developers often assume that compiled languages always perform better than interpreted languages such as Perl.

Conversely, most LAMP online service developers are familiar with mechanisms for preloading Perl interpreters modules (such as Apache mod_perl and ActivePerl/ISAPI), and know that Perl performance often approaches that of C/C++.

However, few 3D developers think of Perl when it comes to performance. They should.

GPUs are increasingly taking the load off of CPUs for number-crunching. Modern GPGPU processing leverages C-like programs and loads large data arrays onto the GPU, where processing executes independent of the CPU. As a result, the overall contribution of CPU-bound programs diminish, while Perl and C differences become statistically insignificant in terms of GPU performance.

The author has recently published a open source update to CPAN's OpenGL module, adding support for GPGPU features. With this release, he has also posted OpenGL Perl versus C benchmarks--demonstrating cases where Perl outperforms C for OpenGL operations.

What Is OpenGL?

OpenGL is an industry-standard, cross-platform language for rendering 3D images. Originally developed by Silicon Graphics Inc. (SGI), it is now in wide use for 3D CAD/GIS systems, game development, and computer graphics (CG) effects in film.

With the advent of Graphic Processing Units (GPU), realistic, real-time 3D rendering has become common--even in game consoles. GPUs are designed to process large arrays of data, such as 3D vertices, textures, surface normals, and color spaces.

It quickly became clear that the GPU's ability to process large amounts of data could expand well beyond just 3D rendering, and could applied to General Purpose GPU (GPGPU) processing. GPGPUs can process complex physics problems, deal with particle simluations, provide database analytics, etc.

Over the years, OpenGL has expanded to support GPGPU processing, making it simple to load C-like programs into GPU memory for fast execution, to load large arrays of data in the form of textures, and to quickly move data between the GPU and CPU via Frame Buffer Objects (FBO).

While OpenGL is in itself a portable language, it provides no interfaces to operating system (OS) display systems. As a result, Unix systems generally rely on an X11-based library called GLX; Windows relies on a WGL interface. Several libraries, such as GLUT, help to abstract these differences. However, as OpenGL added new extensions, OS vendors (Microsoft in particular) provided different methods for accessing the new APIs, making it difficult to write cross-platform GPGPU code.

Perl OpenGL (POGL)

Bob Free of Graphcomp has just released a new, portable, open source Perl OpenGL module (POGL 0.55).

This module adds support for 52 new OpenGL extensions, including many GPGPU features such as Vertex Arrays, Frame Buffer Objects, Vertext Programs, and Fragment Programs.

In terms of 3D processing, these extensions allow developers to perform real-time dynamic vertex and texturemap generation and manipulation within the GPU. This module also simplifies GPGPU processing by moving data to and from the CPU through textures, and loading low-level, assembly-like instructions to the GPU.

POGL 0.55 is a binary Perl module (written in C via XS), that has been tested on Windows (NT/XP/Vista) and Linux (Fedora 6. Ubuntu/Dapper). Source and binaries are available via SVN, PPM, tarball, and ZIP at the POGL homepage.

POGL OS Performance

The POGL homepage includes initial benchmarks comparing POGL on Vista, Fedora, and Ubuntu. These tests show that static texture rendering on an animated object on Fedora was 10x faster than Vista; Ubuntu was 15x faster (using the same nVidia cards, drivers, and machine).

A subsequent, tighter benchmark eliminated UI and FPS counters, and focused more on dynamic texturemap generation. These results, posted on OpenGL C versus Perl benchmarks, show comparable numbers for Fedora and Ubuntu, with both outperforming Vista by about 60 percent.

Note: a further performance on these benchmarks could be available through the use of GPU vertex arrays.

Perl versus C Performance

These benchmarks also compare Perl against C code. It found no statistical difference between overall Perl and C performance on Linux. Inexplicably, Perl frequently outperformed C on Vista.

In general, C performed better than Perl on Vertex/Fragment Shader operations, while Perl outperformed C on FBO operations. In this benchmark, overall performance was essentially equal between Perl and C.

The similarity in performance is explained by several factors:

  • GPU is performing the bulk of the number-crunching operations
  • POGL is a compiled C module
  • Non-GPU operations are minimal

In cases where code dynamically generates or otherwise modifies the GPU's vetex/fragment shader code, it is conceivable that Perl would provide even better than C, due to Perl's optimized and interpreted string handling.

Perl Advantages

Given that GPGPU performance will be a wash in most cases, the primary reason for using a compiled language is to obfuscate source for intellectual property (IP) reasons.

For server-side development, there's really no reason to use a compiled language for GPGPU operations, and several reasons to go with Perl:

  • Perl OpenGL code is more portable than C; therefore there are fewer lines of code
  • Numerous imaging modules for loading GPGPU data arrays (textures)
  • Portable, open source modules for system and auxiliary functions
  • Perl (under mod-perl/ISAPI) is generally faster than Java
  • It is easier to port Perl to/from C than Python or Ruby
  • As of this writing, there is no FBO support in Java, Python, or Ruby

There is a side-by-side code comparison between C and Perl posted on the above benchmark page.

Desktop OpenGL/GPU developers may find it faster to prototype code in Perl (e.g., simpler string handling and garbage collection), and then port their code to C later (if necessary). Developers can code in one window and execute in another--with no IDE, no compiling--allowing innovators/researchers to do real-time experiments with new shader algorithms.

Physicists can quickly develop new models; researchers and media developers can create new experimental effects and reduce their time to market.

Summary

Performance is not a reason a reason to use C over Perl for OpenGL and GPGPU operations, and there are many cases where Perl is preferable to C (or Java/Python/Ruby).

By writing your OpenGL/GPU code in Perl, you will likely:

  • Reduce your R&D costs and time to market
  • Expand your platform/deployment options
  • Accelerate your company's GPGPU ramp up

Using Test::Count

by Shlomi Fish

A typical Test::More test script contains several checks. It is preferable to keep track of the number of checks that the script is running (using use Test::More tests => $NUM_CHECKS or the plan tests => $NUM_CHECKS), so that if some checks are not run (for whatever reason), the test script will still fail when being run by the harness.

If you add more checks to a test file, then you have to remember to update the plan. However, how do you keep track of how many tests should run? I've already encountered a case where a DBI related module had a different number of tests with an older version of DBI than with a more recent one.

Enter Test::Count. Test::Count originated from a Vim script I wrote to keep track of the number of tests by using meta-comments such as # TEST (for one test) or # TEST*3*5 (for 15 tests). However, there was a limit to what I could do with Vim's scripting language, as I wanted a richer syntax for specifying the tests as well as variables.

Thus, I wrote the Test::Count module and placed it on CPAN. Test::Count::Filter acts as a filter, counts the tests, and updates them. Here's an example, taken from a code I wrote for a Perl Quiz of the Week:

#!/usr/bin/perl -w

# This file implements various functions to remove
# all periods ("."'s) except the last from a string.

use strict;

use Test::More tests => 5;
use String::ShellQuote;

sub via_split
{
    my $s = shift;
    my @components = split(/\./, $s, -1);
    if (@components == 1)
    {
        return $s;
    }
    my $last = pop(@components);
    return join("", @components) . "." . $last;
}

# Other Functions snipped.

# TEST:$num_tests=9
# TEST:$num_funcs=8
# TEST*$num_tests*$num_funcs
foreach my $f (@funcs)
{
    my $ref = eval ("\\&$f");
    is($ref->("hello.world.txt"), "helloworld.txt", "$f - simple"); # 1
    is($ref->("hello-there"), "hello-there", "$f - zero periods"); # 2
    is($ref->("hello..too.pl"), "hellotoo.pl", "$f - double"); # 3
    is($ref->("magna..carta"), "magna.carta", "$f - double at end"); # 4
    is($ref->("the-more-the-merrier.jpg"),
       "the-more-the-merrier.jpg", "$f - one period"); # 5
    is($ref->("hello."), "hello.", "$f - one period at end"); # 6
    is($ref->("perl.txt."), "perltxt.", "$f - period at end"); # 7
    is($ref->(".yes"), ".yes", "$f - one period at start"); # 8
    is($ref->(".yes.txt"), "yes.txt", "$f - period at start"); # 9
}

Filtering this script through Test::Count::Filter provides the correct number of tests. I then add this to my .vimrc:

function! Perl_Tests_Count()
    %!perl -MTest::Count::Filter -e 'Test::Count::Filter->new({})->process()'
endfunction

autocmd BufNewFile,BufRead *.t map <F3> :call Perl_Tests_Count()<CR>

Now I can press F3 to update the number of checks.

Test::Count supports +,-,*, /, as well as parentheses, so it is expressive enough for most needs.

Acknowledgements

Thanks to mrMister from Freenode for going over earlier drafts of this article and correcting some problems.

What's In that Scalar?

by brian d foy

Scalars are simple, right? They hold single values, and you don't even have to care what those values are because Perl figures out if they are numbers or strings. Well, scalars show up just about anywhere and it's much more complicated than single values. I could have undef, a number or string, or a reference. That reference can be a normal reference, a blessed reference, or even a hidden reference as a tied variable.

Perhaps I have a scalar variable which should be an object (a blessed reference, which is a single value), but before I call a method on it I want to ensure it is to avoid the "unblessed reference" error that kills my program. I might try the ref built-in to get the class name:

   if( ref $maybe_object ) { ... }

There's a bug there. ref returns an empty string if the scalar isn't an object. It might return 0, a false value, and yes, some Perl people have figured out how to create a package named 0 just to mess with this. I might think that checking for defined-ness would work:

   if( defined ref $maybe_object ) { ... }

... but the empty string is also defined. I want all the cases where it is not the one value that means it's not a reference.

   unless( '' eq ref $maybe_object ) { ... }

This still doesn't tell me if I have an object. I know it's a reference, but maybe it's a regular data reference. The blessed function from Scalar::Util can help:

   if( blessed $maybe_object ) { ... }

This almost has the same problem as ref. blessed returns the package name if it's an object, and undef otherwise. I really need to check for defined-ness.

   if( defined blessed $maybe_object ) { ... }

Even if blessed returns undef, I still might have a hidden object. If the scalar is a tied variable, there's really an object underneath it, although the scalar acts as if it's a normal variable. Although I normally don't need to interact with the secret object, the tied built-in returns the secret object if there is one, and undef otherwise.

        my $secret_object = tied $maybe_tied_scalar;

        if( defined $secret_object ) { ... }

Once I have the secret object in $secret_object, I treat it like any other object.

Now I'm sure I have an object, but that doesn't mean I know which methods I can call. The isa function in the UNIVERSAL package supposedly can figure this out for me. It tells me if a class is somewhere in an object's inheritance tree. I want to know if my object can do what a Horse can do, even if I have a RaceHorse:

   if( UNIVERSAL::isa( $object, 'RaceHorse' ) {
           $object->method;
           }

...what if the RaceHorse class is just a factory for objects in some other class that I'm not supposed to know about? I'll make a new object as a prototype just to get its reference:

   if( UNIVERSAL::isa( $object, ref RaceHorse->new() ) {
           $object->method;
           }

A real object-oriented programmer doesn't care what sort of object it is as long as it can respond to the right method. I should use can instead:

   if( UNIVERSAL::can( $object, $method ) {
           $object->method;
           }

This doesn't always work either. can only knows about defined subroutine names, and only looks in the inheritance tree for them. It can't detect methods from AUTOLOAD or traits. I could override the can method to handle those, but I have to call it as a method (this works for isa too):

   if( $object->can( $method ) ) {
           $object->method;
           }

What if $object wasn't really an object? I just called a method on a non-object! I'm back to my original problem, but I don't want to use all of those tests I just went through. I'll fix this with an eval, which catches the error for non-objects:

   if( eval{ $object->can( $method ) } ) {
           $object->method;
           }

...but what if someone installed a __DIE__ handler that simply exit-ed instead of die-ing? Programmers do that sort of thing forgetting that it affects the entire program.

   $SIG{__DIE__} = sub { exit };

Now my eval tries to die because it caught the error, but the __DIE__ handler says exit, so the program stops without an error. I have to localize the __DIE__ handler:

   if( eval{ local $SIG{__DIE__}; $object->can( $method ) } ) {
           $object->method;
           }

If I'm the guy responsible for the __DIE__ handler, I could use $^S to see if I'm in an eval:

   $SIG{__DIE__} = sub { $^S ? die : exit };

That's solved it, right? Not quite. Why do all of that checking? I can just call the method and hope for the best. If I get an error, so be it:

   my $result = eval { $object->method };

Now I have to wrap all of my method calls in an eval. None of this would really be a problem if Perl were an object language. Or is it? The autobox module makes Perl data types look like objects:

   use autobox;

   sub SCALAR::println { print $_[0], "\n" }

   'Hello World'->println;

That works because it uses a special package SCALAR, although I need to define methods in it myself. I'll catch unknown methods with AUTOLOAD:

   sub SCALAR::AUTOLOAD {}

Or, I can just wait for Perl 6 when these things get much less murky because everything is an object.

Charting Data at the Bottom of the World

I have an odd job: I'm the only programmer for about 500 miles. I look after experiments on a remote Antarctic research station and look after the data they produce. As well as the scientific stuff knocking about, we have between 20 and 70 people, most of them keen on the weather. Either because we can't work if its windy, or can enjoy a spot of kite skiing if it's just windy enough, everyone here wants to know what's going on outside.

Luckily we have a few climate science experiments running, including a weather station. For a few years now, data from the weather station has been available on people's computers through a Perl Tk application and some slightly baroque shuttling of records between three different data servers and the network the office computers run on. All is well and good, and we leave it well alone, as it's worked well. Recently, a new experiment installed on the station provides an up-to-the-minute profile of wind speeds over the first 30 meters of the air. It's there to support research into interactions between snow and air in Antarctica, but it's also crucial information if you want to head out and whiz about behind a kite.

The data from this mast goes to a remote machine that allows users to VNC in to check its health, and logs this data to a binary format of its own making. People around the station have taken to logging in to this machine before heading out, which is probably not the best way keep the data rolling in without interruption. Rather than forbidding access to this useful source of local data, we decided to upgrade our weather display system to include the major parameters recorded by the mast.

Alas, while fairly nice to use, Tk is a bit fiddly and not exactly my cup of tea. Adding new displays to an existing application can be time-consuming, as you must re-learn the relations among each different widget, pane, and button. Added to this programming burden, even if we could find every copy of the application scattered around our network, we'd have to do so every time we added some other source of data. We settled instead on a complete rewrite as a CGI script and some automatically generated graphs. A fancier man than me might call that a three-tier application, but then, he'd probably be selling you something at the same time.

Mountains of Data

Before you can see what the weather is doing (beyond looking out of the window), you need to get at the raw numbers somehow. Ours are provided by state-of-the-art scientific instruments in state-of-the-art data formats; that is to say, partly as lines of ASCII data in columns, and partly as fixed-length records in a binary file. No matter, though. Perl and some friends from CPAN make fast work of building meaning from tumbled piles of data.

Before doing anything, I set up a couple of objects to hold some data values. Each set of observations has a class corresponding to the experiment that generated it. The classes also contain read_file factory methods that read a file and produce a list of observations. To make things as quick (to write) as possible, I used Class::Accessor to autogenerate get and set methods for my objects:

 # Current weather data
 package Z::Weather;
 use base qw(Class::Accessor);
 Z::Weather->mk_accessors( qw(time temp pressure wind dir) );

This automatically creates a new() method for Z::Weather. Call it as:

 my $weather = Z::Weather->new({time => $time,
                                temp => $temp,
                                pressure => $pres,
                                wind => $wind,
                                dir

It also generates get and set accessors for each field:

 # set
 $weather->temp(30);
 
 # get
 my $temp = $weather->temp();

(The "codename" used when shipping items to our station is Z, so I've used that as my little local namespace, too.)

From our mast, we have a number of observations taken at different heights, so I wanted a slightly more complicated representation, using a class to represent the mast and another to represent each level on the mast.

 package Z::Mast;
 use base qw(Class::Accessor);
 
 Z::Mast->mk_accessors(qw(time values));
 
 package Z::Mast::Level;
 use base qw(Class::Accessor);
 Z::Mast::Level->mk_accessors(qw(wind dir level));

Remember that Z::Mast::values will set and get a reference to an array of ::Level objects. If I wanted to enforce that, I could override the methods provided by Class::Accessor, but that would create work that I can get away without doing for this simple case.

Now that I know what the data will look like in Perl, I can wrench it from the covetous hands of our data loggers and turn it into something I can use.

First, I decided to deal with the plain ASCII file. This contains single lines, with the time of observation first, then white-space-separated values for temperature, pressure, wind speed, direction, and a few others that I don't care about. Z::Weather needs to use a couple of modules and add a couple of methods:

 use IO::All;
 
 sub from_file {
     my $class = shift;
     my $io    = io(shift);
     my @recs  = ();
     
     while (my $line = $io->readline()) {
         chomp($line);
         push @recs, $class->_line($line);
     }
     return @recs;
 }

I expect to call this as:

 my @weather_records = Z::Weather->fromfile("weather.data");

Using the IO::All module to access the files both makes it very easy to read the file and also allows calling code to instead supply an IO::All object of its own, or to call this method with a filehandle already opened to the data source. This will make it easy to obtain data from some other source; for instance, if the experiment changes to provide a socket from which to read the current values.

Parsing the data is the responsibility of another method, _line(), which expects lines like:

 2006 02 06 01 25  -10.4  983.2  23.5 260.1

 use DateTime;
 sub _line {
     my ($class, $line) = @_;
     my @vals = split /\s+/, $line;

     # extract time fields and turn into DateTime object
     my($y, $m, $d, $h, $min)
        = $line =~ /^(\d{4}) (\d\d) (\d\d) (\d\d) (\d\d)/;
 
     my $t = DateTime->new(year=>$y,month=>$m,day=>$d,hour=>$h,minute=>$min);
 
     # return a new Z::Weather record, using the magic new() method
     return $class->new({time => $t,
                         temp     => $vals[5],
                         pressure => $vals[6],
                         wind     => $vals[7],
                         dir      => $vals[8],  });
 }

split and Perl's magic make sense of the data points, and the DateTime module take cares of the details of when the record was produced. I find it much easier to turn any time-related value into a DateTime object at the soonest possible moment, so that the rest of my code can expect DateTime objects. It becomes easier to reuse in other projects. If you find yourself writing code to handle leap years every other day, then make using DateTime your number one new habit.

I deal with the mast data in a similar way, except that the other format is fixed-length binary records. The time of the recording is stored in the first four bytes as the number of seconds into an arbitrary epoch. I correct this into Unix time when creating its DateTime object. Values are stored as two-byte, network-endian unsigned shorts stored as hundredths of the recorded values. unpack() comes to my aid here.

 sub from_file {
   my $class = shift;
   my $io    = io(shift);
   my ($rec, @recs);
 
   while ($io->read($rec, 62) == 62) {
     push @recs, $class->_record($rec);
   }
   return @recs;
 }

 # map height of reading to offsets in binary record
 our %heights = qw(1 24  2 28 4 32  8 36  15 40  30 44);
 use constant MAST_EPOCH => 2082844800;
 
 sub _record {
   my ($class, $rec) = @_;

   # extract the time as a 4 byte network order integer, and correct epoch
   my $crazy_time = unpack("N", $rec);
   my $time       = DateTime->from_epoch(epoch=>$crazy_time-MAST_EPOCH);

   # then a series of (speed, dir) 2 byte pairs further into the record
   my @vals;
   foreach my $offset (sort values %heights) {
     my ($speed, $dir) = unpack("nn", substr($rec, $offset));
     push @vals,
       Z::Mast::Level->new({wind=>$speed*100,
                            dir => $dir*100,
                            level=>$heights{$offset}});
   }
   return $class->new({time => $time,
                       values => \@vals});
 }

Again, I can call this using any one of the types supported by IO::All. Again, I wield DateTime to my advantage to turn a time stored in an unusual epoch quickly into an object which anything or anyone else can understand. There are a few magic numbers here, but that's what you end up with when you deal with other people's crazy file formats. The key thing is to record magic numbers in one place, to allow other people to change them if they need to, both in your code and from their own code (hence the our variable), and finally, to let values pass from undocumented darkness into visible, named objects as soon as possible.

Displaying Data

I now have hold of the weather data and have forced it into a form that I can follow. Now I get to show it to someone else. I did this in two different ways: as raw data through a web page and as a pre-generated chart embedded in the page.

In each case, the code has to read in files to obtain the necessary data:

 my @weather_records = Z::Weather->from_file('weather.data.dat');

Then it needs to produce the web page:

 use Template;
 my $template = Template->new();

 print "Content-type: text/html\n\n";
 
 $template->process(\*DATA, {
                       now => $weather_records[-1],
                       records => \@weather_records,
                             })
    || die "Could not process template: ".$template->error()."\n";

This isn't really all that interesting. In fact, it looks almost like this does nothing at all. I've pulled in the Template module, told it to build and output a template defined after the __END__ of the script, and given it two template variables to play with. The template looks something like:

 __END__
 <html><head><title>Weather</title></head>
 <body>
 <h2>Latest weather data at [% now.time %]<a name="/h2">
 
 <P>T: [% now.temp %] &deg;C
    P: [% now.pressure %] kPa
    W: [% now.wind %] kts
    D: [% now.dir %] &deg;</p>
 
 <P><img src="/weather_chart.png"><br>
    <img src="/mast_chart.png"</p>

 <table>
 <tr><th> Time </th><th> Temp </th><th> Wind </th></tr>
 [% FOREACH rec IN records %]
 <tr>
  <td>[% rec.time %]</td>
  <td>[% rec.temp %]</td>
  <td>[% rec.wind %]</td>
 </tr>
 [% END %]
 </table>
 </body></html>

The template uses the syntax of the Template-Toolkit, a general-purpose templating framework. It's useful because it allows the separation of display and formatting of data from the code that generates it. There's no Perl code in the template, and no HTML will appear in any of my Perl code. While the output generated now is ugly and basic, it will be easy to make it flashy later, once I have the program working, without having to change anything in the program itself to do so. As I've prepared our data carefully as objects with sensible methods, I can just hand a bunch of these over to the template and let it suck out whatever it wants to show.

Pretty Pictures

Producing the charts is, again, a simple business (by now, the theme of this article should be emerging). Gone are the days when you'd have to scratch your head figuring out how to draw lines and plot points; gone even are the days when you have to bang your head hard against the confused API of some long-forgotten module. Taking the mast values as an example, I first need to read in the data:

 my @mast_values = Z::Mast->from_file('mast.data.dat');

Because old weather is old news, I throw away any values older than three hours, using DateTime and DateTime::Duration methods in a grep:

 use DateTime;
 use DateTime::Duration;
 
 my $now = DateTime->now();
 my $age = DateTime::Duration->new(hours => 3);
 
 @mast_values = grep { $_->time + $age > $now } @mast_values;

This is so, so much easier than fiddling around with epochs and 3*3600 all over the place. If you find yourself writing 3600 anywhere in your code, you should be using DateTime::Duration instead. Next, I feed the data points into the Chart::Lines module, a part of the Chart distribution. I use this in three phases. First, I create a new Chart and specify how large the resulting graphic should be:

 use Chart::Lines;
 my $chart = Chart::Lines->new($x_size, $y_size);

Then I set up a few options to tweak how the chart will display:

 $chart->set(
    legend          => 'none',
    xy_plot         => 'true',
    grey_background => 0,
    y_label         => 'Wind kts',
    x_label         => 'Hours ago',
    colors          => {
      y_label    => [0xff, 0xee, 0xee],
      text       => [0xff,0xee,0xff],
      dataset0   => [0xff,0,0],
      dataset1   => [0,0xff,0xff],
      dataset2   => [0,0,0xff],
      background => [0x55, 0x00, 0x55],
                },
    );

These are mostly self-explanatory; the Chart documentation covers them in detail. I set xy_plot to true so that the module will use the first dataset as the x values and all of the other datasets as the y values for a line. I set a bunch of rather bright colors, to keep my avid customers cheerful, and set the text used to label the chart.

 my @labels = map {($now->epoch - $_->time->epoch) / 60} @mast_values;

Finally, I used a series of map expressions to extract x and y values from the data. One turns the DateTime times into a number of minutes ago. These values are the x values. y values are the appropriate parameters extracted from the nested Z::Mast and Z::Mast::Label objects. The rest of the code provides the data to the plotting method of the chart, directing it to write out a .png file (Figure 1).

 $chart->png("mast.png",
               [ \@labels,
                [map {$_->values()->[0]->wind} @mast_values],
                [map {$_->values()->[1]->wind} @mast_values],
                [map {$_->values()->[2]->wind} @mast_values],
                  ]);

the resulting chart
Figure 1. The resulting chart

All I need now is a working HTTP server and a crontab entry or two to run the graphic generation programs. It is possible to use the Chart modules to generate CGI output directly using the Chart::cgi method, but I found that this was too slow once lots of different clients accessed the weather data at the same time. It was a simple task to instead switch to a crontab-based approach for the graphs, with a CGI script still providing real-time access to the current values.

Conclusions

The Chart family of modules provides more than just an x-y plot. Pie, bar, Pareto, and mountain charts, amongst others, are available through the same API as I discussed in this article. They are just as easy to whip into being to satisfy even the most demanding of data consumers.

The Template Toolkit is used mainly for more complicated websites and content management systems, but it will simplify the production of simple sites and pages, allowing you to concentrate on the detail of the problem by separating data and its presentation. Even though a problem is simple and allows a fast solution, you can reach your goal faster still by pulling in big tools to do little jobs.

As for the DateTime module, I simply wouldn't go anywhere without it. These days, I find myself automatically typing use DateTime; along with warnings and strict at the head of every Perl program I write.

Class::Accessors makes the creation of data representation objects faster than typing in a C struct, provides some level of documentation about what the data you're dealing with, and allows for reuse. You could just stick everything into layers of nested hashes and arrays, but this is a certain path to eventual confusion. Class::Accessors will keep you sane and save your fingers at the same time.

IO::All should be a part of your day-to-day toolkit; the new idioms it provides will soon see you using it everywhere, even in one-liners.

One of the many joys of programming lies in the satisfaction we receive when we make someone's life that little bit better. Perl makes it easy, fast, and fun for us to tread that path. Perl's greatest strength, the rock upon which its greatness is founded, is the speed with which we can take a problem, or a cool idea, and structure our half-formed thoughts into a soundly built solution.

Download the example code for this article.

Making Menus with wxPerl


In a previous article about wxPerl published on Perl.com, Jouke Visser taught the very basics of wxPerl programming. In this article, I will continue with Jouke's work, explaining how to add menus in our wxPerl applications. I will cover the creation, editing, and erasure of menus with the Wx::Menu and Wx::MenuBar modules, and also will show examples of their use.

Conventions

I assume that you understand the wxPerl approach to GUI programming, so I won't explain it here. The following code is the base for the examples in this article:

use strict;
use Wx;

package WxPerlComExample;

use base qw(Wx::App);

sub OnInit {
    my $self  = shift;
    my $frame = WxPerlComExampleFrame->new(undef, -1, "WxPerl Example");

    $frame->Show(1);
    $self->SetTopWindow($frame);

    return 1;
}

package WxPerlComExampleFrame;

use base qw(Wx::Frame);

use Wx qw( 
    wxDefaultPosition wxDefaultSize wxDefaultPosition wxDefaultSize wxID_EXIT
);

use Wx::Event qw(EVT_MENU);

our @id = (0 .. 100); # IDs array

sub new {
    my $class = shift;
    my $self  = $class->SUPER::new( @_ );

    ### CODE GOES HERE ###

    return $self;
}

### PUT SUBROUTINES HERE ###

package main;

my($app) = WxPerlComExample->new();

$app->MainLoop();

@id is an array of integer numbers to use as unique identifier numbers. In addition, the following definitions are important:

  • Menu bar: The bar located at the top of the window where menus will appear. This is a particular instance of Wx::MenuBar.
  • Menu: A particular instance of Wx::Menu.
  • Item: An option inside of a (sub)menu.

A Quick Example

Instead of wading through several pages of explanation before the first example, here is a short example that serves as a summary of this article. Note that I have divided it in two parts. Add this code to the base code in the WxPerlComExampleFrame constructor:

# Create menus
my $firstmenu = Wx::Menu->new();
$firstmenu->Append($id[0], "Normal Item");
$firstmenu->AppendCheckItem($id[1], "Check Item");
$firstmenu->AppendSeparator();
$firstmenu->AppendRadioItem($id[2], "Radio Item");

my $secmenu   = Wx::Menu->new();
$secmenu->Append(wxID_EXIT, "Exit\tCtrl+X");

# Create menu bar
my $menubar   = Wx::MenuBar->new();
$menubar->Append($firstmenu, "First Menu");
$menubar->Append($secmenu, "Exit Menu");

# Attach menubar to the window
$self->SetMenuBar($menubar);
$self->SetAutoLayout(1);

# Handle events only for Exit and Normal item
EVT_MENU( $self, $id[0], \&ShowDialog );
EVT_MENU( $self, wxID_EXIT, sub {$_[0]->Close(1)} );

Insert the following code into the base code at the line ### PUT SUBROUTINES HERE ###.

use Wx qw(wxOK wxCENTRE);

# The following subroutine will be called when you click in the normal item

sub ShowDialog {
  my($self, $event) = @_;
  Wx::MessageBox( "This is a dialog", 
                  "Wx::MessageBox example", 
                   wxOK|wxCENTRE, 
                   $self
               );
}

Run this example to see something like Figures 1 and 2.

a menu with complex sub-items
Figure 1. A menu with complex sub-items

a menu with a single sub-item
Figure 2. A menu with a single sub-item

Programming Menus

To add a menu to your wxPerl application, you must know how to use two Perl modules that come with WxPerl: Wx::MenuBar and Wx::Menu. Wx::MenuBar creates and manages the bar that contains menus created with Wx::Menu. There is also a third module involved: Wx::MenuItem. This module, as its name implies, creates and manages menu items. You usually don't need to use it, because almost all of the operations you need for a menu item are available through Wx::Menu methods.

Using Wx::Menu

Creating a menu with Wx::Menu is as easy as:

my $menu = Wx::Menu->new();

Now $menu is a Wx::Menu object. WxPerl has five types of items. The first is the normal item, upon which you can click to get a response (a dialog or something else). The second is the check item, which has the Boolean property of being checked or not (independent of another check items). The third item is the radio item, which is an "exclusive check item;" if you check a particular radio item, other radio items in its radio group get unchecked instantly. The fourth type of item is the separator, which is just a straight line that acts as a barrier that separates groups of similar items inside of a menu. The fifth type is the submenu, an item that expands another menu when the mouse cursor is over it.

Setting Up Menu Items

To create a normal item for your menu, write:

$menu->Append($id, $label, $helpstr);

where $id is an unique integer that identifies this item, $label is the text to display on the menu, and $helpstr is a string to display in the status bar. (This last argument is optional.) Note that every menu item must have an unique identifier number in order to be able to operate with this item during the rest of the program. (From now on, $id will denote the unique identifier number of a menu item.)

To create a check or radio item, the methods are analogous to Append--AppendCheckItem and AppendRadioItem, respectively. Add a separator with the AppendSeparator method; it does not expect arguments. Create a submenu with the AppendSubMenu method:

$menu->AppendSubMenu($id, $label, $submenu, $helpstr);

where $submenu is an instance to another Wx::Menu object. (Don't try to make that a submenu be a submenu of itself, because the Universe will crash or, in the best case, your program won't execute at all.)

While append methods add menu items in the last position of your menus, Wx::Menu gives you methods to add menu items at any position you want. For instance, to add a normal item at some position in a menu:

$menu->Insert($pos, $id, $label, $helpstr);

where $pos is the position of the item, starting at 0. To add a radio item, check item, or separator, use the InsertRadioItem, InsertCheckItem, or InsertSeparator methods. As usual, the latter takes no arguments. To insert a submenu, use the InsertSubMenu method:

$menu->InsertSubMenu($pos, $id, $label, $submenu, $helpstr);

You can also insert an item at the first position by using the Prepend method:

$menu->Prepend($id, $label, $helpstr);

PrependRadioItem, PrependCheckItem, and PrependSeparator methods are also available. As you might expect, there's a PrependSubMenu method that works like this:

$menu->PrependSubMenu($id, $label, $submenu, $helpstr);

Sometimes, a menu grows to include too many menu items, and then it's impractical to show them all. For this problem, Wx::Menu has the Break method. When called, it causes Wx to place subsequently appended items into another column. Call this method like so:

$menu->Break();
Menu Item Methods

Once you have created your items, you need some way to operate on them, such as finding information about them through their identifier numbers, getting or setting their labels or help strings, enabling or disabling them, checking or unchecking them, or removing them. For example, you may want to retrieve some specific menu item in some point of your program. To do this, use the FindItem method in either of two ways:

my $menuitem_with_the_given_id = $menu->FindItem($id);
my ($menuitem, $submenu)        = $menu->FindItem($id);

where $menuitem is the corresponding Wx::MenuItem object with the identifier $id, and $submenu is the (sub)menu to which $menuitem belongs. You can also retrieve a menu item through the FindItemByPosition method (but remember that positions start at 0):

my $menuitem = $menu->FindItemByPosition($pos);

Wx::Menu provides methods to get or set properties of menu items. To set a property, there are two methods: SetLabel and SetHelpString. A SetLabel call might be:

$menu->SetLabel($id, $newlabel);

SetHelpString works similarly:

$menu->SetHelpString($id, $newhelpstr);

To retrieve the label or help string of a particular item, use the GetLabel and GetHelpString methods. Both methods expect the menu item identifier number as the sole argument.

Every menu item has an enabled property that makes an item available or unavailable. By default, all items are enabled. To enable or disable a particular menu item, use the Enable method:

$menu->Enable($id, $boolean);

where $boolean is 0 or 1, depending if you want to disable or enable it, respectively. Maybe your next question is how to check if a menu item is enabled; use the IsEnabled method:

$menu->IsEnabled($id);

This returns TRUE or FALSE, depending on the status of the menu item.

Radio items and check items have the checked property that indicates the selection status of the item. By default, no check item is checked at the start of the execution of your program. For radio items, the first one created is checked at the start of execution. Use the Check method to check or uncheck a radio or check item:

$menu->Check($id, $boolean);

To determine if a menu item is checked, use IsChecked:

$menu->IsChecked($id);

This method, as does IsEnabled, returns TRUE or FALSE.

It's also possible to get the number of menu items your menu has. For this, use the GetMenuItemCount method:

$menu->GetMenuItemCount();

note that if @args is the argument's array, then $menu->Append(@args) and $menu->Insert($menu->GetMenuItemCount(), @args) are the same.

Finally, it's important to know that there are three ways to remove an item from a menu (honoring Larry Wall's phrase: "There's more than one way to do it"). The first is the Delete method, which just kills the menu item without compassion:

$menu->Delete($id);

This method returns nothing. Be careful--WxWidgets documentation says that the Delete method doesn't delete a menu item that's a submenu. Instead, the documentation recommends that you use the Destroy method to delete a submenu. In wxPerl, this isn't true. Delete is certainly capable of deleting a submenu, and is here equivalent to the Destroy method. I don't know the reason for this strange behavior.

The Destroy method looks like this:

$menu->Destroy($id);

If you want to remove an item but not destroy it, then the Remove method is for you. It allows you to store the menu item that you want to delete in a variable for later use, and at the same time delete it from its original menu. Use it like so:

my $removed_item = $menu->Remove($id);

Now you have your menu item with the identifier $id in the $removed_item variable (it now contains a Wx::MenuItem object). You can now use this variable to relocate the removed item into another menu with the append methods. For example:

$other_menu->Append($removed_item);

does the same thing as:

$other_menu->Append($id_removed_item, $title_removed_item, 
    $helpstr_removed_item);

but in a shorter way.

Finally, it's useful to be able to remove a submenu's menu item. You can't use the Destroy, Delete, or Remove methods, because they don't work. Instead, you need to do something like this:

my ($mitem, $submenu) = $menu->FindItem($mitem_id);

where $mitem_id is the identifier number of the submenu's menu item you're looking for. $submenu is a Wx::Menu object, just as $menu is, and hence you can use all the methods mentioned here, so the only thing you have to do to remove $mitem from $submenu is:

$submenu->Delete($mitem_id);

As the good reader that I am sure you are, you already have realized that this isn't the only thing you can do with the $submenu object. In fact, you can now add new menu items to your submenu, delete another menu item, and in general do everything mentioned already.

Using Wx::MenuBar

You have created your menus and obviously want to use them. The last step to get the job done is to create the menu bar that will handle your menus. When you want to create a menu bar, the first step is to enable your code to handle menu events. This is the job of the Wx::Event module:

use Wx::Event qw(EVT_MENU)

Now create a Wx::MenuBar object:

my $menubar = Wx::MenuBar->new();

This object will contain all of the menus that you want to show on your window. To associate a menu bar with a frame, call the SetMenuBar method from Wx::Frame:

$self->SetMenuBar($menubar);

where $self is the Wx::Frame object inherited in WxPerlComExampleFrame's constructor. Note that if your application has MDI characteristics, or has many windows, then you have to take in account that Wx first sends menu events to the focused window. (I won't cover this issue in this article, so for more information, review the WxWidgets documentation.) Finally, be sure to call the EVT_MENU subroutine as many times as you have menu items that execute some action when clicked:

EVT_MENU($self, $menu_item_id, \&subroutine);

where $self is the object of your package's new method, $menu_item_id is the unique identifier of the menu item involved, and subroutine is the name of the subroutine that will handle the click event you want to catch.

Setting Up Menus

The first thing to do once you have created your menu bar is to attach your menus to the menu bar. There are two methods for this: Append and Insert. Append, as you might expect, attaches a menu in the last position:

$menubar->Append($menu, $label);

where $menu is the menu created in the previous section and $label is the name to display for this menu in the menu bar. To insert a menu in an arbitrary position, use the Insert method:

$menubar->Insert($pos, $menu, $label);

where $pos is the position of your menu, starting at 0.

Menu Methods

Wx::MenuBar provides some methods that are also present in Wx::Menu and work in the same way. This methods are Check, Enable, FindItem, GetLabel, GetHelpString, SetLabel, SetHelpString, IsChecked, and IsEnabled. Besides these methods, Wx::MenuBar has its own set of methods to manage the properties of the menu bar. For example, as a menu item, a menu has its own enabled property, which you toggle with the EnableTop method:

$menubar->EnableTop($pos, $boolean);

where $pos is the position of your menu (starting at 0) and $boolean is TRUE or FALSE, depending on whether you want that menu enabled. Note that you can use this method only after you attach your menu bar to the window through the SetMenuBar method.

Wx::MenuBar has methods to retrieve an entire menu or menu item given its title or (menu title, menu item label) pair, respectively. In the first case, use the code:

$menu_with_the_given_title = $menubar->FindMenu($title);

In the second case:

$menu_item = $menubar->FindMenuItem($menu_title, $menu_item_label);

In both cases, the returned variables are Wx::Menu objects. You can also retrieve a menu if you provide its position (starting at 0):

$menu_with_the_given_pos = $menubar->GetMenu($pos);

As in the Wx::Menu case, Wx::MenuBar provides methods to set or get the label of a specific menu and to retrieve the number of menus in a menu bar. Those methods are SetLabelTop, GetLabelTop, and GetMenuCount respectively. Use them like this:

$menu->SetLabelTop($pos, $label);
my $menu_label = $menu->GetLabelTop($pos);
my $num_menu   = $menu->GetMenuCount();

where $pos is the position of the menu and $label is the new label that you want to put on your menu. Note that GetLabelTop's result doesn't include accelerator characters inside the returned string.

Finally, Wx::MenuBar gives two more choices to remove a menu. The first method is Replace, which replaces it with another menu:

$menubar->Replace($pos, $new_menu, $label);

where $pos is the position of the menu to remove, $new_menu is the new menu that will be in the $pos position, and $label is the label to display on the menu bar for $new_menu. The second choice is to remove a menu, just by removing it with the Remove method:

my $removed_menu = $menubar->Remove($pos);

Remove returns the $removed_menu object, so if you need it in the future, it'll be still there waiting for you.

Example

With all of that explained, I can show a full, working example. As before, add this code to the base code in the blank spot in the WxPerlComExampleFrame constructor.

# Create menus
# Action's sub menu
my $submenu = Wx::Menu->new();
$submenu->Append($id[2], "New normal item");
$submenu->Append($id[3], "Delete normal item");
$submenu->AppendSeparator();
$submenu->Append($id[4], "New check item");
$submenu->Append($id[5], "Delete check item");
$submenu->AppendSeparator();
$submenu->Append($id[6], "New radio item");
$submenu->Append($id[7], "Delete radio item");

# Disable items for this submenu
for(2..7) {
    $submenu->Enable($id[$_], 0);
}

# Actions menu
my $actionmenu = Wx::Menu->new();
$actionmenu->Append($id[0], "Create Menu"); # Create new menu
$actionmenu->Append($id[1], "Delete Menu"); # Delete New Menu
$actionmenu->AppendSeparator();
$actionmenu->AppendSubMenu($id[100], "New Item", $submenu); # Create item submenu
$actionmenu->AppendSeparator();
$actionmenu->Append(wxID_EXIT, "Exit\tCtrl+X"); # Exit

# At first, disable the Delete Menu option
$actionmenu->Enable($id[1], 0);

# Create menu bar
$self->{MENU} = Wx::MenuBar->new();
$self->{MENU}->Append($actionmenu, "Actions");

# Attach menubar to the window
$self->SetMenuBar($self->{MENU});
$self->SetAutoLayout(1);

# Handle events
EVT_MENU($self, $id[0], \&MakeActionMenu);
EVT_MENU($self, $id[1], \&MakeActionMenu);
EVT_MENU($self, $id[2], \&MakeActionNormal);
EVT_MENU($self, $id[3], \&MakeActionNormal);
EVT_MENU($self, $id[4], \&MakeActionCheck);
EVT_MENU($self, $id[5], \&MakeActionCheck);
EVT_MENU($self, $id[6], \&MakeActionRadio);
EVT_MENU($self, $id[7], \&MakeActionRadio);

EVT_MENU($self, wxID_EXIT, sub {$_[0]->Close(1)});

This code creates a menu called Actions with the following options inside:

  • Create Menu: When a user clicks this option, the program creates a new menu called New Menu at the right side of the Actions menu. The Create Menu option is enabled by default, but creating the menu disables this option.
  • Delete Menu: Deletes the menu created with Create Menu. This option is disabled by default and is enabled when New Menu exists.
  • New normal item: This option creates the Normal item option on New Menu when it exists. It is disabled by default.
  • Delete normal item: Deletes Normal item when it exists. It is disabled by default.
  • New check item: Creates the Check item option on New Menu when it exists. It is disabled by default. Check item is unchecked by default.
  • Delete check item: Deletes Check item when it exists. It is disabled by default.
  • New radio item: Creates the Radio item option on New Menu when it exists. It is disabled by default. Radio item is checked by default.
  • Delete radio item: Deletes Radio item when it exists. It is disabled by default.
  • Exit: Exits the program.

Once the code has created the menu, it attaches the menu to the menu bar saved on $self->{MENU}, then calls the EVT_MENU subroutine eight times to handle all of the menu events from Action's menu items. Add the following code to the base code where it says ### PUT SUBROUTINES HERE ###:

# Subroutine that handles menu creation/erasure
sub MakeActionMenu {
    my($self, $event) = @_;

    # Get Actions menu
    my $actionmenu    = $self->{MENU}->GetMenu(0);

    # Now check if we have to create or delete the New Menu
    if ($self->{MENU}->GetMenuCount() == 1) {
        # New Menu doesn't exist

        # Create menu
        my $newmenu = Wx::Menu->new();
        $self->{MENU}->Append($newmenu, "New Menu");       

        # Disable and Enable options
        $actionmenu->Enable($id[0], 0); # New menu
        $actionmenu->Enable($id[1], 1); # Delete menu
        $actionmenu->Enable($id[2], 1); # New normal item
        $actionmenu->Enable($id[3], 0); # Delete normal item
        $actionmenu->Enable($id[4], 1); # New check item
        $actionmenu->Enable($id[5], 0); # Delete check item
        $actionmenu->Enable($id[6], 1); # New radio item
        $actionmenu->Enable($id[7], 0); # Delete radio item
    } else {
        # New Menu exists

        # Remove menu
       $self->{MENU}->Remove(1);

        # Enable and disable options
        $actionmenu->Enable($id[0], 1);

        for(1..7) {
               $actionmenu->Enable($id[$_], 0);
        }
    }

    return 1;
}

# Subroutine that handles normal item creation/erasure
sub MakeActionNormal {
    my($self, $event) = @_;
    # Check if New Menu exists
    if($self->{MENU}->GetMenuCount() == 2) {
        # New menu exists

        # Get Action menu
        my $actionmenu = $self->{MENU}->GetMenu(0);
        my $newmenu    = $self->{MENU}->GetMenu(1);

        # Check if we have to create or delete a menu item
        if($actionmenu->IsEnabled($id[2])) {
            # Create normal menu item
            $newmenu->Append($id[50], "Normal item");           

            # Disable and Enable options
            $actionmenu->Enable($id[2], 0);
            $actionmenu->Enable($id[3], 1);
        } else {
            # Delete menu item
               $newmenu->Delete($id[50]);

            # Enable and disable options
            $actionmenu->Enable($id[2], 1);
            $actionmenu->Enable($id[3], 0);
        }
    }

    return 1;
}

# Subroutine that handles check item creation/erasure
sub MakeActionCheck {
    my($self, $event) = @_;

    # Check if New Menu exists
    if($self->{MENU}->GetMenuCount() == 2) {
        # New menu exists

        # Get Action menu
        my $actionmenu = $self->{MENU}->GetMenu(0);
        my $newmenu    = $self->{MENU}->GetMenu(1);

        # Check if we have to create or delete a menu item
        if($actionmenu->IsEnabled($id[4])) {
            # Create check item
               $newmenu->AppendCheckItem($id[51], "Check item");

           # Disable and Enable options
           $actionmenu->Enable($id[4], 0);
           $actionmenu->Enable($id[5], 1);
        } else {
           # Delete menu item
           $newmenu->Delete($id[51]);

              # Enable and disable options
              $actionmenu->Enable($id[4], 1);
              $actionmenu->Enable($id[5], 0);
        }
    }

    return 1;
}

# Subroutine that handles radio item creation/erasure

sub MakeActionRadio {
    my($self, $event) = @_;

    # Check if New Menu exists
    if($self->{MENU}->GetMenuCount() == 2) {
        # New menu exists

        # Get Action menu
        my $actionmenu = $self->{MENU}->GetMenu(0);
        my $newmenu    = $self->{MENU}->GetMenu(1);

        # Check if we have to create or delete a menu item
        if ($actionmenu->IsEnabled($id[6])) {
               # Create radio item
              $newmenu->AppendRadioItem($id[52], "Radio item");

              # Disable and Enable options
              $actionmenu->Enable($id[6], 0);
              $actionmenu->Enable($id[7], 1);
        } else {
              # Delete menu item
              $newmenu->Delete($id[52]);

              # Enable and disable options
              $actionmenu->Enable($id[6], 1);
              $actionmenu->Enable($id[7], 0);
        }
    }

    return 1;
}

The MakeActionMenu subroutine handles events for the New Menu and Delete Menu items. It first gets the Actions menu and checks whether the New Menu exists by retrieving the number of menus attached to the $self->{MENU} menu bar. If the new menu doesn't exist, the number of menus in the menu bar is equal to 1, and the subroutine then creates New Menu. If it exists, the subroutine deletes New Menu.

The MakeActionNormal, MakeActionCheck, and MakeActionRadio subroutines are almost identical. They differ only in the involved identifier numbers. These subroutines handle events for New normal item, Delete normal item, New check item, Delete check item, New radio item, and Delete radio item, respectively. They first check if New Menu exists (the number of menus attached to the menu bar is equal to 2). If so, they check if the options to create normal, check, or radio items are enabled, respectively. If the corresponding option is enabled, then the corresponding item doesn't exist on New Menu, and the subroutine creates it. If the option to create an item is disabled, then that item exists on New Menu and hence it must be deleted. If New Menu doesn't exist, the subroutines do nothing. Figure 3 shows how there are no options available if New Menu does not exist, and Figure 4 shows New Menu with two options added.

no available options without New Menu
Figure 3. No available options without New Menu

New Menu has menu options
Figure 4. New Menu has menu options

Conclusion

As this article has shown, menu programming with wxPerl is an extremely simple task. Wx::MenuBar and Wx::Menu's methods are very easy to use and remember. If you understood this article, you can do anything possible with menus in your wxPerl programs.

I have covered almost all of the available methods in Wx::Menu and Wx::MenuBar. I left out some methods related to pop-up menus, but I hope to cover these topics in future articles. WxPerl is a really great module, but its lack of adoption is due to its severe lack of documentation. This situation must be reversed, and this article is a small contribution to that cause.

See Also

Visit the home of the Perl programming language: Perl.org

Sponsored by

Powered by Movable Type 5.02