path: root/bin/perload

#! /usr/bin/perl
'/bin/true' && eval 'exec perl -S $0 "$@"'
	if $running_under_some_shell;
'di';
'ig00';

#
# This perl script is its own manual page [generated by wrapman]
#

# $Id: perload,v 3.0.1.1 1994/10/29 15:45:36 ram Exp ram $
#
#  Copyright (c) 1991-1997, 2004-2006, Raphael Manfredi
#  
#  You may redistribute only under the terms of the Artistic Licence,
#  as specified in the README file that comes with the distribution.
#  You may reuse parts of this distribution only within the terms of
#  that same Artistic Licence; a copy of which may be found at the root
#  of the source tree for dist 4.0.
#
# $Log: perload,v $
# Revision 3.0.1.1  1994/10/29  15:45:36  ram
# patch36: added minimal support for perl5 dataloading
#
# Revision 3.0  1993/08/18  12:04:06  ram
# Baseline for dist 3.0 netwide release.
#

# Replace each function definition in a loading section by two stubs and
# reject the definition into the DATA part of the script if in a dataload
# section or into a FILE if in an autoload section.

$in_load = 0;					# In a loading section
$autoload = '';					# Name of autoloaded file
$has_invocation_stub = 0;		# True if we detect a #! stub
$current_package = 'main';		# Current package
$init_emitted = 0;				# True when dataloading stamp was emitted
$in_function = 0;

require 'getopt.pl';
&Getopt;

while (<>) {
	if ($. == 1 && /^(:|#).*perl/) {	# Invocation stub
		$has_invocation_stub = 1;
		print;
		next;
	}
	if ($. <= 3 && $has_invocation_stub) {
		print;
		next;
	}
	if (/^\s*$/) {
		&flush_comment;
		print unless $in_function;
		print if $in_function && !$in_load;
		if ($in_function && $in_load) {
			push(@Data, "\n") unless $autoload;
			$Auto{$autoload} .= "\n" if $autoload;
		}
		next;
	}
	if (/^\s*;?#/) {
		if (/#\s*perload on/i) {		# Enter a loading section
			print unless /:$/;
			$in_load = 1;
			next;
		}
		if (/#\s*perload off/i) {		# End a loading section
			print unless /:$/;
			$in_load = 0;
			next;
		}
		if (/#\s*autoload (\S+)/i) {	# Enter autoloading section
			print unless /:$/;
			push(@autoload, $autoload);	# Directives may be nested
			$autoload = $1;
			$in_load += 2;
			next;
		}
		if (/#\s*offload/i) {			# End autoloading section
			print unless /:$/;
			$autoload = pop(@autoload);	# Revert to previously active file
			$in_load -= 2;
			next;
		}
		&emit_init unless $init_emitted;
		push(@Comment, $_) unless $in_function;
		print if $in_function && !$in_load;
		next unless $in_function;
		push(@Data, $_) unless $autoload;
		$Auto{$autoload} .= $_ if $autoload;
		next;
	}
	&emit_init unless $init_emitted;
	/^package (\S+)\s*;/ && ($current_package = $1);
	unless ($in_load) {
		&flush_comment;
		print;
		next;
	}
	# We are in a loading section
	if (/^sub\s+([\w']+)\s*\{(.*)/) {
		die "line $.: function $1 defined within another function.\n"
			if $in_function;
		# Silently ignore one-line functions
		if (/\}/) {
			&flush_comment;
			print;
			next;
		}
		$comment = $2;
		$in_function = 1;
		$function = $1;
		($fn_package, $fn_basename) = $function =~ /^(\w+)'(\w+)/;
		unless ($fn_package) {
			$fn_package = $current_package;
			$fn_basename = $function;
		}
		# Keep leading function comment
		foreach (@Comment) {
			push(@Data, $_) unless $autoload;
			$Auto{$autoload} .= $_ if $autoload;
		}
		@Comment = ();
		# Change package context for correct compilation: the name is visible
		# within the original function package while the body of the function
		# is compiled within the current package.
		$declaration = "sub $fn_package" . "'load_$fn_basename {$comment\n";
		$package_context = "\tpackage $current_package;\n";
		if ($autoload) {
			$Auto{$autoload} .= $declaration . $package_context;
		} else {
			push(@Data, $declaration, $package_context);
		}
		# Emit stubs
		print "sub $fn_package", "'$fn_basename";
		print " { &auto_$fn_package", "'$fn_basename; }\n";
		print "sub auto_$fn_package", "'$fn_basename { ";
		print '&main\'dataload' unless $autoload;
		print '&main\'autoload(' . "'$autoload'" . ', @_)' if $autoload;
		print "; }\n";
		next;
	}
	unless ($in_function) {
		&flush_comment;
		print;
		next;
	}
	# We are in a loading section and inside a function body
	push(@Data, $_) unless $autoload;
	$Auto{$autoload} .= $_ if $autoload;
	$in_function = 0 if /^\}/;
	if (/^\}/) {
		push(@Data, "\n") unless $autoload;
		$Auto{$autoload} .= "\n" if $autoload;
	}
}

