December 2001 Archives

This Week on Perl 6 (23 - 29 December 2001)

Notes

You can subscribe to an email version of this summary by sending an empty message to perl6-digest-subscribe@netthink.co.uk.

This summary, as with past summaries, can be found in here. Please send additions, submissions, corrections, kudos, and complaints to bwarnock@capita.com.

For more information on the Perl 6 and Parrot development efforts, visit dev.perl.org and parrotcode.org.

It was a light week due to the holidays. There were 52 messages across 26 threads, with 14 authors contributing. About half were directly related to patch submission.

JIT

The bulk of the non-patch postings this week centered around the JIT. Nothing earth-shattering, although problems with gcc 2.96 under Red Hat Linux have shut things down for that configuration.

Output

Dan Sugalski provided primitives for output.

Parroty Bits

The Perl Development Grant Fund crested 25%.


Bryan C. Warnock

This Week on Perl 6 (16 - 22 December 2001)

Notes

You can subscribe to an email version of this summary by sending an empty message to perl6-digest-subscribe@netthink.co.uk.

This summary, as with past summaries, can be found in here. Please send additions, submissions, corrections, kudos, and complaints to bwarnock@capita.com.

For more information on the Perl 6 and Parrot development efforts, visit dev.perl.org and parrotcode.org.

There were 110 messages across 32 threads, with 32 authors contributing.

The Perl Development Grant Fund

The Perl Foundation is raising money to sponsor Damian "Mr. Language" Conway and Dan "Mr. Internals" Sugalski. We're about a quarter of the way there, so if you don't know what to do with the $25 you received from Aunt Bertha for Christmas, now you do.

A JIT Compiler for Parrot

Daniel Grunblatt has an early JIT compiler in CVS now. Although it currently works only under Linux x86, it's certainly an impressive demonstration.

Perl I/O

Melvin Smith asked whether Nick Ing-Simmons Perl I/O layer was going to be used for Parrot. Given Dan's desire to support asynchronous I/O, there were several conflicting opinions. The final result, however, was that Melvin was going to start from scratch, using Nick's Perl I/O code as a basis.

MiniPerl

Jeff Goff has been busy with MiniPerl, one of the languages distributed with Parrot.

Setline

There was a brief debate about whether to inline or offline setline operations . An out-of-band index seems to be the current direction.

Exporter

Brent Dax posted his thoughts on Perl 6's Exporter module. Michael Schwern pitched in his objections.

Parroty Bits

The Perl and Parrot communities wish you and yours a happy and safe holiday season.


Bryan C. Warnock

This Week on Perl 6 (9 - 15 December 2001)

Notes

You can subscribe to an email version of this summary by sending an empty message to perl6-digest-subscribe@netthink.co.uk.

This summary, as with past summaries, can be found in here. Please send additions, submissions, corrections, kudos, and complaints to bwarnock@capita.com.

For more information on the Perl 6 and Parrot development efforts, visit dev.perl.org and parrotcode.org.

There were 137 messages across 44 threads, with 41 authors contributing.

Slice Context

(10 posts) Piers Cawley gave a huge list of slice examples, wondering what the expected context would be.

Damian Conway's first, second, and third answers and explanations.

Make make Make

(33 posts) There were several threads centered around getting make to work everywhere - with nmake being the most problematic.

Jaen Saul had not one, but two major threads on nmake incompatibilities in the Parrot makefile, causing a failed build on Win32. Both Jeff Goff and Robert Spier are working on a complete Perl replacement for the build process. (With Jeff having already committed a preliminary one.)

  • Jaen Saul provided a temporary solution one of his problems.
  • Andy Dougherty and Garrett Goebel both tentatively fixed some of the other Win32 problems.
  • Robert Spier patched distclean to keep any CVS-related files.

Performance Patches

(5 posts) Jeff Goff committed an early version of a Parrot optimizer, while Gregor Purdy submitted a simple JIT runtime loop for experimentation.

Aggregates

(1 post) Jeff Goff also turned in the aggregate keys code, leading the way for development on arrays and hashes.

Bytecode Portability

(7 posts) Bryan C. Warnock posted his thoughts on Parrot bytecode.

Parroty Bits

Dave Mitchell has finally been given a PDD number (7) for the coding standards, so they should be up on dev.perl.org soon.


Bryan C. Warnock

Building a Bridge to the Active Directory

Introduction

Active Directory of Windows 2000's directory service, allowing organizations to keep and share information about networked resources and users. One significant feature of the Active Directory is that it is LDAP-compliant. Unfortunately, it is still very difficult to access the Active Directory without using the Active Directory Services Interface (ADSI). As a COM component, ADSI is very partial to the Windows operating system.

What if you want to access information in your organization's Active Directory from a host that is not running Windows? One option is to build a piece of middleware (a daemon) to bridge a non-Windows host to the Active Directory. This article describes how to build such a daemon, and how to build a simple client would communicate with that daemon.

XML-RPC and Active Perl to the Rescue

XML-RPC is a mechanism that enables platform-independent and language-independent distributed computing. It serializes function calls and their associated arguments into an XML stream, and transports the stream via the ubiquitous HTTP protocol. Although it might be an over-simplification, XML-RPC provides some of the power of CORBA without the associated pain.

The aim of this article is to walk you through the construction of a daemon that accesses data from the Active Directory using ADSI and passes on this data to other non-Windows clients via XML-RPC. This daemon must, of necessity, run on a Windows host.

A daemon isn't much good unless there is a client with which to communicate. As such, I will also walk you through the construction of a simple client application.

Since Visual Basic is the de facto standard for writing Windows applications, it would seem natural to build the daemon in Visual Basic. However, I'm just not comfortable with Visual Basic, even though I had used it on several projects. Fortunately, ActivePerl from ActiveState has a very well developed COM interface that can be used to interact with ADSI.

