X11::Wcl - Perl interface to the Widget Creation Library

 use X11::Wcl;

 $object->idx(INT);

 # create array of 20 structures
 $options = new StructureName(0, 20);
 # now initialize them
 for ($i=0; $i<20; ++$i) {
     $x = $options->idx($i);
     $x->{field} = "value"
 }

 WcRegisterCallback($app_context, $callback_name, $function, $arg)

 WcAddEditResSupportToShell($shell)

 preprocess($string)

 MakeXt*Proc($perl_function_name)

 mainloop(TAG => VALUE, ...)

 *resourceFile: some_file_name

 *resourceFile: $main::x

 "David E. Smyth" (Widget Creation Library)
 "David M. Beazley" <dmb@asator.lanl.gov> (SWIG)
 "Joseph H. Buehler" <jhpb@sarto.gaithersburg.md.us> (X11::Wcl module)

 Widget Creation Library documentation.
 Motif toolkit documentation.
 SWIG documentation.
 examples supplied with this module.
 perl(1).

#
# This is the hand-written PERL part of the X11::Wcl module.
#

use Carp;

package X11::Wcl;

$VERSION = '0.3';

$toplevel = undef;
$application_context = undef;
$initial_resources = undef;
$delete_callback = undef;

#
# called when user has requested callback for window manager close
#
sub delete
{
	&{$delete_callback}();
}

#
# This is the public function used to register PERL callback
# functions.  It saves some information in PERL structures for later
# use when the callback is invoked, and some information it passes
# down to the C level of Wcl for its use.
#
sub WcRegisterCallback
{
	my($app_context, $callback_name, $function, $arg) = @_;

	# save function and argument for use when callback is invoked
	$callback_function{$callback_name} = $function;
	$callback_arg{$callback_name} = $arg;

	# register callback with Widget Creation Library
	_X11_Wcl_register_callback($app_context, $callback_name);
}

#
# This routine is called from the C level when a callback needs to be
# executed.  It calls the proper PERL function, passing information
# remembered from when the callback was registered, and information
# passed in from the C level.
#
sub do_callback
{
	my($callback_name, $widget, $client_data, $callback_data) = @_;

	# convert $widget to the proper type
	$widget = ptrcast(eval $widget, "Widget");

	# convert $client_data to the proper type
	$client_data = ptrcast(eval $client_data, "char *");
	$client_data = ptrvalue($client_data);

	# do the callback
	&{$callback_function{$callback_name}}(
		$widget,
		$client_data,
		$callback_data,
		$callback_arg{$callback_name}
	);
}

#
# perform preprocessing on a string
#
# #if, #else and #endif are valid and can be arbitrarily nested
# argument to #if is a PERL expression
#
# The extra arguments are for internal use, during recursion.
#
sub preprocess
{
	my($data, $inside_an_if, $discarding, $inside_false_clause) = @_;
	my $in;
	my $out = "";

	if (ref $data eq "") {
		$in = $data;
		$data = \$in;
	}
	while ($$data =~ m@^(.*)\n?@gm) {
		$_ = $1;
		if (/^\s*#\s*if\s+((\S.*)?\S)\s*$/) {
			if (eval $1) {
				$out .= preprocess($data, 1, $discarding || $inside_false_clause, 0);
			} else {
				$out .= preprocess($data, 1, $discarding || $inside_false_clause, 1);
			}
		} elsif (/^\s*#\s*else\s*$/) {
			if (!$inside_an_if) {
				croak "unexpected #else";
			} else {
				$inside_false_clause = !$inside_false_clause;
			}
		} elsif (/^\s*#\s*endif\s*$/) {
			if (!$inside_an_if) {
				croak "unexpected #endif";
			} else {
				return $out;
			}
		} elsif (/^\s*#/) {
			croak "unknown directive: $_";
		} elsif (!$discarding && !$inside_false_clause) {
			$out .= "$_\n";
		} else {
			# discard the line
		}
	}
	if ($inside_an_if) {
		croak "unexpected end of input";
	}
	$out;
}

#
# parse resource specifications, performing preprocessing on them
# first, using preprocess()
#
# Input argument can be a scalar, a ref to a scalar, a ref to a
# subroutine, or a ref to a glob (which is interpreted as a file
# handle to read, such as \*DATA).
#
# The keyword MAIN introduces the top-level resources for an
# application.
#
# The keyword TEMPLATE followed by a template name introduces a
# template definition.
#
sub get_resources
{
	my($arg) = @_;
	my $main;
	my $variable;
	my $data;

	if ("SCALAR" eq ref $arg) {
		# reference to a variable
		$data = $$arg;
	} elsif ("CODE" eq ref $arg) {
		# reference to a subroutine
		$data = &{$arg}();
	} elsif ("GLOB" eq ref $arg) {
		# file handle
		my $x = $/;
		undef $/;
		$data = <$arg>;
		$/ = $x;
		close($arg);
	} else {
		# assume scalar value
		$data = $arg;
	}

	$arg = preprocess($data);

	$data = "";
	while ($arg =~ m@^.*\n?@gm) {
		$_ = $&;
		if (/^MAIN\s*$/) {
			# start of top level resources
			if (defined $variable) {
				eval "\$$variable = \$data";
				$data = "";
			}
			$variable = "main";
		} elsif (/^TEMPLATE\s+(\S+)\s*$/) {
			# start of template resources
			if (defined $variable) {
				eval "\$$variable = \$data";
				$data = "";
			}
			$variable = $1;
		} else {
			$data .= $_;
		}
	}
	if (defined $variable) {
		eval "\$$variable = \$data";
	}

	# return top level resources
	$main;
}