@auto = keys %Auto;
if (@auto > 0) {
	print &q(<<'EOC');
:# Load the calling function from file and call it. This function is called
:# only once per file to be loaded.
:sub main'autoload {
:	local($__file__) = shift(@_);
:	local($__packname__) = (caller(1))[3];
:	$__packname__ =~ s/::/'/;
:	local($__rpackname__) = $__packname__;
:	local($__saved__) = $@;
:	$__rpackname__ =~ s/^auto_//;
:	&perload'load_from_file($__file__);
:	$__rpackname__ =~ s/'/'load_/;
:	$@ = $__saved__;		# Restore value $@ had on entrance
:	&$__rpackname__(@_);	# Call newly loaded function
:}
:
:# Load file and compile it, substituing the second stub function with the
:# loaded ones. Location of the file uses the @AUTO array.
:sub perload'load_from_file {
:	package perload;
:	local($file) = @_;				# File to be loaded
:	local($body) = ' ' x 1024;		# Pre-extent
:	local($load) = ' ' x 256;		# Loading operations
:	# Avoid side effects by protecting special variables which will be
:	# changed by the autoloading operation.
:	local($., $_, $@);
:	$body = '';
:	$load = '';
:	&init_auto unless defined(@'AUTO);	# Make sure we have a suitable @AUTO
:	&locate_file unless -f "$file";		# Locate file if relative path
:	open(FILE, $file) ||
:		die "Can't load $'__rpackname__ from $file: $!\n";
:	while (<FILE>) {
:		$load .= '*auto_' . $1 . '\'' . $2 . '= *' . $1 . '\'' . "load_$2;\n"
:			if (/^sub\s+(\w+)'load_(\w+)\s*\{/);
:		$body .= $_;
:	}
:	close FILE;
EOC
	if ($opt_t) {
		print &q(<<'EOC');
:	# Untaint body when running setuid
:	$body =~ /^([^\0]*)/;
:	# No need to untaint $load, as it was built using trusted variables
:	eval $1 . $load;
EOC
	} else {
		print &q(<<'EOC');
:	eval $body . $load;
EOC
	}
	print &q(<<'EOC');
:	chop($@) && die "$@, while parsing code of $file.\n";
:}
:
:# Initialize the @AUTO array. Attempt defining it by using the AUTOLIB
:# environment variable if set, otherwise look in auto/ first, then in the
:# current directory.
:sub perload'init_auto {
:	if (defined $ENV{'AUTOLIB'} && $ENV{'AUTOLIB'}) {
:		@AUTO = split(':', $ENV{'AUTOLIB'});
:	} else {
:		@AUTO = ('auto', '.');
:	}
:}
:
:# Locate to-be-loaded file held in $file by looking through the @AUTO array.
:# This variable, defined in 'load_from_file', is modified as a side effect.
:sub perload'locate_file {
:	package perload;
:	local($fullpath);
:	foreach $dir (@'AUTO) {
:		$fullpath = $dir . '/' . $file;
:		last if -f "$fullpath";
:		$fullpath = '';
:	}
:	$file = $fullpath if $fullpath;		# Update var from 'load_from_file'
:}
:
EOC
}