Before we get into the details of our Active Directory Daemon and Active Directory Client, here are the links to the source code, so that you can refer to it as we discuss the code and the logic behind it.

Active Directory Daemon: activedirectory_daemon.pl
Active Directory Client: activedirectory_client.pl

The Active Directory Daemon

Our daemon will be able to do the following:

a. Authenticate a user against the Active Directory using the user ID and password. A successful login will result in the salient data (e.g. surname, given name and email address) associated with the user ID being returned.

b. Return the chain of command (the user's immediate boss, the immediate boss's immediate boss, etc).

First, we need to load the modules below, and we also invoke the strict pragma.

  use strict;
  use Win32::OLE;
  use Win32::OLE::Const 'Microsoft ActiveX Data Objects';
  use Frontier::Daemon;

The first two are part of Active Perl, while the third module is available from CPAN.

The AuthenticateUser subroutine authenticates the user against the active directory.

  sub AuthenticateUser {
        my $strUserID       = shift || "someuserid"; 
        my $strUserPassword = shift || "Somepassword1";
        my $strADsPath      = shift || 
           'LDAP://OU=somedivision,OU=somedepartment,DC=someuniversity,DC=edu';
        my $strDomain       = shift || "\@someuniversity.edu";
        my $strAttributeName = "userPrincipalName";
        my $strAttributeValue = $strUserID;

We've assigned default values to some of the scalars above to provide an example of how arguments will be used at various points in the process of querying the Active Directory. There are several ways of interacting with ADSI. In this bit of code, we bind directly to ADSI. Later on, we will show how we can use ADO to bind to ADSI. It is important to note that each method of interacting with ADSI has its own peculiarities.

         my $objNameSpace = Win32::OLE->GetObject ('LDAP:') 
                or die ("Cannot create LDAP object");.
         my $objObjSec = $objNameSpace->OpenDSObject($strADsPath, $strUserID,
   $strUserPassword, 1);
         my %hashAdRecord;

We use Win32::OLE->GetObject('LDAP:') to utilize the LDAP services of ADSI. ADSI supports several directory services such as Novell NDS, and Windows NT4 amongst others. Next we try to access the Active Directory record associated with our user ID and password. The $strADsPath variable specifies what is roughly the domain name of the Windows 2000 forest, and how far down the forest one wants to begin searching. The DC=someuniversity,DC=edu is the LDAP analog of a DNS style domain name i.e. someuniversity.edu. In this example, we want to access the Active Directory starting at the organizational unit somedepartment that is a child of the organization unit somedivision.

We use $objNameSpace->OpenDSObject($strADsPath, $strUserID, $strUserPassword, 1) to access the Active Directory and retrieve the relevant record. The last argument in this subroutine is set to 1. It indicates that we are using an unencryted password.

    if (Win32::OLE->LastError()==0) {
        $refAdRecord =
            GetUserData($strAttributeName,$strAttributeValue,$strADsPath,$strDomain);
    } else {
        %hashAdRecord =('result' => 'failed');
        $refAdRecord = \%hashAdRecord;
    }

We use Win32::OLE->LastError() to ascertain if we have a valid user. Win32::OLE->LastError() is ActivePerl's implementation of Visual Basic's Err.Number. Up to now, everything is pretty straightforward. Deciphering the error codes is a little tricky. Here's how the error logic works. Win32::OLE->LastError() returns a non-zero only if the password is invalid. However, supplying a non-existent user ID will result in zero being returned. As such this bit of code is only good for detecting an invalid password. So, how do we detect a non-existent user ID? Our GetUserData subroutine serves a dual purpose. It not only detects a non-existent user ID, but also returns data from the Active Directory object that is associated with a valid user ID.

We can only return references to the XML-RPC client, so we need to define a scalar variable to which we can assign a reference of the return value. Furthermore, the scalar variable has to be global to the XML-RPC daemon program. In our case, the scalar variable is $refAdRecord. If the user id and password are valid, the reference to the hash returned by the subroutine GetUserData is assigned to the scalar $refAdRecord. On the other hand, if the user id and password are not valid, we insert the 'result' => 'failed' key-value pair to the %hashAdRecord hash variable, and subsequently assign the reference of that hash variable to $refAdRecord.

    $objObjSec->Close;
    $objNameSpace->Close;
    return $refAdRecord;
    }

And, it's time to destroy the ADSI objects that we created earlier.

Now, we move on to the XML-RPC specific bits of the daemon program.

    my $methods = {
    'activedirectory_daemon1.GetUserData' => \&GetUserData,
    'activedirectory_daemon1.GetCommandChain' => \&GetCommandChain,
    'activedirectory_daemon1.AuthenticateUser' => \&AuthenticateUser
    };

We declare a hash of subroutines that are accessible to the XML-RPC client. The key of each entry is the name of the method prefixed by an identifier using the dot convention. In our case, we arbitrarily use the name of the daemon file as the identifier. The value part of each hash entry is the de-referenced pointer to the corresponding method. This hash serves as a sort of look up table for requests to methods made at the XML-RPC client. The subroutines besides AuthenticateUser will be discussed later in this article.

    Frontier::Daemon->new(LocalPort => 8080, methods => $methods) 
           or die ("Cannot start HTTP daemon: $!");

At this juncture, we insert the code that fires up the XML-RPC daemon. We do so creating a new Frontier::Daemon instance. The constructor subroutine takes two arguments, each as a key-value pair. The first argument is the port used by the daemon. Since the host may already be running a web server, we'll use port 8080. The second argument is the set of subroutines to be published for use by the XML-RPC client (see above).