#
# standard main routine
#
# The following arguments can be passed.
#
# ARGV => ["program name", "arg1", "arg2", "etc."]
#
#	Required.  Specifies program name (required) and any command line
#	arguments necessary for Wcl or Xt.
#
# DELETE => \&delete_window
#
#	Optional.  Callback routine to be executed when window manager
#	does a close operation.
#
# EDITRES_SUPPORT => 1
#
#	Optional.  Requests that top-level shell support the editres
#	protocol.
#
# INITIAL_RESOURCES => $whatever
# INITIAL_RESOURCES => \$whatever
# INITIAL_RESOURCES => \&whatever
# INITIAL_RESOURCES => \*whatever
#
#	Optional.  Provides the top-level resources and/or templates for
#	the application.
#
# NO_INITIAL_RESOURCES => 1
#
#	Optional.  Prevents main loop from calling Wcl to create the
#	initial widget tree.
#
# NO_REALIZE => 1
#
#	Optional.  Prevents main loop from calling Xt to realize the
#	widget tree, thus preventing top-level shell creation.
#
# CALLBACKS => [
#	["name", \&procedure, "arbitrary PERL object"],
#	...
# ]
#
#	Optional.  Provides information about callback routines that need
#	to be registered with Wcl, because they appear in callback
#	resources.
#
# OPTIONS => [
#	["-name",	"*resource",	$X11::Wcl::XrmoptionXXX, VALUE],
#	...
# ]
#
#	Optional.  Provides values for an array of XrmOptionDescRec
#	structures which is created by main loop for argument parsing.
#	The default Wcl options are always added to the end of any options
#	passed in.
#
# STARTUP => \&startup
#
#	Optional.  Provides a callback routine that is called just before
#	the widget tree is realized by Xt.
#
# NEED_MISC => 1
#
#	Optional.  Indicates that the Misc library is needed.
#
# NEED_MOTIF => 1
#
#	Optional.  Indicates that the Motif library is needed.
#
sub mainloop
{
	my %args = @_;

	croak "no ARGV array was passed"
		unless exists $args{ARGV};

	# add standard Wcl options
	push(@{$args{OPTIONS}},
		["-ResFile","*wclInitResFile",		$XrmoptionSepArg, undef],
		["-rf",		"*wclInitResFile",		$XrmoptionSepArg, undef],
		["-trrf",	"*wclTraceResFiles",	$XrmoptionNoArg,  "on"],
		["-Trace",	"*wcTrace",				$XrmoptionNoArg,  "on"],
		["-tr",		"*wcTrace",				$XrmoptionNoArg,  "on"],
		["-trtd",	"*wclTraceTemplateDef",	$XrmoptionNoArg,  "on"],
		["-trtx",	"*wcTraceTemplate",		$XrmoptionNoArg,  "on"],
		["-Warnings","*wclVerboseWarnings",	$XrmoptionNoArg,  "on"],
	);

	# make array of XrmOptionDescRec structures
	my $options = new XrmOptionDescRec(0, scalar @{$args{OPTIONS}});
	# setup options structure
	my $num_options = 0;
	for (@{$args{OPTIONS}}) {
		my $x = $options->idx($num_options);
		$x->{option} = ${$_}[0];
		$x->{specifier} = ${$_}[1];
		$x->{argKind} = ${$_}[2];
		$x->{value} = ${$_}[3];
		++$num_options;
	}

	# parse the initial resource specifications
	if (exists $args{INITIAL_RESOURCES}) {
		$initial_resources = get_resources($args{INITIAL_RESOURCES});
		push(@{$args{ARGV}}, "-rf");
		push(@{$args{ARGV}}, "\$X11::Wcl::initial_resources");
	}

	# make an int for argc
	my $argc = ptrcreate("int", 0, 1);
	# make array of char * pointers for argv
	my $argv = ptrcreate("char *", 0, 1 + scalar @{$args{ARGV}});
	# set up argv
	my $i = 0;
	for (@{$args{ARGV}}) {
		ptrset($argv, $_, $i++);
	}
	ptrset($argv, ptrcast(0, "char *"), $i++);
	# set up argc
	ptrset($argc, $i);

    # Initialize Toolkit creating the application shell
    $toplevel = XtInitialize(
		WcAppName(ptrvalue($argc), $argv), WcAppClass(ptrvalue($argc), $argv),
		$options, $num_options,
		$argc, $argv);

	# add editres support
	if (exists $args{EDITRES_SUPPORT}) {
		WcAddEditResSupportToShell($toplevel);
	}

	# get application context
    $application_context =
		XtWidgetToApplicationContext($toplevel);

    # Register application specific callbacks and widget classes
	for (@{$args{CALLBACKS}}) {
		WcRegisterCallback($application_context, @{$_});
	}

    # Register all widget classes and constructors
	if (exists $args{NEED_MOTIF}) {
	    XmpRegisterAll($application_context);
	}
	if (exists $args{NEED_MISC}) {
	    RegisterMisc($application_context);
	}

    # Create widget tree below toplevel shell using Xrm database
	if (!exists $args{NO_INITIAL_RESOURCES}) {
		if (WcWidgetCreation($toplevel)) {
			croak "cannot create widget tree";
		}
	}

	# startup here
	if (exists $args{STARTUP}) {
		&{$args{STARTUP}}($toplevel, $application_context);
	}

    # Realize the widget tree
	if (!exists $args{NO_REALIZE}) {
	    XtRealizeWidget($toplevel);
	}

	if (exists $args{DELETE}) {
		$delete_callback = $args{DELETE};
		my $x = MakeXtCallbackProc("X11::Wcl::delete");
		XmpAddMwmCloseCallback($toplevel, $x, undef);
	}

    # finally, enter the main application loop
    XtMainLoop();
}

1;

__END__