if (@Data > 0) {
	print &q(<<'EOC');
:# Load the calling function from DATA segment and call it. This function is
:# called only once per routine to be loaded.
:sub main'dataload {
:	local($__packname__) = (caller(1))[3];
:	$__packname__ =~ s/::/'/;
:	local($__rpackname__) = $__packname__;
:	local($__at__) = $@;
:	$__rpackname__ =~ s/^auto_//;
:	&perload'load_from_data($__rpackname__);
:	local($__fun__) = "$__rpackname__";
:	$__fun__ =~ s/'/'load_/;
:	eval "*$__packname__ = *$__fun__;";	# Change symbol table entry
:	die $@ if $@;		# Should not happen
:	$@ = $__at__;		# Restore value $@ had on entrance
:	&$__fun__;			# Call newly loaded function
:}
:
:# Load function name given as argument, fatal error if not existent
:sub perload'load_from_data {
:	package perload;
:	local($pos) = $Datapos{$_[0]};			# Offset within DATA
:	# Avoid side effects by protecting special variables which will be changed
:	# by the dataloading operation.
:	local($., $_, $@);
:	$pos = &fetch_function_code unless $pos;
:	die "Function $_[0] not found in data section.\n" unless $pos;
:	die "Cannot seek to $pos into data section.\n"
:		unless seek(main'DATA, $pos, 0);
:	local($/) = "\n}";
:	local($body) = scalar(<main'DATA>);
:	die "End of file found while loading $_[0].\n" unless $body =~ /^\}$/m;
EOC
	if ($opt_t) {
		print &q(<<'EOC');
:	# Untaint body when running setuid
:	$body =~ /^([^\0]*)/;
:	# Now we may safely eval it without getting an insecure dependency
:	eval $1;		# Load function into perl space
EOC
	} else {
		print &q(<<'EOC');
:	eval $body;		# Load function into perl space
EOC
	}
	print &q(<<'EOC');
:	chop($@) && die "$@, while parsing code of $_[0].\n";
:}
:
EOC
	print &q(<<'EOC') unless $opt_o;
:# Parse text after the END token and record defined loadable functions (i.e.
:# those whose name starts with load_) into the %Datapos array. Such function
:# definitions must be left adjusted. Stop as soon as the function we want
:# has been found.
:sub perload'fetch_function_code {
:	package perload;
:	local($pos) = tell main'DATA;
:	local($in_function) = 0;
:	local($func_name);
:	local($., $_);
:	while (<main'DATA>) {
:		if (/^sub\s+(\w+)'load_(\w+)\s*\{/) {
:			die "DATA line $.: function $1'$2 defined within $func_name.\n"
:				if $in_function;
:			$func_name = $1 . '\'' . $2;
:			$Datapos{$func_name} = $pos;
:			$in_function = 1;
:			next;
:		}
:		$in_function = 0 if /^\}/;
:		next if $in_function;
:		return $pos if $func_name eq $_[0];
:		$pos = tell main'DATA;
:	}
:	0;		# Function not found
:}
:
EOC
	print &q(<<'EOC') if $opt_o;
:# This function is called only once, and fills in the %Datapos array with
:# the offset of each of the dataloaded routines held in the data section.
:sub perload'fetch_function_code {
:	package perload;
:	local($start) = 0;
:	local($., $_);
:	while (<main'DATA>) {			# First move to start of offset table
:		next if /^#/;
:		last if /^$/ && ++$start > 2;	# Skip two blank line after end token
:	}
:	$start = tell(main'DATA);		# Offsets in table are relative to here
:	local($key, $value);
:	while (<main'DATA>) {			# Load the offset table
:		last if /^$/;				# Ends with a single blank line
:		($key, $value) = split(' ');
:		$Datapos{$key} = $value + $start;
:	}
:	$Datapos{$_[0]};		# All that pain to get this offset...
:}
:
EOC
	print &q(<<'EOC');
:#
:# The perl compiler stops here.
:#
:
:__END__
:
:#
:# Beyond this point lie functions we may never compile.
:#
:
EOC
	# Option -o directs us to optimize the function location by emitting an
	# offset table, which lists all the position within DATA for each possible
	# dataloaded routine.
	if ($opt_o) {
		print &q(<<'EOC');
:#
:# DO NOT CHANGE A IOTA BEYOND THIS COMMENT!
:# The following table lists offsets of functions within the data section.
:# Should modifications be needed, change original code and rerun perload
:# with the -o option to regenerate a proper offset table.
:#
:
EOC
		$trailing_message = &q(<<'EOC');
:
:#
:# End of offset table and beginning of dataloading section.
:#
:
EOC
		$pos = 0;			# Offset relative to this point (start of table)
		foreach (@Data) {
			$Datapos{"$1\'$2"} = $pos - $now
				if /^sub\s+(\w+)'load_(\w+)\s*\{/;	# } for vi
			$pos += length;
		}
		@poskeys = keys %Datapos;	# Array of routine names (fully qualified)

		# Write out a formatted table, each entry stored on $entry bytes and
		# formatted with the $format string.
		($entry, $format) = &get_format(*poskeys);

		# The total size occupied by the table is the size of one item times
		# the number of items plus the final trailing message at the end of
		# the table.
		$table_size = $entry * @poskeys + length($trailing_message);

		# Output formatted table
		foreach (sort @poskeys) {
			printf($format, $_, $table_size + $Datapos{$_});
		}
		print $trailing_message;
	}

	# Output code for each dataloaded function
	foreach (@Data) {
		print;
	}
	print &q(<<'EOC');