Besides the AuthenticateUser subroutine, we've also included a couple of subroutines that retrieve useful information about a user. GetUserData retrieves data like the user's email address, telephone number, etc. Although we call GetUserData from other subroutines (AuthenticateUser and GetCommandChain) within the daemon program, GetUserData may also be called from an XML-RPC client to retrieve data in the Active Directory about any user whose record is accessible. Instead of binding directly with ADSI, in this case, we use ADO to bind with the Active Directory, just so that the retreived data is presented as a record like if the data was retrieved from a relational database.

    sub GetUserData {
        my $strAttributeName  = shift; #could be userPrincipalName, cn etc
        my $strAttributeValue = shift; #could be user ID, cn value etc
        my $strADsPath        = shift; #could be
        # "LDAP://OU=somedivision,OU=somedepartment,DC=someuniversity,DC=edu"
		
        my $strDomain         = shift; #could be "someuniversity.edu"

        if ($strAttributeName eq "userPrincipalName") { 
            $strAttributeValue = $strAttributeValue . $strDomain; s
        }

        my $strProvider = "Active Directory Provider";

        my $strConnectionString = $strProvider;

        my $strFilter = "(" . $strAttributeName . "=" . $strAttributeValue . ")";

        my $strAttribs =
             "userPrincipalName,sn,givenName,cn,department,telephoneNumber,mail,title,manager";

        my $strScope = "subtree";

        my $strCommandText = "<" . $strADsPath . "E>;" . $strFilter . "
        ;" . $strAttribs . ";" . $strScope;

        my $objConnection = Win32::OLE->new ("ADODB.Connection") 
             or die ("Cannot create ADODB object!");

        my $objRecordset = Win32::OLE->new ("ADODB.Recordset")
             or die ("Cannot create ADODB recordset!");

        my $objCommand = Win32::OLE-E<gt>new ("ADODB.Command") 
             or die ("Cannot create ADODB command!");

        my %hashAdRecord;

The above code snippet from the GetUserData subroutine shows what values are assigned to varaibles. This subroutine has four arguments:

a. $strAttributeName

b. $strAttributeValue

c. $strADsPath

d. $strDomain

At this juncture, I'll try to explain how the above variables are used. In our case, we will search the Active Directory for the record that contains a given value for the userPrincipalName. As such, $strAttributeName = "userPrincipalName". If the user ID is jsmith12, then $strAttributeValue = "jsmith12". Alternatively, if we call the GetUserData subroutine from inside the AuthenticateUser subroutine, we declare $strAttributeValue = $strUserID in the AuthenticateUser subroutine.

Since we have used the user ID instead of the full userPrincipalName, we need to append @somedomain to the user ID. Hence we get,

    if ($strAttributeName eq "userPrincipalName") { 
        $strAttributeValue = $strAttributeValue . $strDomain; 
    }

The remainder of the above variable declarations with the exception of %hashAdRecord are required to enable ADO to bind with ADSI. I'll try to explain what's happening there. First we create the following objects:

a. ADODB connection object

b. ADODB Recordset object

c. ADODB Command object

Once these objects have been created, we assign values to selected properties of the ADODB Connection object.

    $objConnection->{Provider} = ("ADsDSOObject");
    $objConnection->{ConnectionString} = ($strConnectionString);
    $objConnection->Open();
    $objCommand->{ActiveConnection} = ($objConnection);

We open the ADODB connection, and assign the ADODB Connection object to the ActiveConnection property of the ADODB Command object.

    $objCommand->{CommandText} = ($strCommandText);
    $objRecordset = $objCommand->Execute($strCommandText) 
        or die ("Cannot execute!");

We assign $strCommandText to the CommandText property of the ADODB Command object, and next, we run the Execute method of the ADODB Command object.The $strCommandText variable is the argument of the Execute method. The value of the $strCommandText is the Active Directory analog of an SQL statement use to query an relational database. $strCommandText comprises four elements:

a. $strADsPath

b. $strFilter

c. $strAttribs

d. $strScope

$strADsPath contains the address of the Active Directory server, and the subset of the total set of records one wishes to search through. The address of the Active Directory server is specified by splitting the domain name up. And the result is DC=someuniversity,DC=edu. The subset of the records in the Active Directory is defined by listing the hierarchy of OUs (Organizational Units) e.g. OU=somedivision,OU=somedepartment. The syntax of the entire $strADsPath string complies with the LDAP RFC 2307 syntax. However, many programming or scripting languages do not seem to support this syntax as yet. Instead, the LDAP RFC 2251 syntax is widely supported.

$strFilter specificies the Active Directory records that we are interested in. In this instance, we are interested in the record where userPrincipalName is equal to someuserid@someuniversity.edu. Hence, this relationship is expressed as

    $strFilter="(" . $strAttributeName . "=" . $strAttributeValue . ")".

$strAttribs contains the list of fields that we want to retrieve from the query. If the query is successful, the result will be returned in ADODB Recordset object, and we can use the methods in the ADODB Recordset objects to retrieve the data.

$strScope="subtree" indicates that the scope of the search is limited to the subtree that has been specified in $strADsPath.

Finally, we turn our attention to getting a list of a user's superiors. This is possible because each user's record in the Active Directory has a manager field that contains the canonical name or CN (amongst other bits of data) of the user's immediate superior. The GetCommandChain subroutine returns an array of a user's superiors. This subroutine takes two arguments:

a. $refAdRecord

b. $strApexTitle

    sub GetManagerString {
        my %hashAdRecord = %$refAdRecord;
        my $strManagerString=$hashAdRecord{"manager"};
        return $strManagerString;
    }

$refAdRecord is the reference of the user's data returned by GetUserData. $strApexTitle is the highest office (e.g. ``Division Manager'') relevant to the search. The logic within this subroutine is quite simple. We make use of the GetManagerString subroutine to retrieve the data that was obtained from the Manager field in the Active Directory.

    sub GetManagerCN {
        my $strManagerString=shift;
        $strManagerString =~ /\bCN=([-_#@%\&\$\*\.a-zA-Z0-9\s]+)/;
        return $1;
    }

Next we use the GetManagerCN subroutine to extract the canonical name from the string returned by the GetManagerString subroutine.

    do {
        $refAdRecord =
        <GetUserData>("cn",$strManagerCN,"LDAP://OU=somedivision,
        OU=somedepartment,DC=someuniversity,DC=edu",
        "\@someuniversity.edu");
        %hashAdRecord=%$refAdRecord;
        $strTitle = $hashAdRecord{"title"};
        push @arrCommandChain, {%hashAdRecord};
        $strManagerString = GetManagerString($refAdRecord);
        $strManagerCN = GetManagerCN($strManagerString); 
    } until ($strTitle eq $strApexTitle);
    $refCommandChain = \@arrCommandChain;
    return $refCommandChain;

A do loop is used to traverse up the management hierarchy till we reach the user record that has a title value which matches the value in $strApexTitle. Over each iteration, we store the hash of the data retreived from the Active Directory into the array @arrCommandChain. Finally, we return the reference to this array as $refCommandChain.

In the next section we will examine how the client uses the XML-RPC mechanism to make requests of the daemon.

The Client in Perl

Since most of the work is done by the active directory daemon, the active directory client in Perl is relatively simple. Because we've used the XML-RPC protocol, the client can be written in various languages, e.g. PHP 4, Python, Java, etc. However we shall continue with Perl to be consistent with the theme of this web site.

As with the daemon, we invoke the strict pragma, and load the Frontier::Client module.

    $strDaemon_url = "http://www.someuniversity.edu:8080/RPC2";

To make use of the subroutines in the Active Directory daemon, we need to provide a url to the daemon. In our case we've assigned the url to the $strDaemon_url variable. As discussed in the Daemon section of this article, we've assigned port 8080 for our daemon's use. The Frontier::Daemon package has also assigned a default virtual directory, RPC2.

Next, we create a new instance of the XML RPC client by passing $strDaemon_url as the value part of the key-value pair of a hash entry.

    $objServer = Frontier::Client->new(url => $strDaemon_url);

Now we can utilize the published subroutines in the Active Directory daemon.

$refAdRecord=$objServer->call('activedirectory_daemon.AuthenticateUser','someuserid',
'Somepassword1','LDAP://OU=somedivision,OU=somedepartment,DC=someuniversity,DC=edu',
"\@someuniversity.edu");

The first argument in the $objServer->call subroutine is the qualified daemon subroutine name. The rest of the arguments are the arguments of the daemon subroutine.

As mentioned earlier, the XML-RPC daemon, can only return references. As such, we need to convert references to hashes, or arrays as appropriate. For example, %hashAdRecord = %$refAdRecord.

Conclusion

XML-RPC is a much more than an effective mechanism to enable distributed computing. We can use it to provide access to platform specific services. In our case, we used XML-RPC to enable a non-Windows host to access data and services in the Active Directory. Furthermore, XML-RPC is simple to implement. I've made forays into distributed computing several years ago by way of Java's RMI and Microsoft's DCOM. In my experience, XML-RPC is by far the cleanest and most fuss-free mechanism of the three.

So, if you're a Perl programmer, and are looking to leveraging off a service that only runs on the Windows platform, give Active Perl and XML-RPC a go. You'll be pleasantly surprised.

Resources

http://www.cpan.org

http://www.activestate.com

http://xmlrpc-c.sourceforge.net/xmlrpc-howto/xmlrpc-howto.html

A Drag-and-Drop Primer for Perl/Tk

As it happens, no matter how much I write about Perl/Tk, there's always something left unsaid. A case in point is the topic of drag and drop, which didn't make it into our book, Mastering Perl/Tk.

This article describes the Perl/Tk drag-and-drop mechanism, often referred to as DND. We'll illustrate DND operations local to a single application, where we drag items from one Canvas to another.

There are two basic types of DND operations, local (intra-application) and remote (inter-application). Local drops are fully supported, but there is no standard for remote drops. For this reason, this article describes only local DND operations. Note: Perl/Tk supports Sun, XDND, KDE, and Win32 remote DND protocols.

To write DND code you should be comfortable with these concepts:

  1. The drag source is the widget that we drag. In the case of a Canvas widget, we can arrange for an individual item to be the drag source.
  2. The drop destination is the widget upon which we drop the source widget.
  3. The DND token is a Label widget that tracks the cursor as it moves from the drag source to the drop destination. We can configure the DND token with a text string or an image.

This figure shows what we will end up with--one Canvas populated by various types of objects, which we can drag around the application and drop onto another Canvas. Let's now look at the code.

Here we have a rather typical Perl/Tk prologue. Tk::DragDrop is required if coding a program with a drag source, while Tk::DropSite is required for programs declaring a drop destination.

    use Tk;
    use strict;
    use Tk::DragDrop;
    use Tk::DropSite;
    use subs qw/make_bindings move_bbox move_image/;

Global variables

A drag begins with a <ButtonPress-1> event, where we record the ID of the specified Canvas item in the variable $drag_id. $mw is, of course, a reference to the program's MainWindow.

    our (
         $drag_id,              # Canvas item id of drag source
         $mw,                   # Perl/Tk MainWindow reference
    );

$mw = MainWindow->new(-background => 'green');

Define the drag source--a Canvas full of items. Here we declare that a <B1-Motion> event over the source Canvas signals the start of a local drag operation.

$drag_source is a Tk::DragDrop object, sometimes called a DND token. It's really a disguised Label widget, which we can configure in the standard fashion. For our purposes, we set the -text option to describe the Canvas item we are dragging, rather than the default text of the source widget's class name. But you can assign an image to the DND token if desired.

When performing a DND operation, notice that the DND token has a flat relief over the source, and a sunken relief over the destination.

    my $c_src = $mw->Canvas(qw/-background yellow/)->pack;

    my $drag_source = $c_src->DragDrop(
        -event     => '<B1-Motion>',
        -sitetypes => [qw/Local/],
    );

Every Canvas source item has a <ButtonPress-1> binding associated with it. The callback bound to this event serves to record the item's ID in the global variable $drag_id, and to configure the drag Label's -text/ option with the item's ID and type.

    my $press = sub {
        my ($c_src, $c_src_id, $drag_source) = @_;
        $drag_id = $c_src_id;
        my $type = $c_src->type($drag_id);
        $drag_source->configure(-text => $c_src_id . " = $type");
    };
  

OK, let's populate the source Canvas with items of various types. For this demonstration, we limit the choices to ovals, rectangles, and all the GIF files in the current directory. As noted earlier, every item gets a <ButtonPress-1> binding.

    my ($x, $y) = (30, 30);
    foreach (<*.gif>) {

        my $id = $c_src->createImage($x, $y,
            -image => $mw->Photo(-file => $_));
        $x += 80;
        $c_src->bind($id, '<ButtonPress-1>' => [$press, $id, $drag_source]);
    
    } # forend

    $x = 30;
    $y = 80;

    foreach (qw/oval rectangle/) {

        my $method = 'create' . ucfirst $_;
        my $id = $c_src->$method($x, $y, $x + 40, $y + 40, -fill => 'orange');
        $x += 80;
        $c_src->bind($id, '<ButtonPress-1>' => [$press, $id, $drag_source]);
    
    } # forend
  

Define the drop-site destination--another Canvas. As a source Canvas item is dropped here, create an identical item in the destination at the drop coordinates.

    my $c_dest = $mw->Canvas(qw/-background cyan/)->pack;
    $c_dest->DropSite(
        -droptypes   => [qw/Local/],
        -dropcommand => [\&move_items, $c_src, $c_dest],
    );
  

Build the obligatory Quit Button, and enter the main event loop.

    my $quit = $mw->Button(-text => 'Quit', -command => [$mw => 'destroy']);
    $quit->pack;

    MainLoop;
  

These subroutines are invoked when a Canvas source item is dropped on the destination Canvas. Callback "move_items" is invoked first, with these arguments:

$c_src  = source Canvas widget reference
$c_dest = destination Canvas widget reference
$sel    = selection type, here "XdndSelection"
$dest_x = Canvas drop site X coordinate
$dest_y = Canvas drop site Y coordinate
  

The first two arguments we supplied on the -dropcommand option. The remaining arguments are implicitly supplied by Perl/Tk.

"move_items" simply branches according to the item's type, throwing an error for Canvas items we are not prepared to handle. Each type handler receives the preceding arguments plus the item's type.

    sub move_items {

        $_ = $_[0]->type($drag_id);
        return unless defined $_;

      CASE: {

        /image/      and do {move_image $_, @_; last CASE};
        /oval/       and do {move_bbox  $_, @_; last CASE};
        /rectangle/  and do {move_bbox  $_, @_; last CASE};
        warn "Unknown Canvas item type '$_'.";

      }# casend

    } # end move_items
  

Subroutine "move_bbox" handles all Canvas item types described by a bounding box. (For this demonstration, we only propagate the -fill attribute from the Canvas source item to the new item.) It uses the subroutine "make_bindings" given below to establish local bindings on the newly created destination item, so it can be dragged about the destination Canvas.

    sub move_bbox {

        my ($item_type, $c_src, $c_dest, $sel, $dest_x, $dest_y) = @_;

        my $fill = $c_src->itemcget($drag_id, -fill);
        my $method = 'create' . ucfirst $item_type;
        my $id = $c_dest->$method($dest_x, $dest_y,
            $dest_x + 40, $dest_y + 40, -fill => $fill,
        );

        make_bindings $c_dest, $id;

    } # end move_bbox
  

Subroutine "move_image" handles a Canvas image item type. It uses the "make_bindings" subroutine just described.

    sub move_image {

        my ($item_type, $c_src, $c_dest, $sel, $dest_x, $dest_y) = @_;

        my $image = $c_src->itemcget($drag_id, -image);
        my $id = $c_dest->createImage($dest_x, $dest_y, -image => $image);

        make_bindings $c_dest, $id;

    } # end move_image
  

"make_bindings" itself adds drag behavior to our newly dropped Canvas items, but without using the DND mechanism. The basic idea is as follows:

  • On a <ButtonPress-1> event, record the Canvas item's (x,y) coordinates in instance variables of the form "x" . $id and "y" . $id, where $id is the item's Canvas ID. This ensures that each item's position is uniquely maintained.
  • On a <ButtonRelease-1> event, compute an (x,y) delta from the item's original position (stored in instance variables) and the new position, and use the Canvas "move" method to relocate it.
    sub make_bindings {

        my ($c_dest, $id) = @_;

        $c_dest->bind($id, '<ButtonPress-1>' => [sub {
	    my ($c, $id) = @_;
	    ($c_dest->{'x' . $id}, $c_dest->{'y' . $id}) =
	        ($Tk::event->x, $Tk::event->y);
        }, $id]);

        $c_dest->bind($id, '$lt;ButtonRelease-1>' => [sub {
	    my ($c, $id) = @_;
	    my($x, $y) = ($Tk::event->x, $Tk::event->y);
	    $c->move($id, $x - $c_dest->{'x' . $id}, $y - $c_dest->{'y' . $id});
        }, $id]);

    } # end make_bindings
  

The entire source code to this program is available here, and for more information about Perl/Tk programming, check out Mastering Perl/Tk.


O'Reilly & Associates will soon release (January 2002) Mastering Perl/Tk.

This Week on Perl 6 (2 - 8 December 2001)

Notes

You can subscribe to an email version of this summary by sending an empty message to perl6-digest-subscribe@netthink.co.uk.

This summary, as with past summaries, can be found in here. Please send additions, submissions, corrections, kudos, and complaints to bwarnock@capita.com.

There were 203 messages across 51 threads, with 46 authors contributing.

Parrot 0.03

Parrot 0.03 should now be available. From the release notes:

What have we unleashed? As promised, the latest release of Parrot, 0.0.3, contains support for complex, language-specific data types to be created. PMCs, or Parrot Magic Cookies, are abstract object data types, with class libraries written in C specifying their behaviour.

To start you off, we have implemented nice, happy, polymorphic Perl undef, Perl Integer, Perl String and Perl Number classes. There's also a default class you can inherit from if you're rolling your own data types. See docs/vtables.pod for all the juicy details.

That's not all, however... We've more documentation, examples, a minature Scheme implementation, support for pushing and popping onto register and global user stacks, subroutine support for Jako, better platform support, and a whole lot more. See the NEWS and ChangeLog files for the rest.

Download it and give it a try.

Parrot FAQ 0.2

Adam Turoff has coalesced many of the common questions on Parrot and Perl 6 into the Parrot FAQ.

The GCC Register Transfer Language

(17 posts) Terrence Brannon asked why Parrot wasn't simply compiling to GCC's RTL, instead of having to invent a brand new pseudo-architecture.

Dan Sugalski:

  • Because there are platforms where GCC doesn't run.
  • Because GCC's licensing is onerously restrictive for our purposes.
  • Because it makes embedding an interpreter a pain.
  • Because we dynamically recompile and redefine ourselves, which makes this difficult.
  • Because GCC's codegen is pretty bad.

Parrot Execution Environment

(14 posts) Nguon Hao Ching wondered how external arguments - via the command line, although the environment was quickly added to the discussion - were going to work in Parrot.

Weighing particularly heavy on Dan's mind - embedded interpreters and multi-threaded applications:

Who has control over the environment? The primary thread? All the threads? Should some have access and others not? Is there read-only access, or access to some but not all of the variables? Can an interpreter create or delete entries, and if so which ones? How much control does an embedder have, anyway? Should we call a separate function when getting/setting/querying/deleting? Do we even know which variables exist, or do we have to ask? Is it even thread-safe?

It's kinda messy, and since we can put it off for a bit, I'd as soon do that. We may have a half-kludge solution, but since that's all we have at the moment I'd rather wait and maybe a stroke of genius will occur. Or maybe not, in which case we're not really worse off than we are now.

String-to-Number Conversions

(11 posts) Alex Gough submitted, then withdrew, a patch to move string-to-number conversions to the encoding layer. (Alex discovered, as Tom Hughes pointed out, that the encoding layer is character agnostic, and that digit determination needs to occur at the character set layer.)

Aggregate Keys

(11 posts) Dan Sugalski posted his thoughts on aggregate keys. Jeff Goff is currently working on implementation.

Parroty Bits

Currently, Parrot is being developed without a license. Inside sources indicate that Larry is coming to a final decision on this, and Parrot should have one soon.

Parrot now has an IRC channel on irc.rhizomatic.net for some of the more mundane day-to-day development coordination. Join #parrot and hang out some time.

It looks like The Parrot Conference will be in San Diego, July 22-26, 2002. More info will be forthcoming, but get your vacation notices in now. (Yes, I believe that some other Open Source stuff will be going on, too. :-)


Bryan C. Warnock

An Introduction to Testing

Someday, you'll be dubiously blessed with the job of maintenance programming. You might need to add new features or to fix long-standing bugs. The code may be your own or the apparently disturbed mutterings of a long-disappeared agent of chaos. If you haven't yet been this fortunate, then download a Perl CGI script circa 1996 and try to make it operate under use strict, warnings and taint mode.

Maintenance is rarely pretty, mixing forensics, psychology and playing-card house construction. Complicating the matter are concerns such as backward compatibility, portability and interoperability. You'll probably hate the learning experience, but don't miss the chance to learn some important lessons:

These rules have been well-established since the early days (think Grace Hopper) of software engineering. Good practices remain the same: Write good comments, document your assumptions and logic, test your code to death, test it again.

Every serious software engineering methodology promotes testing. It is essential to newer approaches, like Extreme Programming. A comprehensive test suite helps to verify that the code performs as expected, helps to minimize the scope of future modifications, and frees developers to improve the structure and design of code without changing its behavior. Yes, this can actually work.

Caveats

Experienced readers (especially those with strong math backgrounds) rightly note that testing cannot prove the absence of bugs. If it's theoretically impossible to write a non-trivial program with zero defects, it's impossible to write enough tests to prove that the program works completely. Programmers try to write bug-free code anyway, so why not test anything and everything possible? A tested program may have unknown bugs, but an untested program will.

Of course, some things are truly untestable. This category includes the ``black boxes,'' such as other processes and machines, and system libraries. More things are testable than not, though. Perl allows good programmers to perform scary black magic, including system table and run-time manipulations. It's possible to create your own fake little world just to satisfy a testable interface. A little megalomania can be handy.

Testing can be difficult. A wad of code with minimal documentation -- a design from the Perl 4 days -- and business logic that relies on prayer, global variables and animal sacrifice may push you to new heights of productivity, or teach you how to manage programmers. If you don't fix it now, then when do you fix it? Extreme Programming recommends revising untestable code to make it easier to maintain and to test. Sometimes, you must write simple tests, rework the code slightly, and iterate until it's palatable.

Don't let the enormity of the task get you down. If you can write Perl code worth testing, then you can write tests.

How Perl Module Testing Works

This section assumes you're already familiar with perlmodinstall, having installed a module manually. After the perl Makefile.PL and make stages, make test runs any tests shipped with the module, either test.pl or all files in the t/ directory that end in ``.t.'' The blib/ directories are added to @INC, and Test::Harness runs the test files, captures their output and provides a short summary of the results, including success and failure.

At its heart, a test either prints ``ok'' or ``not ok.'' That's it. Any test program or testing framework that prints results to standard output can use Test::Harness. If you're feeling epistemological (a good trait to cultivate for writing tests), you could ask ``What is truth?'':

        print "1..1\n";

        if (1) {
                print "ok\n";
        } else {
                print "not ok\n";
        }

Basic? Yes. Bogus? Not really. This is a variant of an actual Perl core test. If you understood that code, then you can write tests. Ignoring the first line for now, simply stick it in a file (truth.t) and run either the command line:

        perl -MTest::Harness -e "runtests 'truth.t'";

or the program:

        #!/usr/bin/perl -w

        use strict;
        use Test::Harness;

        runtests 'truth.t';

This should produce a message saying that all tests succeeded. If not, then something is broken, and many people would be interested in fixing it.

The first line of the test corresponds to Test::Harness' handy test-numbering feature. The harness needs to know how many tests to expect, and each individual test within a group can have its own number. This is for your benefit. If one test in a 100 mysteriously fails, then it's much easier to track down number 93 than it is to run through the debugger, comment out large swaths of the test suite or rely on intuitively placed print statements.

Knowing truth is good, and so is discerning falsehood. Let's extend truth.t slightly. Note the addition of test numbers to each potential printable line. This is both a boon and a bane.

        print "1..2\n";
		
        if (1) {
                print "ok 1\n";
        } else {
                print "not ok 1\n";
        }

        if (0) {
                print "not ok 2\n";
        } else {
                print "ok 2\n";
        }

Besides the increasingly duplicate code, keeping test numbers synchronized is painful. False laziness is painful -- Test::Harness emits warnings if the number of actual tests run does not meet its expectations. Test writers may not mind, but spurious warnings will confuse end users and healthily lazy developers. As a rule, the simpler the output, the more people will believe that things succeeded. The stuffed, smiling Pikachu (hey, it was a birthday present from an attractive female Web designer) perched atop my monitor makes me think that a giant yellow smiley face would be even better than a simple ``ok'' message. ASCII artists, fire up your editors!

Unfortunately, the truth test is repetitive and fragile. Adding a third test between the first two (the progression from ``truth'' to ``hidden truth'' to ``falsehood'' makes sense) means duplicating the if/else block and renumbering the previously second test. There's also room for a subtle bug:

        print "1..2\n";
        if (1) {
                print "ok 1\n";
        } else {
                print "not ok 1\n";
        }
        if ('0 but true') {
                print "ok 2\n";
        } else {
                print "not ok 2\n";
        }
        if (0) {
                print "not ok 3\n";
        } else {
                print "ok 3\n";
        }

Forgetting to update the first line is common. Two tests were expected; three tests ran. The confused Test::Harness will report strange things, like negative failure percentages. Baby Pikachu may cry. Smarter programmers eventually apply good programming style, writing their own ok() functions:

        print "1..3\n";
        my $testnum = 1;
        sub ok {
                my $condition = shift;
                print $condition ? "ok $testnum\n" : "not ok $testnum\n";
                $testnum++;
        }
        ok( 1 );
        ok( '0 but true' );
        ok( ! 0 );

The lowest levels of the Perl core test suite use this approach. It's simpler to write and handles numbering almost automatically. It lacks some features, though, and is little easier to debug.

Enter Test::More

Several modules exist to make testing easier and almost enjoyable. Test ships with modern Perl distributions and plays well with Test::Harness. The Perl-Unit suite reimplements the popular JUnit framework in Perl. The rather new Test::More module adds several features beyond those of Test. (I admit a particular bias toward the latter, though these and other modules are fine choices.)

Test::More has its own ok() function, but it is rarely used in favor of more specific functions. is() compares two expressions. For example, testing an addition function is as simple as:

        is( add(2, 2), 4 );

This handles strings and numbers equally well. Since version 0.36, it also distinguishes between 0, '' (the empty string), and undef -- we hope.

like() applies a regular expression to a scalar. This is also useful for trapping fatal errors:

        $self->eat('garden salad'):

        eval { $self->write_article() };
        like( $@, qr/not enough sugar/ );

The second argument can be either a regular expression compiled with the qr// operator (introduced in Perl 5.005), or a string that resembles a regular expression. Modifiers are allowed. If you absolutely must rewrite the previous example to run on Perl 5.004 and to use StudlyCaps, then you can:

        eval { $self->write_article() };
        like( $@, '/NoT eNoUgH sUgAr/i' );

That's too cute/hideous for a real test, but the regex form is completely valid.

Test::More Makes Debugging Nicer

That's useful enough already, but there's more to Test::More.

Test::More supports test numbering just as Test::Harness does, and automatically provides the numbers. This is a big win in two cases: where the test suite may accidentally fail (from a die() call, a segmentation fault, or spontaneous combustion), or if the tests can accidentally repeat (due to an improper chdir(), unexpected input in a loop condition, or a time warp). Test::Harness is happy to warn whether the number of tests actually run do not match its expectations. You just have to tell it how many should run. This is usually done when using Test::More:

        use Test::More tests => 50;

When writing new tests, you may not know how many there will be. Use the no_plan option:

        use Test::More 'no_plan';

Extreme Programming recommends this game-like approach: add a test, run it, write code to pass the test, repeat. When you've finished, update the use line to reflect the actual number of tests.

Test::More also handles failures gracefully. Given the following file with a final, doomed test:

        use Test::More tests => 4;
        is( 1, 1 );
        is( !0, 1 );
        is( 0, 0 );
        is( undef, 1 );

Test::More run on its own, not through Test::Harness, produces:

        1..4
        ok 1
        ok 2
        ok 3
        not ok 4
        #     Failed test (numbers.t at line 6)
        #          got: undef
        #     expected: '1'
        # Looks like you failed 1 tests of 1.

The error message provides the name of the file containing the tests, the number of the failed test, the line number containing the failed test, and expected and received data. This makes for easier debugging. Count tests to find an error just once, and you'll prefer this approach.

Test::Harness also supports optional test comments attached to test messages. That is, it allows raw tests to say:

        print "ok 1 # the most basic test possible\n";

Nearly all Test::More functions support this as an optional parameter:

        ok( 1, 'the number 1 should evaluate to true' );
        is( 2 + "2", 4, 'numeric strings should numerify in addition' );
        like( 'abc', qr/z*/, '* quantifier should match zero elements' );

These names are required by nothing except social convention. Think of them as little test comments. If the test is wrong, or exposes a fixed bug that should never reoccur, then a descriptive name makes it clear what the test should be testing. Test::Harness silently eats the names, but they're present when run manually:

        ok 1 - the number 1 should evaluate to true
        ok 2 - numeric strings should numerify in addition
        ok 3 - * quantifier should match zero elements

Manual test runs make for improved bug reports. Ignore these convenient tools at your own peril.

Intermediate Test::More Features

If the previous features weren't enough, Test::More supports still more! One such is the notion of skippable tests. Occasionally, the presence or absence of certain criteria obviate the need to test a feature. Consider the qr// operator explained earlier. A module that needs to be backward compatible to Perl 5.004 can gradefully degrade its test suite with skippable tests:

        SKIP: {
                skip( 'qr// not supported in this version', 2 ) unless $] >= 5.005;
                my $foo = qr/i have a cat/;
                ok( 'i have a caterpillar' =~ $foo,
                        'compiled regex should match similar string' );
                ok( 'i have a cold' !~ $foo,
                        'compiled regex should not match dissimilar string' );
        }

There's a lot to digest. First, the skippable tests are contained in a labelled block. The label must be SKIP. (Don't worry: you can have several of these within a file.) Next, there should be a condition that governs whether to skip the tests. This example checks the special variable perlvar to find the current Perl version. skip() will only be called when run with an older version.

The skip() function always confuses me with its unique parameter order. The first argument is the name to display for each skipped test. The second argument is the number of tests to skip. This must match the number of tests within the block, at the risk of certain confusion. Run on Perl 5.004, the above test produces:

        ok 1 # skip qr// not supported in this version
        ok 2 # skip qr// not supported in this version

Though the message says ok, Test::Harness will see skip and report the tests as skipped, not passed. This should only be used for tests that absolutely will not run due to platform or version differences. For tests you just can't figure out yet, use todo().

Though everything is built on Test::Builder::ok(), other functions offer helpful shortcuts. use_ok() and require_ok load and optionally import the named file, reporting the success or error. These verify that a module can be found and compiled, and are often used for the first test in a suite. The can_ok() function attempts to resolve a class or an object method. isa_ok() checks inheritance:

        use_ok( 'My::Module' );
        require_ok( 'My::Module::Sequel' );
        my $foo = My::Module->new();
        can_ok( $foo->boo() );
        isa_ok( $foo, 'My::Module' );

They produce their own test names:

        ok 1 - use My::Module;
        ok 2 - require My::Module::Sequel;
        ok 3 - My::Module->can(boo)
        ok 4 - object->isa('My::Module')

Other functions and features are documented in the Test::More documentation. As well, the Test::Tutorial manpage explains similar things with a different wit.

Finally, do not forget good programming practices. Test functions are simply standard subroutines. Tests are just Perl code. Use loops, variables, helper subs, map(), and anything else, when they make things easier. For example, basic inherited interface testing can be made easier with:

        # see if IceCreamBar inherits these methods from Popsicle
        my $icb = IceCreamBar->new();
        foreach my $method (qw( fall_off_stick freeze_tongue drip_on_carpet )) {
                can_ok( $icb, $method, "IceCreamBar should be able to $method()" );
        }

That beats writing several individual can_ok() tests. Interpolating things into the test name is also handy.

Conclusion

Testing is unfortunately often neglected, especially among free software projects. Think of it as getting plenty of sleep, eating vegetables, and working out regularly. It may cramp your style at first, but will improve things immensely if you do it consistently. (Results may vary if you're adding tests to a huge system that doesn't have them, like, say, Perl itself.)

One goal of Perl is to make your life easier. Perl 5.8 will include Test::More and its hearty brethren, the Test::Simple manpage and the Test::Builder manpage. They exist to make writing tests less of a hassle, and even more pleasant. Consider them.

The easier it is to write and maintain tests, the more likely people will do it. More and better tests improve software portability, maintainability, and reliability. You may currently compare testing to broccoli, brussel sprouts, and wind sprints. Try Test::More or another framework, and you may grow to see them as oranges, sweet potatoes with marshmallows, and a trip to the sauna. It really is good for you.

chromatic is the author of Modern Perl. In his spare time, he has been working on helping novices understand stocks and investing.

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

Sponsored by

Monthly Archives

Powered by Movable Type 5.13-en