:#
:# End of dataloading section.
:#
:
EOC
}

if (@auto > 0) {
	mkdir('auto',0755) unless -d 'auto';
	foreach $file (@auto) {
		unless (open(AUTO, ">auto/$file")) {
			warn "Can't create auto/$file: $!\n";
			next;
		}
		print AUTO &q(<<'EOC');
:# This file was generated by perload
:
EOC
		print AUTO $Auto{$file};
		close AUTO;
	}
}

# Compute optimum format for routine offset table, returning both the size of
# each entry and the formating string for printf.
sub get_format {
	local(*names) = @_;
	local($name_len) = 0;
	local($max_len) = 0;
	foreach (@names) {
		$name_len = length;
		$max_len = $name_len if $name_len > $max_len;
	}
	# The size of each entry (preceded by one tab, followed by 12 chars)
	$name_len = $max_len + 1 + 12;
	($name_len, "\t%${max_len}s %10d\n");
}

sub emit_init {
	print &q(<<'EOC');
:#
:# This perl program uses dynamic loading [generated by perload]
:#
:
:$ENV{LC_ALL} = 'C';
:
EOC
	$init_emitted = 1;
}

sub flush_comment {
	print @Comment if @Comment > 0;
	@Comment = ();
}

sub q {
	local($_) = @_;
	s/^://gm;
	$_;
}

#
# These next few lines are legal in both perl and nroff.
#

.00;		# finish .ig
 
'di			\" finish diversion--previous line must be blank
.nr nl 0-1	\" fake up transition to first page again
.nr % 0		\" start at page 1
'; __END__	\" the perl compiler stops here

'''
''' From here on it's a standard manual page.
'''

.TH PERLOAD 1 "June 20, 1992"
.AT 3
.SH NAME
perload \- builds up autoloaded and dataloaded perl scripts
.SH SYNOPSIS
.B perload
[ \fB\-ot\fR ]
[ \fIfile\fR ]
.SH DESCRIPTION
.I Perload
takes a perl script as argument (or from stdin if no argument is supplied)
and prints out on stdout an equivalent script set-up to perform autoloading
or dataloading. The translation is directed by special comments within the
original script. Using dynamic loading can drastically improve start-up
performances, both in time and in memory, as perl does not need to compile
the whole script nor store its whole compiled form in memory.
.PP
.I Autoloading
delays compilation of some functions until they are needed. The code for these
functions is loaded dynamically at run-time. The atomicity of loading is a
file, which means that putting more than one function into a file will cause
all these functions to be loaded and compiled as soon as one among them is
needed.
.PP
.I Dataloading
is a form of autoloading where no extra file are needed. The script carries
all the functions whose compilation is to be delayed in its data segment
(in the \fIperl\fR sense, i.e. they are accessible via the DATA filehandle).
The scripts parses the data segment and extracts only the code for the needed
subroutine, which means granularity is better than with autloading.
.PP
It is possible for a single script to use both autoloading and dataloading at
the same time. However, it should be noted that a script using only dataloading
is self contained and can be moved or shared accross different platforms without
fear. On the contrary, a script using only autoloading relies on some externally
provided files. Sharing this script among different platforms requires sharing
of these external files. The script itself cannot be redistributed without
also giving the extra files holding the autoloaded functions.
.PP
The major drawback with dataloading is that the DATA filehandle cannot be used
for anything else and may result in code duplication when two scripts could
share the same pieces of code. Autoloading appears as the perfect solution in
this case since two scripts may freely share the same functions without
actually duplicating them on the disk (hence saving some precious disk blocks
:-).
.SH CRITERIA
Functions to be dataloaded or autoloaded must meet the following layout
criteria:
.TP 5
\-
They must not be one-line functions like \fIsub sorter { $a <=> $b }\fR.
Those functions are simply output verbatim, as they are already so
small that it would not be worth to dynamically load them,
.TP
\-
The first line must be of the form \fIsub routine_name {\fR, with an optional
comment allowed after the '{'.
.TP
\-
The function definition must end with a single '}' character left aligned.
.TP
\-
Package directives outside any function must be left aligned.
.PP
All the above restrictions should not be source of a problem if "standard"
writing style is used. There are also some name restrictions: the package
name \fIperload\fR is reserved, as is the \fI@AUTO\fR array when autoloading
is used. Packages must not start with \fIauto_\fR, as this is prepended to
user's package names when building the stubs. Furthermore, the subroutines
names \fImain'autoload\fR and
\fImain'dataload\fR must not be used by the original script. Again, these
should not cause any grief.
.SH DIRECTIVES
The translation performed by
.I Perload
is driven by some special comment directives placed directly within the code.
Ending those directives with a ':' character will actually prevent them from
being output into the produced script. Case is irrelevant for all the directives
and the comment need not be left-aligned, although it must be the first
non-space item on the line.
.PP
The following directives are available:
.TP 10
# Perload ON
Turns on the \fIperload\fR processing. Any function definition which meets
the criteria listed in the previous section will be replaced by two stubs and
its actual definition will be rejected into the data segment (default) or a
file when inside an autoloading section.
.TP
# Perload OFF
Turns off any processing. The script is written as-is on the standard output.
.TP
# Autoload \fIpath\fR
Requests autoloading from file \fIpath\fR, which may be an absolute path or
a relative path. The file will be located at run-time using the @AUTO array
if a non-absolute path is supplied or if the file does not exist as listed.
Autoloading directives may be nested.
.TP
# Offload \fIpath\fR
The argument is not required. The directive ends the previous autoloading
directive (the inmost one). This does not turn off the \fIperload\fR processing
though. The \fIpath\fR name is optional here (in fact, it has only a comment
value).
.SH OPTIONS
Perload accepts only two options. Using \fB\-o\fR is meaningful only when
dataloading is used. It outputs an offset table which lists the relative
offset of the dataloaded functions within the data section. This will spare
perl the run-time parsing needed to locate the function, and results in an good
speed gain. However, it has one major drawback: it prevents people from
actually modifying the source beyond the start of the table. But anything
before can be freely edited, which is particulary useful when tailoring the
script.
.PP
This option should not be used when editing of functions within the data
section is necessary for whatever reason. When \fB\-o\fR is used, any
change in the dataloaded function must be committed by re-running perload
on the original script.
.PP
The other option \fB\-t\fR is to be used when producing a script which is
going to run setuid. The body of the loaded function is untainted before being
fed to eval, which slightly slows down loading (the first time the function is
called), but avoids either an insecure dependency report or weird warnings from
taintperl stating something is wrong (which is the behaviour with 4.0 PL35).
.SH FILES
.TP 10
auto
the subdirectory where all produced autoloaded files are written.
.SH ENVIRONMENT
No environment variables are used by \fIperload\fR. However, the autoloaded
version of the script pays attention to the \fIAUTOLIB\fR variable as a colon
separated set of directories where the to-be-loaded files are to be found
when a non-absolute path was specified. If the \fIAUTOLIB\fR variable is not
set, the default value 'auto:.' is used (i.e. look first in the auto/
subdirectory, then in the current directory.
.SH CAVEAT
Special care is required when using an autoloading script, especially when
executed by the super-user: it would be very easy for someone to leave a
special version of a routine to be loaded, in the hope the super-user (or
another suitable target) executes the autoloaded version of the script with
some \fIad hoc\fR changes...
.PP
The directory holding the to-be-loaded files should therefore be protected
against unauthorized access, and no file should have write permission on them.
The directory itself should not be world-writable either, or someone might
substitute his own version.
It should also be considered wise to manually set the @AUTO variable to a
suitable value within the script itself.
.PP
The \fB\-o\fR option uses \fIperl\fR's special variable \fI$/\fR with a
multi-character value. I suspect this did not work with versions of \fIperl\fR
prior to 4.0, so any script using this optimized form of dataloading will not
be 100% backward compatible.
.SH AUTHOR
Raphael Manfredi <ram@acri.fr>
.SH CREDITS
Valuable input came from Wayne H. Scott <wscott@ecn.purdue.edu>. He is
merely the author of the optimizing offset table (\fB\-o\fR option).
.PP
.I Perload
is based on an article from Tom Christiansen <tchrist@convex.com>,
.I Autoloading in Perl,
explaining the concept of dataloading and giving a basic implementation.
.SH "SEE ALSO"
perl(1).